Add Advisory.Ecosystem to support GHC's advisory

This change updates the affected schema to support GHC ecosystem
with the "component" key.
This change also implement a new OOB attribute to validate the
advisory path matchs at least one affected.

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,12 @@ module Security.Advisories.Core.Advisory
   , AffectedVersionRange(..)
   , OS(..)
   , Keyword(..)
+  , Ecosystem(..)
+  , ecosystemName
+  , ecosystemToPackage
+  , GHCComponent(..)
+  , ghcComponentToText
+  , ghcComponentFromText
   )
   where
 
@@ -44,10 +50,42 @@ data Advisory = Advisory
   }
   deriving stock (Show)
 
+-- | The affected package or component name, e.g. for user display.
+ecosystemToPackage :: Ecosystem -> Text
+ecosystemToPackage e = case e of
+  Hackage pkg -> pkg
+  GHC c -> ghcComponentToText c
+
+-- | The name of the ecosystem, e.g. for osv export.
+ecosystemName :: Ecosystem -> Text
+ecosystemName e = case e of
+  Hackage{} -> "Hackage"
+  GHC{} -> "GHC"
+
+data Ecosystem = Hackage Text | GHC GHCComponent
+  deriving stock (Show, Eq)
+
+-- Keep this list in sync with the 'ghcComponentFromText' below
+data GHCComponent = GHCCompiler | GHCi | GHCRTS
+  deriving stock (Show, Eq)
+
+ghcComponentToText :: GHCComponent -> Text
+ghcComponentToText c = case c of
+  GHCCompiler -> "compiler"
+  GHCi -> "ghci"
+  GHCRTS -> "rts"
+
+ghcComponentFromText :: Text -> Maybe GHCComponent
+ghcComponentFromText c = case c of
+  "compiler" -> Just GHCCompiler
+  "ghci" -> Just GHCi
+  "rts" -> Just GHCRTS
+  _ -> Nothing
+
 -- | An affected package (or package component).  An 'Advisory' must
 -- mention one or more packages.
 data Affected = Affected
