Add Advisory.Ecosystem to support GHC's advisory

This change adds a new OOB to pass the Ecosystem value from
the advisory path.

code/hsec-core/src/Security/Advisories/Core/Advisory.hs

@@ -10,6 +10,8 @@ module Security.Advisories.Core.Advisory
   , AffectedVersionRange(..)
   , OS(..)
   , Keyword(..)
+  , Ecosystem(..)
+  , GHCComponent(..)
   )
   where
 
@@ -26,6 +28,7 @@ import Security.OSV (Reference)
 
 data Advisory = Advisory
   { advisoryId :: HsecId
+  , advisoryEcosystem :: Ecosystem
   , advisoryModified :: UTCTime
   , advisoryPublished :: UTCTime
   , advisoryCAPECs :: [CAPEC]
@@ -44,6 +47,12 @@ data Advisory = Advisory
   }
   deriving stock (Show)
 
+data Ecosystem = Hackage | GHC GHCComponent
+  deriving stock (Show)
+
+data GHCComponent = GHCCompiler | GHCi | GHCRTS
+  deriving stock (Show)
+
 -- | An affected package (or package component).  An 'Advisory' must
 -- mention one or more packages.
 data Affected = Affected

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

@@ -24,23 +24,25 @@ convert adv =
   , OSV.modelSummary = Just $ advisorySummary adv
   , OSV.modelDetails = Just $ advisoryDetails adv
   , OSV.modelReferences = advisoryReferences adv
-  , OSV.modelAffected = fmap mkAffected (advisoryAffected adv)
+  , OSV.modelAffected = fmap (mkAffected (advisoryEcosystem adv)) (advisoryAffected adv)
   }
 
-mkAffected :: Affected -> OSV.Affected Void Void Void
-mkAffected aff =
+mkAffected :: Ecosystem -> Affected -> OSV.Affected Void Void Void
+mkAffected ecosystem aff =
   OSV.Affected
-    { OSV.affectedPackage = mkPackage (affectedPackage aff)
+    { OSV.affectedPackage = mkPackage ecosystem (affectedPackage 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
+mkPackage :: Ecosystem -> T.Text -> OSV.Package
+mkPackage ecosystem name = OSV.Package
   { OSV.packageName = name
-  , OSV.packageEcosystem = "Hackage"
+  , OSV.packageEcosystem = case ecosystem of
+      GHC _ -> "GHC"
+      Hackage -> "Hackage"
   , 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)
@@ -30,16 +31,16 @@ import Data.Traversable (for)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Writer.Strict (execWriterT, tell)
 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(..), GHCComponent(..))
 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))
 
 
 dirNameAdvisories :: FilePath
@@ -126,15 +127,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 +163,11 @@ _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
+  _component : "hackage" : _ -> pure Hackage
+  "compiler" : "ghc" : _ -> pure (GHC GHCCompiler)
+  "ghci" : "ghc" : _ -> pure (GHC GHCi)
+  "rts" : "ghc" : _ -> pure (GHC GHCRTS)
+  _xs -> Left PathHasNoEcosystem

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

@@ -61,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
+  , oobEcosystem :: Ecosystem
   }
   deriving (Show)
 
@@ -96,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
+  | 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,8 +193,15 @@ parseAdvisoryTable oob policy doc summary details html tab =
             (oobPublished <$> oob)
             "advisory.modified"
             (amdModified (frontMatterAdvisory fm))
+      ecosystem <-
+        mergeOobMandatory policy
+          (oobEcosystem <$> oob)
+          displayOOBError
+          "advisory.ecosystem"
+          Nothing
       pure Advisory
         { advisoryId = amdId (frontMatterAdvisory fm)
+        , advisoryEcosystem = ecosystem
         , advisoryPublished = published
         , advisoryModified = modified
         , advisoryCAPECs = amdCAPECs (frontMatterAdvisory fm)