Add Advisory.Ecosystem to support GHC's advisory

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]

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

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 =

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

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

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
           }

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,14 +202,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
+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