-  { affectedPackage :: Text
+  { affectedEcosystem :: Ecosystem
   , affectedCVSS :: CVSS.CVSS
   , affectedVersions :: [AffectedVersionRange]
   , affectedArchitectures :: Maybe [Architecture]

code/hsec-tools/app/Main.hs

@@ -27,6 +27,7 @@ import qualified Security.Advisories.Convert.OSV as OSV
 import Security.Advisories.Git
 import Security.Advisories.Queries (listVersionRangeAffectedBy)
 import Security.Advisories.Generate.HTML
+import Security.Advisories.Filesystem (parseEcosystem)
 
 import qualified Command.Reserve
 
@@ -156,11 +157,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 <- parseEcosystem path
+     withExceptT GitHasNoOOB $ do
+      gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo path
       pure OutOfBandAttributes
         { oobPublished = firstAppearanceCommitDate gitInfo
         , oobModified = lastModificationCommitDate gitInfo
+        , oobEcosystem = ecosystem
         }
 
   case parseAdvisory NoOverrides oob input of

code/hsec-tools/src/Security/Advisories/Convert/OSV.hs

@@ -30,17 +30,17 @@ convert adv =
 mkAffected :: Affected -> OSV.Affected Void Void Void
 mkAffected aff =
   OSV.Affected
-    { OSV.affectedPackage = mkPackage (affectedPackage aff)
+    { OSV.affectedPackage = mkPackage (affectedEcosystem 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 :: Ecosystem -> OSV.Package
+mkPackage ecosystem = OSV.Package
+  { OSV.packageName = ecosystemToPackage ecosystem
+  , OSV.packageEcosystem = ecosystemName ecosystem
   , OSV.packagePurl = Nothing
   }
 

code/hsec-tools/src/Security/Advisories/Filesystem.hs

@@ -20,6 +20,7 @@ module Security.Advisories.Filesystem
   , forReserved
   , forAdvisory
   , listAdvisories
+  , parseEcosystem
   ) where
 
 import Control.Applicative (liftA2)
@@ -29,17 +30,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, Ecosystem(..))
 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, PathHasNoEcosystem))
+import Security.Advisories.Core.Advisory (ghcComponentFromText)
 
 
 dirNameAdvisories :: FilePath
@@ -126,15 +129,18 @@ listAdvisories root =
     if isSym
       then return $ pure []
       else do
-        oob <- runExceptT $ withExceptT GitHasNoOOB $ do
-          gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo advisoryPath
-          pure OutOfBandAttributes
-            { oobPublished = firstAppearanceCommitDate gitInfo
-            , oobModified = lastModificationCommitDate gitInfo
-            }
+        oob <- runExceptT $ do
+          ecosystem <- parseEcosystem advisoryPath
+          withExceptT GitHasNoOOB $ do
+            gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo advisoryPath
+            pure OutOfBandAttributes
+              { oobPublished = firstAppearanceCommitDate gitInfo
+              , oobModified = lastModificationCommitDate gitInfo
+              , oobEcosystem = ecosystem
+              }
         fileContent <- liftIO $ T.readFile advisoryPath
-        pure 
-          $ either (Failure . (: [])) (Success . (: [])) 
+        pure
+          $ either (Failure . (: [])) (Success . (: []))
           $ parseAdvisory NoOverrides oob fileContent
 
 -- | Get names (not paths) of subdirectories of the given directory
@@ -159,3 +165,9 @@ _forFiles root go =
       case parseHsecId (takeBaseName file) of
         Nothing -> pure mempty
         Just hsid -> go (dir </> file) hsid
+
+parseEcosystem :: Monad m => FilePath -> ExceptT OOBError m Ecosystem
+parseEcosystem fp = ExceptT . pure $ case drop 1 $ reverse $ splitDirectories fp of
+  package : "hackage" : _ -> pure (Hackage $ T.pack package)
+  component : "ghc" : _ | Just ghc <- ghcComponentFromText (T.pack component) -> pure (GHC ghc)
+  _ -> Left PathHasNoEcosystem

code/hsec-tools/src/Security/Advisories/Generate/HTML.hs

@@ -228,7 +228,7 @@ toAdvisoryR x =
     toAffectedPackageR p =
       flip map (Advisories.affectedVersions p) $ \versionRange ->
         AffectedPackageR
-          { packageName = Advisories.affectedPackage p,
+          { packageName = Advisories.ecosystemToPackage (Advisories.affectedEcosystem p),
             introduced = T.pack $ prettyShow $ Advisories.affectedVersionRangeIntroduced versionRange,
             fixed = T.pack . prettyShow <$> Advisories.affectedVersionRangeFixed versionRange
           }

code/hsec-tools/src/Security/Advisories/Parse.hs

@@ -23,6 +23,7 @@ import Data.List (intercalate)
 import Data.Maybe (fromMaybe)
 import Data.Monoid (First(..))
 import Data.Tuple (swap)
+import Control.Applicative ((<|>))
 import GHC.Generics (Generic)
 
 import qualified Data.Map as Map
@@ -61,14 +62,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
+  , oobEcosystem :: Ecosystem
   }
   deriving (Show)
 
@@ -96,14 +93,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
+  | PathHasNoEcosystem -- ^ 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"
+  PathHasNoEcosystem -> "the path is missing 'hackage' or 'ghc' directory"
   GitHasNoOOB gitErr -> "no out of band information obtained with git error:\n"
     <> explainGitError gitErr
 
@@ -195,6 +194,10 @@ parseAdvisoryTable oob policy doc summary details html tab =
             (oobPublished <$> oob)
             "advisory.modified"
             (amdModified (frontMatterAdvisory fm))
+      let affected = frontMatterAffected fm
+      case oob of
+        Right attr -> validateEcosystem (oobEcosystem attr) affected
+        _ -> pure ()
       pure Advisory
         { advisoryId = amdId (frontMatterAdvisory fm)
         , advisoryPublished = published
@@ -204,14 +207,20 @@ 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
         , advisorySummary = summary
         , advisoryDetails = details
         }
 
+-- | Make sure one of the affected match the ecosystem
+validateEcosystem :: MonadFail m => Ecosystem -> [Affected] -> m ()
+validateEcosystem ecosystem xs
+  | any (\affected -> affectedEcosystem affected == ecosystem) xs = pure ()
+  | otherwise = fail $ "Expected an affected to match the ecosystem: " <> show ecosystem
+
 -- | Internal type corresponding to the complete raw TOML content of an
 -- advisory markdown file.
 data FrontMatter = FrontMatter {
@@ -290,16 +299,25 @@ 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 = \case
+    Toml.Text' _ n
+      | Just c <- ghcComponentFromText n -> pure c
+    v -> Toml.failAt (Toml.valueAnn v) "Invalid component, expected compiler|ghci|rts"
+
+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 "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
+        { affectedEcosystem = ecosystem
         , affectedCVSS = cvss
         , affectedVersions = versions
         , affectedArchitectures = arch
@@ -312,14 +330,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 affectedEcosystem x of
+        Hackage pkg -> ["package" Toml..= pkg]
+        GHC c -> ["component" Toml..= c]
       asTable kvs = Map.fromList [(T.unpack k, v) | (k,v) <- kvs]
 
 instance Toml.FromValue AffectedVersionRange where

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 affectedEcosystem 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

code/hsec-tools/test/Spec.hs

@@ -16,6 +16,7 @@ import Text.Pretty.Simple (pShowNoColor)
 
 import qualified Security.Advisories.Convert.OSV as OSV
 import Security.Advisories.Parse
+import Security.Advisories.Core.Advisory (Ecosystem(Hackage))
 import qualified Spec.QueriesSpec as QueriesSpec
 
 main :: IO ()
@@ -42,9 +43,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
+              , oobEcosystem = Hackage "package-name"
               }
             res = parseAdvisory NoOverrides (Right attr) input
             osvExport = case res of

code/hsec-tools/test/Spec/QueriesSpec.hs

@@ -115,7 +115,7 @@ mkAdvisory versionRange =
      , advisoryRelated = [ "CVE-2022-YYYY" , "CVE-2022-ZZZZ" ]
      , advisoryAffected =
          [ Affected
-             { affectedPackage = packageName
+             { affectedEcosystem = Hackage packageName
              , affectedCVSS = cvss
              , affectedVersions = mkAffectedVersions versionRange
              , affectedArchitectures = Nothing

code/hsec-tools/test/golden/EXAMPLE_ADVISORY.md.golden

@@ -17,7 +17,7 @@ Right
             ]
         , advisoryAffected =
             [ Affected
-                { affectedPackage = "package-name"
+                { affectedEcosystem = 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