diff --git a/code/hsec-core/src/Security/Advisories/Core/Advisory.hs b/code/hsec-core/src/Security/Advisories/Core/Advisory.hs index 08d30707..92ef84d7 100644 --- a/code/hsec-core/src/Security/Advisories/Core/Advisory.hs +++ b/code/hsec-core/src/Security/Advisories/Core/Advisory.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DerivingVia, OverloadedStrings #-} module Security.Advisories.Core.Advisory ( Advisory(..) @@ -10,6 +10,10 @@ module Security.Advisories.Core.Advisory , AffectedVersionRange(..) , OS(..) , Keyword(..) + , ComponentIdentifier(..) + , GHCComponent(..) + , ghcComponentToText + , ghcComponentFromText ) where @@ -44,10 +48,44 @@ data Advisory = Advisory } deriving stock (Show) +data ComponentIdentifier = Hackage Text | GHC GHCComponent + deriving stock (Show, Eq) + +-- Keep this list in sync with the 'ghcComponentFromText' below +data GHCComponent = GHCCompiler | GHCi | GHCRTS | GHCPkg | RunGHC | IServ | HP2PS | HPC | HSC2HS | Haddock + deriving stock (Show, Eq, Enum, Bounded) + +ghcComponentToText :: GHCComponent -> Text +ghcComponentToText c = case c of + GHCCompiler -> "ghc" + GHCi -> "ghci" + GHCRTS -> "rts" + GHCPkg -> "ghc-pkg" + RunGHC -> "runghc" + IServ -> "ghc-iserv" + HP2PS -> "hp2ps" + HPC -> "hpc" + HSC2HS -> "hsc2hs" + Haddock -> "haddock" + +ghcComponentFromText :: Text -> Maybe GHCComponent +ghcComponentFromText c = case c of + "ghc" -> Just GHCCompiler + "ghci" -> Just GHCi + "rts" -> Just GHCRTS + "ghc-pkg" -> Just GHCPkg + "runghc" -> Just RunGHC + "ghc-iserv" -> Just IServ + "hp2ps" -> Just HP2PS + "hpc" -> Just HPC + "hsc2hs" -> Just HSC2HS + "haddock" -> Just Haddock + _ -> Nothing + -- | An affected package (or package component). An 'Advisory' must -- mention one or more packages. data Affected = Affected - { affectedPackage :: Text + { affectedComponentIdentifier :: ComponentIdentifier , affectedCVSS :: CVSS.CVSS , affectedVersions :: [AffectedVersionRange] , affectedArchitectures :: Maybe [Architecture] diff --git a/code/hsec-tools/app/Main.hs b/code/hsec-tools/app/Main.hs index d68c716f..2163aead 100644 --- a/code/hsec-tools/app/Main.hs +++ b/code/hsec-tools/app/Main.hs @@ -23,6 +23,7 @@ import Security.Advisories.Generate.HTML import Security.Advisories.Generate.Snapshot import Security.Advisories.Git import Security.Advisories.Queries (listVersionRangeAffectedBy) +import Security.Advisories.Filesystem (parseComponentIdentifier) import System.Exit (die, exitFailure, exitSuccess) import System.FilePath (takeBaseName) import System.IO (hPrint, hPutStrLn, stderr) @@ -167,11 +168,14 @@ withAdvisory go file = do oob <- runExceptT $ case file of Nothing -> throwE StdInHasNoOOB - Just path -> withExceptT GitHasNoOOB $ do - gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo path + Just path -> do + ecosystem <- parseComponentIdentifier path + withExceptT GitHasNoOOB $ do + gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo path pure OutOfBandAttributes { oobPublished = firstAppearanceCommitDate gitInfo , oobModified = lastModificationCommitDate gitInfo + , oobComponentIdentifier = ecosystem } case parseAdvisory NoOverrides oob input of diff --git a/code/hsec-tools/src/Security/Advisories/Convert/OSV.hs b/code/hsec-tools/src/Security/Advisories/Convert/OSV.hs index 07cffcfa..c63e0e72 100644 --- a/code/hsec-tools/src/Security/Advisories/Convert/OSV.hs +++ b/code/hsec-tools/src/Security/Advisories/Convert/OSV.hs @@ -30,19 +30,23 @@ convert adv = mkAffected :: Affected -> OSV.Affected Void Void Void mkAffected aff = OSV.Affected - { OSV.affectedPackage = mkPackage (affectedPackage aff) + { OSV.affectedPackage = mkPackage (affectedComponentIdentifier aff) , OSV.affectedRanges = pure $ mkRange (affectedVersions aff) , OSV.affectedSeverity = [OSV.Severity (affectedCVSS aff)] , OSV.affectedEcosystemSpecific = Nothing , OSV.affectedDatabaseSpecific = Nothing } -mkPackage :: T.Text -> OSV.Package -mkPackage name = OSV.Package - { OSV.packageName = name - , OSV.packageEcosystem = "Hackage" +mkPackage :: ComponentIdentifier -> OSV.Package +mkPackage ecosystem = OSV.Package + { OSV.packageName = packageName + , OSV.packageEcosystem = ecosystemName , OSV.packagePurl = Nothing } + where + (ecosystemName, packageName) = case ecosystem of + Hackage n -> ("Hackage", n) + GHC c -> ("GHC", ghcComponentToText c) mkRange :: [AffectedVersionRange] -> OSV.Range Void mkRange ranges = diff --git a/code/hsec-tools/src/Security/Advisories/Filesystem.hs b/code/hsec-tools/src/Security/Advisories/Filesystem.hs index 2e65dc15..897a7d2d 100644 --- a/code/hsec-tools/src/Security/Advisories/Filesystem.hs +++ b/code/hsec-tools/src/Security/Advisories/Filesystem.hs @@ -21,6 +21,7 @@ module Security.Advisories.Filesystem , forAdvisory , listAdvisories , advisoryFromFile + , parseComponentIdentifier ) where import Control.Applicative (liftA2) @@ -31,17 +32,19 @@ import Data.Traversable (for) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Writer.Strict (execWriterT, tell) +import qualified Data.Text as T import qualified Data.Text.IO as T -import System.FilePath ((), takeBaseName) +import System.FilePath ((), takeBaseName, splitDirectories) import System.Directory (doesDirectoryExist, pathIsSymbolicLink) import System.Directory.PathWalk import Validation (Validation (..)) -import Security.Advisories (Advisory, AttributeOverridePolicy (NoOverrides), OutOfBandAttributes (..), ParseAdvisoryError, parseAdvisory) +import Security.Advisories (Advisory, AttributeOverridePolicy (NoOverrides), OutOfBandAttributes (..), ParseAdvisoryError, parseAdvisory, ComponentIdentifier(..)) import Security.Advisories.Core.HsecId (HsecId, parseHsecId, placeholder) import Security.Advisories.Git(firstAppearanceCommitDate, getAdvisoryGitInfo, lastModificationCommitDate) import Control.Monad.Except (runExceptT, ExceptT (ExceptT), withExceptT) -import Security.Advisories.Parse (OOBError(GitHasNoOOB)) +import Security.Advisories.Parse (OOBError(GitHasNoOOB, PathHasNoComponentIdentifier)) +import Security.Advisories.Core.Advisory (ghcComponentFromText) dirNameAdvisories :: FilePath @@ -136,14 +139,17 @@ advisoryFromFile :: (MonadIO m) => FilePath -> m (Validation ParseAdvisoryError Advisory) advisoryFromFile advisoryPath = do - oob <- runExceptT $ withExceptT GitHasNoOOB $ do + oob <- runExceptT $ do + ecosystem <- parseComponentIdentifier advisoryPath + withExceptT GitHasNoOOB $ do gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo advisoryPath pure OutOfBandAttributes { oobPublished = firstAppearanceCommitDate gitInfo , oobModified = lastModificationCommitDate gitInfo + , oobComponentIdentifier = ecosystem } fileContent <- liftIO $ T.readFile advisoryPath - pure + pure $ either Failure Success $ parseAdvisory NoOverrides oob fileContent @@ -169,3 +175,10 @@ _forFiles root go = case parseHsecId (takeBaseName file) of Nothing -> pure mempty Just hsid -> go (dir file) hsid + +parseComponentIdentifier :: Monad m => FilePath -> ExceptT OOBError m (Maybe ComponentIdentifier) +parseComponentIdentifier fp = ExceptT . pure $ case drop 1 $ reverse $ splitDirectories fp of + package : "hackage" : _ -> pure (Just $ Hackage $ T.pack package) + component : "ghc" : _ | Just ghc <- ghcComponentFromText (T.pack component) -> pure (Just $ GHC ghc) + _ : _ : "advisories" : _ -> Left PathHasNoComponentIdentifier + _ -> pure Nothing diff --git a/code/hsec-tools/src/Security/Advisories/Format.hs b/code/hsec-tools/src/Security/Advisories/Format.hs index 7107522d..19037c53 100644 --- a/code/hsec-tools/src/Security/Advisories/Format.hs +++ b/code/hsec-tools/src/Security/Advisories/Format.hs @@ -15,6 +15,7 @@ module Security.Advisories.Format ) where +import Control.Applicative ((<|>)) import Commonmark.Types (HasAttributes (..), IsBlock (..), IsInline (..), Rangeable (..), SourceRange (..)) import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -135,16 +136,36 @@ instance Toml.ToTable AdvisoryMetadata where ["aliases" Toml..= amdAliases x | not (null (amdAliases x))] ++ ["related" Toml..= amdRelated x | not (null (amdRelated x))] +instance Toml.FromValue GHCComponent where + fromValue v = case v of + Toml.Text' _ n + | Just c <- ghcComponentFromText n + -> pure c + | otherwise + -> Toml.failAt (Toml.valueAnn v) $ + "Invalid ghc-component '" + <> T.unpack n + <> "', expected " + <> T.unpack (T.intercalate "|" componentNames) + _ -> Toml.failAt (Toml.valueAnn v) $ + "Non-text ghc-component, expected" + <> T.unpack (T.intercalate "|" componentNames) + where + componentNames = map ghcComponentToText [minBound..maxBound] + +instance Toml.ToValue GHCComponent where + toValue = Toml.Text' () . ghcComponentToText + instance Toml.FromValue Affected where fromValue = Toml.parseTableFromValue $ - do package <- Toml.reqKey "package" + do ecosystem <- (Hackage <$> Toml.reqKey "package") <|> (GHC <$> Toml.reqKey "ghc-component") cvss <- Toml.reqKey "cvss" -- TODO validate CVSS format os <- Toml.optKey "os" arch <- Toml.optKey "arch" decls <- maybe [] Map.toList <$> Toml.optKey "declarations" versions <- Toml.reqKey "versions" pure $ Affected - { affectedPackage = package + { affectedComponentIdentifier = ecosystem , affectedCVSS = cvss , affectedVersions = versions , affectedArchitectures = arch @@ -157,14 +178,17 @@ instance Toml.ToValue Affected where instance Toml.ToTable Affected where toTable x = Toml.table $ - [ "package" Toml..= affectedPackage x - , "cvss" Toml..= affectedCVSS x + ecosystem ++ + [ "cvss" Toml..= affectedCVSS x , "versions" Toml..= affectedVersions x ] ++ [ "os" Toml..= y | Just y <- [affectedOS x]] ++ [ "arch" Toml..= y | Just y <- [affectedArchitectures x]] ++ [ "declarations" Toml..= asTable (affectedDeclarations x) | not (null (affectedDeclarations x))] where + ecosystem = case affectedComponentIdentifier x of + Hackage pkg -> ["package" Toml..= pkg] + GHC c -> ["ghc-component" Toml..= c] asTable kvs = Map.fromList [(T.unpack k, v) | (k,v) <- kvs] instance Toml.FromValue AffectedVersionRange where diff --git a/code/hsec-tools/src/Security/Advisories/Generate/HTML.hs b/code/hsec-tools/src/Security/Advisories/Generate/HTML.hs index 2ef4dc33..b28cfc6b 100644 --- a/code/hsec-tools/src/Security/Advisories/Generate/HTML.hs +++ b/code/hsec-tools/src/Security/Advisories/Generate/HTML.hs @@ -35,6 +35,7 @@ import Validation (Validation (..)) import qualified Security.Advisories as Advisories import Security.Advisories.Filesystem (listAdvisories) import Security.Advisories.Generate.TH (readDirFilesTH) +import Security.Advisories.Core.Advisory (ComponentIdentifier (..), ghcComponentToText) -- * Actions @@ -87,7 +88,7 @@ data AdvisoryR = AdvisoryR deriving stock (Show) data AffectedPackageR = AffectedPackageR - { packageName :: Text, + { ecosystem :: ComponentIdentifier, introduced :: Text, fixed :: Maybe Text } @@ -118,6 +119,11 @@ listByDates advisories = td_ [class_ "advisory-packages"] $ toHtml $ T.intercalate "," $ packageName <$> advisoryAffected advisory td_ [class_ "advisory-summary"] $ toHtml $ advisorySummary advisory +packageName :: AffectedPackageR -> Text +packageName af = case ecosystem af of + Hackage n -> n + GHC c -> "ghc:" <> ghcComponentToText c + listByPackages :: [AdvisoryR] -> Html () listByPackages advisories = inPage PageListByPackages $ do @@ -231,7 +237,7 @@ toAdvisoryR x = toAffectedPackageR p = flip map (Advisories.affectedVersions p) $ \versionRange -> AffectedPackageR - { packageName = Advisories.affectedPackage p, + { ecosystem = Advisories.affectedComponentIdentifier p, introduced = T.pack $ prettyShow $ Advisories.affectedVersionRangeIntroduced versionRange, fixed = T.pack . prettyShow <$> Advisories.affectedVersionRangeFixed versionRange } diff --git a/code/hsec-tools/src/Security/Advisories/Parse.hs b/code/hsec-tools/src/Security/Advisories/Parse.hs index e5389506..b16f7f78 100644 --- a/code/hsec-tools/src/Security/Advisories/Parse.hs +++ b/code/hsec-tools/src/Security/Advisories/Parse.hs @@ -16,6 +16,7 @@ , displayOOBError , AttributeOverridePolicy(..) , ParseAdvisoryError(..) + , validateComponentIdentifier ) where @@ -24,6 +25,10 @@ import Data.Bifunctor (first) import Data.Foldable (toList) import Data.Maybe (fromMaybe) import Data.Monoid (First(..)) + +import Data.Tuple (swap) +import Control.Applicative ((<|>)) + import GHC.Generics (Generic) import Data.Sequence (Seq((:<|))) @@ -56,14 +61,10 @@ type OOB = Either OOBError OutOfBandAttributes -- | A source of attributes supplied out of band from the advisory -- content. Values provided out of band are treated according to -- the 'AttributeOverridePolicy'. --- --- The convenient way to construct a value of this type is to start --- with 'emptyOutOfBandAttributes', then use the record accessors to --- set particular fields. --- data OutOfBandAttributes = OutOfBandAttributes { oobModified :: UTCTime , oobPublished :: UTCTime + , oobComponentIdentifier :: Maybe ComponentIdentifier } deriving (Show) @@ -81,8 +82,8 @@ data ParseAdvisoryError deriving stock (Eq, Show, Generic) -- | @since 0.2.0.0 -instance Exception ParseAdvisoryError where - displayException = T.unpack . \case +instance Exception ParseAdvisoryError where + displayException = T.unpack . \case MarkdownError _ explanation -> "Markdown parsing error:\n" <> explanation MarkdownFormatError explanation -> "Markdown structure error:\n" <> explanation TomlError _ explanation -> "Couldn't parse front matter as TOML:\n" <> explanation @@ -91,14 +92,16 @@ instance Exception ParseAdvisoryError where -- | errors that may occur while ingesting oob data -- -- @since 0.2.0.0 -data OOBError +data OOBError = StdInHasNoOOB -- ^ we obtain the advisory via stdin and can hence not parse git history + | PathHasNoComponentIdentifier -- ^ the path is missing 'hackage' or 'ghc' directory | GitHasNoOOB GitError -- ^ processing oob info via git failed deriving stock (Eq, Show, Generic) -displayOOBError :: OOBError -> String -displayOOBError = \case +displayOOBError :: OOBError -> String +displayOOBError = \case StdInHasNoOOB -> "stdin doesn't provide out of band information" + PathHasNoComponentIdentifier -> "the path is missing 'hackage' or 'ghc' directory" GitHasNoOOB gitErr -> "no out of band information obtained with git error:\n" <> explainGitError gitErr @@ -186,6 +189,10 @@ parseAdvisoryTable oob policy doc summary details html tab = (oobPublished <$> oob) "advisory.modified" (amdModified (frontMatterAdvisory fm)) + let affected = frontMatterAffected fm + case oob of + Right (OutOfBandAttributes _ _ (Just ecosystem)) -> validateComponentIdentifier ecosystem affected + _ -> pure () pure Advisory { advisoryId = amdId (frontMatterAdvisory fm) , advisoryPublished = published @@ -195,7 +202,7 @@ parseAdvisoryTable oob policy doc summary details html tab = , advisoryKeywords = amdKeywords (frontMatterAdvisory fm) , advisoryAliases = amdAliases (frontMatterAdvisory fm) , advisoryRelated = amdRelated (frontMatterAdvisory fm) - , advisoryAffected = frontMatterAffected fm + , advisoryAffected = affected , advisoryReferences = frontMatterReferences fm , advisoryPandoc = doc , advisoryHtml = html @@ -203,6 +210,12 @@ parseAdvisoryTable oob policy doc summary details html tab = , advisoryDetails = details } +-- | Make sure one of the affected match the ecosystem +validateComponentIdentifier :: MonadFail m => ComponentIdentifier -> [Affected] -> m () +validateComponentIdentifier ecosystem xs + | any (\affected -> affectedComponentIdentifier affected == ecosystem) xs = pure () + | otherwise = fail $ "Expected an affected to match the ecosystem: " <> show ecosystem + advisoryDoc :: Blocks -> Either Text (Text, [Block]) advisoryDoc (Many blocks) = case blocks of CodeBlock (_, classes, _) frontMatter :<| t @@ -274,10 +287,10 @@ mergeOobMandatory -> m a mergeOobMandatory policy eoob doob k ib = mergeOob policy eoob k ib everythingFailed pure - where - everythingFailed e = fail $ unlines - [ "while trying to lookup mandatory key " <> show k <> ":" - , doob e + where + everythingFailed e = fail $ unlines + [ "while trying to lookup mandatory key " <> show k <> ":" + , doob e ] {- | A solution to an awkward problem: how to delete the TOML diff --git a/code/hsec-tools/src/Security/Advisories/Queries.hs b/code/hsec-tools/src/Security/Advisories/Queries.hs index cae48c7b..06ed2b25 100644 --- a/code/hsec-tools/src/Security/Advisories/Queries.hs +++ b/code/hsec-tools/src/Security/Advisories/Queries.hs @@ -38,9 +38,10 @@ isAffectedByHelper checkWithRange queryPackageName queryVersionish = any checkAffected . advisoryAffected where checkAffected :: Affected -> Bool - checkAffected affected = - queryPackageName == affectedPackage affected - && checkWithRange queryVersionish (fromAffected affected) + checkAffected affected = case affectedComponentIdentifier affected of + Hackage pkg -> queryPackageName == pkg && checkWithRange queryVersionish (fromAffected affected) + -- TODO: support GHC ecosystem query, e.g. by adding a cli flag + _ -> False fromAffected :: Affected -> VersionRange fromAffected = foldr (unionVersionRanges . fromAffectedVersionRange) noVersion . affectedVersions diff --git a/code/hsec-tools/test/Spec.hs b/code/hsec-tools/test/Spec.hs index 9c157b2e..836e19ec 100644 --- a/code/hsec-tools/test/Spec.hs +++ b/code/hsec-tools/test/Spec.hs @@ -44,9 +44,10 @@ doGoldenTest fp = goldenVsString fp (fp <> ".golden") (LText.encodeUtf8 <$> doCh doCheck = do input <- T.readFile fp let fakeDate = UTCTime (fromOrdinalDate 1970 0) 0 - attr = OutOfBandAttributes + attr = OutOfBandAttributes { oobPublished = fakeDate , oobModified = fakeDate + , oobComponentIdentifier = Nothing } res = parseAdvisory NoOverrides (Right attr) input osvExport = case res of diff --git a/code/hsec-tools/test/Spec/FormatSpec.hs b/code/hsec-tools/test/Spec/FormatSpec.hs index 5aac95e6..8a4e1d7a 100644 --- a/code/hsec-tools/test/Spec/FormatSpec.hs +++ b/code/hsec-tools/test/Spec/FormatSpec.hs @@ -70,13 +70,19 @@ genAdvisoryMetadata = genAffected :: Gen.Gen Affected genAffected = Affected - <$> genText + <$> genComponentIdentifier <*> genCVSS <*> Gen.list (Range.linear 0 5) genAffectedVersionRange <*> Gen.maybe (Gen.list (Range.linear 0 5) genArchitecture) <*> Gen.maybe (Gen.list (Range.linear 0 5) genOS) <*> (Map.toList . Map.fromList <$> Gen.list (Range.linear 0 5) ((,) <$> genText <*> genVersionRange)) +genComponentIdentifier :: Gen.Gen ComponentIdentifier +genComponentIdentifier = Gen.choice $ + [ Hackage <$> genText + , GHC <$> Gen.enumBounded + ] + genCVSS :: Gen.Gen CVSS genCVSS = Gen.choice $ diff --git a/code/hsec-tools/test/Spec/QueriesSpec.hs b/code/hsec-tools/test/Spec/QueriesSpec.hs index 6c8137f9..54be3d90 100644 --- a/code/hsec-tools/test/Spec/QueriesSpec.hs +++ b/code/hsec-tools/test/Spec/QueriesSpec.hs @@ -115,7 +115,7 @@ mkAdvisory versionRange = , advisoryRelated = [ "CVE-2022-YYYY" , "CVE-2022-ZZZZ" ] , advisoryAffected = [ Affected - { affectedPackage = packageName + { affectedComponentIdentifier = Hackage packageName , affectedCVSS = cvss , affectedVersions = mkAffectedVersions versionRange , affectedArchitectures = Nothing diff --git a/code/hsec-tools/test/golden/EXAMPLE_ADVISORY.md.golden b/code/hsec-tools/test/golden/EXAMPLE_ADVISORY.md.golden index 14695047..62dda0c3 100644 --- a/code/hsec-tools/test/golden/EXAMPLE_ADVISORY.md.golden +++ b/code/hsec-tools/test/golden/EXAMPLE_ADVISORY.md.golden @@ -17,7 +17,7 @@ Right ] , advisoryAffected = [ Affected - { affectedPackage = "package-name" + { affectedComponentIdentifier = Hackage "package-name" , affectedCVSS = CVSS:3.1/AV:N/AC:L/PR:N/UI:N/S:U/C:H/I:H/A:H , affectedVersions = [ AffectedVersionRange