hsec-tools 0.1.0.0 → 0.2.0.2

raw patch · 22 files changed

+1531/−701 lines, 22 filesdep +atom-conduitdep +conduitdep +conduit-extradep −feeddep ~Cabal-syntaxdep ~basedep ~bytestringnew-uploaderbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: atom-conduit, conduit, conduit-extra, data-default, file-embed, hedgehog, pandoc, pretty, prettyprinter, refined, resourcet, tasty-hedgehog, template-haskell, transformers, uri-bytestring, xml-conduit

Dependencies removed: feed

Dependency ranges changed: Cabal-syntax, base, bytestring, containers, cvss, extra, filepath, hsec-core, osv, tasty, time, toml-parser

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• README.md +15/−0
• app/Command/NextID.hs +10/−0
• app/Command/Reserve.hs +4/−12
• app/Main.hs +96/−78
• app/Util.hs +21/−0
• assets/css/default.css +156/−0
• assets/images/hf-logo.png binary
• hsec-tools.cabal +61/−24
• src/Security/Advisories/Convert/OSV.hs +11/−8
• src/Security/Advisories/Filesystem.hs +39/−18
• src/Security/Advisories/Format.hs +376/−0
• src/Security/Advisories/Generate/HTML.hs +260/−119
• src/Security/Advisories/Generate/Snapshot.hs +84/−0
• src/Security/Advisories/Generate/TH.hs +22/−0
• src/Security/Advisories/Git.hs +10/−5
• src/Security/Advisories/Parse.hs +147/−410
• src/Security/Advisories/Queries.hs +15/−6
• test/Spec.hs +22/−19
• test/Spec/FormatSpec.hs +168/−0
• test/Spec/QueriesSpec.hs +1/−1
• test/golden/EXAMPLE_ADVISORY.md.golden +1/−1

@@ -0,0 +1,12 @@+## 0.2.0.2++* Update `tasty` dependency bounds+* Update `osv` dependency bounds++## 0.2.0.1++- Rework HTML/Atom generation, use `atom-conduit` instead of `feed`++## 0.1.1.0++- Redesign index

@@ -0,0 +1,15 @@+# hsec-tools++`hesc-tools` aims to support [Haskell advisories database](https://github.com/haskell/security-advisories).++## Building++We aim to support both regular cabal-based and nix-based builds.++## Testing++Run (and auto update) the golden test:++```ShellSession+cabal test -O0 --test-show-details=direct --test-option=--accept+```

@@ -0,0 +1,10 @@+module Command.NextID where++import Security.Advisories.Core.HsecId (printHsecId, getNextHsecId)+import Security.Advisories.Filesystem (getGreatestId)++import Util (ensureRepo)++runNextIDCommand :: Maybe FilePath -> IO ()+runNextIDCommand mPath =+  ensureRepo mPath >>= getGreatestId >>= getNextHsecId >>= putStrLn . printHsecId

@@ -2,8 +2,7 @@  module Command.Reserve where -import Control.Monad (unless, when)-import Data.Maybe (fromMaybe)+import Control.Monad (when) import System.Exit (die) import System.FilePath ((</>), (<.>)) @@ -11,7 +10,6 @@   ( add   , commit   , explainGitError-  , getRepoRoot   ) import Security.Advisories.Core.HsecId   ( placeholder@@ -21,10 +19,11 @@ import Security.Advisories.Filesystem   ( dirNameAdvisories   , dirNameReserved-  , isSecurityAdvisoriesRepo   , getGreatestId   ) +import Util (ensureRepo)+ -- | How to choose IDs when creating advisories or -- reservations. data IdMode@@ -40,14 +39,7 @@  runReserveCommand :: Maybe FilePath -> IdMode -> CommitFlag -> IO () runReserveCommand mPath idMode commitFlag = do-  let-    path = fromMaybe "." mPath-  repoPath <- getRepoRoot path >>= \case-    Left _ -> die "Not a git repo"-    Right a -> pure a-  isRepo <- isSecurityAdvisoriesRepo repoPath-  unless isRepo $-    die "Not a security-advisories repo"+  repoPath <- ensureRepo mPath    hsid <- case idMode of     IdModePlaceholder -> pure placeholder

@@ -1,39 +1,42 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}  module Main where  import Control.Monad (forM_, join, void, when)+import Control.Monad.Trans.Except (runExceptT, ExceptT (ExceptT), withExceptT, throwE)+import Control.Monad.IO.Class (liftIO)+import qualified Data.Aeson import qualified Data.ByteString.Lazy as L-import Data.Maybe (fromMaybe) import Data.Foldable (for_)-import Data.Functor ((<&>)) import Data.List (intercalate, isPrefixOf)-import Distribution.Parsec (eitherParsec)-import Distribution.Types.VersionRange (VersionRange, anyVersion)-import System.Exit (die, exitFailure, exitSuccess)-import System.IO (hPrint, hPutStrLn, stderr)-import System.FilePath (takeBaseName)-import Validation (Validation(..))--import qualified Data.Aeson+import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T+import Control.Exception (Exception(displayException))+import Distribution.Parsec (eitherParsec)+import Distribution.Types.VersionRange (VersionRange, anyVersion) import Options.Applicative- import Security.Advisories import qualified Security.Advisories.Convert.OSV as OSV+import Security.Advisories.Generate.HTML+import Security.Advisories.Generate.Snapshot import Security.Advisories.Git import Security.Advisories.Queries (listVersionRangeAffectedBy)-import Security.Advisories.Generate.HTML+import Security.Advisories.Filesystem (parseComponentIdentifier)+import System.Exit (die, exitFailure, exitSuccess)+import System.FilePath (takeBaseName)+import System.IO (hPrint, hPutStrLn, stderr)+import Validation (Validation (..))  import qualified Command.Reserve+import qualified Command.NextID  main :: IO ()-main = join $-  customExecParser-    (prefs showHelpOnEmpty)-    cliOpts+main =+  join $+    customExecParser+      (prefs showHelpOnEmpty)+      cliOpts  cliOpts :: ParserInfo (IO ()) cliOpts = info (commandsParser <**> helper) (fullDesc <> header "Haskell Advisories tools")@@ -41,55 +44,63 @@     commandsParser :: Parser (IO ())     commandsParser =       hsubparser-        (  command "check" (info commandCheck (progDesc "Syntax check a single advisory"))-        <> command "reserve" (info commandReserve (progDesc "Reserve an HSEC ID"))-        <> command "osv" (info commandOsv (progDesc "Convert a single advisory to OSV"))-        <> command "render" (info commandRender (progDesc "Render a single advisory as HTML"))-        <> command "generate-index" (info commandGenerateIndex (progDesc "Generate an HTML index"))-        <> command "query" (info commandQuery (progDesc "Run various queries against the database"))-        <> command "help" (info commandHelp (progDesc "Show command help"))+        ( command "check" (info commandCheck (progDesc "Syntax check a single advisory"))+            <> command "next-id" (info commandNextID (progDesc "Print the next available HSEC ID"))+            <> command "reserve" (info commandReserve (progDesc "Reserve an HSEC ID"))+            <> command "osv" (info commandOsv (progDesc "Convert a single advisory to OSV"))+            <> command "render" (info commandRender (progDesc "Render a single advisory as HTML"))+            <> command "generate-index" (info commandGenerateIndex (progDesc "Generate an HTML index"))+            <> command "generate-snapshot" (info commandGenerateSnapshot (progDesc "Generate a snapshot from a Git repository"))+            <> command "query" (info commandQuery (progDesc "Run various queries against the database"))+            <> command "help" (info commandHelp (progDesc "Show command help"))         )  -- | Create an option with a fixed set of values multiOption :: [(String, a)] -> Mod OptionFields a -> Parser a multiOption kvs m = option rdr (m <> metavar choices)   where-  choices = "{" <> intercalate "|" (fmap fst kvs) <> "}"-  errMsg = "must be one of " <> choices-  rdr = eitherReader (maybe (Left errMsg) Right . flip lookup kvs)+    choices = "{" <> intercalate "|" (fmap fst kvs) <> "}"+    errMsg = "must be one of " <> choices+    rdr = eitherReader (maybe (Left errMsg) Right . flip lookup kvs)  commandReserve :: Parser (IO ()) commandReserve =   Command.Reserve.runReserveCommand-  <$> optional (argument str (metavar "REPO"))-  <*> multiOption-        [ ("placeholder", Command.Reserve.IdModePlaceholder)-        , ("auto",        Command.Reserve.IdModeAuto)-        ]-        ( long "id-mode" <> help "How to assign IDs" )-  <*> flag-        Command.Reserve.DoNotCommit -- default value-        Command.Reserve.Commit      -- active value-        ( long "commit"-        <> help "Commit the reservation file"-        )+    <$> optional (argument str (metavar "REPO"))+    <*> multiOption+      [ ("placeholder", Command.Reserve.IdModePlaceholder),+        ("auto", Command.Reserve.IdModeAuto)+      ]+      (long "id-mode" <> help "How to assign IDs")+    <*> flag+      Command.Reserve.DoNotCommit -- default value+      Command.Reserve.Commit -- active value+      ( long "commit"+          <> help "Commit the reservation file"+      ) +commandNextID :: Parser (IO ())+commandNextID =+  Command.NextID.runNextIDCommand+    <$> optional (argument str (metavar "REPO"))+ commandCheck :: Parser (IO ()) commandCheck =   withAdvisory go-  <$> optional (argument str (metavar "FILE"))+    <$> optional (argument str (metavar "FILE"))   where     go mPath advisory = do       for_ mPath $ \path -> do         let base = takeBaseName path         when ("HSEC-" `isPrefixOf` base && base /= printHsecId (advisoryId advisory)) $-          die $ "Filename does not match advisory ID: " <> path+          die $+            "Filename does not match advisory ID: " <> path       T.putStrLn "no error"  commandOsv :: Parser (IO ()) commandOsv =   withAdvisory go-  <$> optional (argument str (metavar "FILE"))+    <$> optional (argument str (metavar "FILE"))   where     go _ adv = do       L.putStr (Data.Aeson.encode (OSV.convert adv))@@ -98,7 +109,7 @@ commandRender :: Parser (IO ()) commandRender =   withAdvisory (\_ -> T.putStrLn . advisoryHtml)-  <$> optional (argument str (metavar "FILE"))+    <$> optional (argument str (metavar "FILE"))  commandQuery :: Parser (IO ()) commandQuery =@@ -112,22 +123,23 @@         <$> argument str (metavar "PACKAGE")         <*> optional (option versionRangeReader (metavar "VERSION-RANGE" <> short 'v' <> long "version-range"))         <*> optional (option str (metavar "ADVISORIES-PATH" <> short 'p' <> long "advisories-path"))-      where go :: T.Text -> Maybe VersionRange -> Maybe FilePath -> IO ()-            go packageName versionRange advisoriesPath = do-              let versionRange' = fromMaybe anyVersion versionRange-              maybeAffectedAdvisories <- listVersionRangeAffectedBy (fromMaybe "." advisoriesPath) packageName versionRange'-              case maybeAffectedAdvisories of-                Validation.Failure errors -> do-                  T.hPutStrLn stderr "Cannot parse some advisories"-                  forM_ errors $-                    hPrint stderr-                  exitFailure-                Validation.Success [] -> putStrLn "Not affected"-                Validation.Success affectedAdvisories -> do-                  hPutStrLn stderr "Affected by:"-                  forM_ affectedAdvisories $ \advisory ->-                    T.hPutStrLn stderr $ "* [" <> T.pack (printHsecId $ advisoryId advisory) <> "] " <> advisorySummary advisory-                  exitFailure+      where+        go :: T.Text -> Maybe VersionRange -> Maybe FilePath -> IO ()+        go packageName versionRange advisoriesPath = do+          let versionRange' = fromMaybe anyVersion versionRange+          maybeAffectedAdvisories <- listVersionRangeAffectedBy (fromMaybe "." advisoriesPath) packageName versionRange'+          case maybeAffectedAdvisories of+            Validation.Failure errors -> do+              T.hPutStrLn stderr "Cannot parse some advisories"+              forM_ errors $+                hPrint stderr+              exitFailure+            Validation.Success [] -> putStrLn "Not affected"+            Validation.Success affectedAdvisories -> do+              hPutStrLn stderr "Affected by:"+              forM_ affectedAdvisories $ \advisory ->+                T.hPutStrLn stderr $ "* [" <> T.pack (printHsecId $ advisoryId advisory) <> "] " <> advisorySummary advisory+              exitFailure  commandGenerateIndex :: Parser (IO ()) commandGenerateIndex =@@ -135,16 +147,25 @@       renderAdvisoriesIndex src dst       T.putStrLn "Index generated"   )-  <$> argument str (metavar "SOURCE-DIR")-  <*> argument str (metavar "DESTINATION-DIR")+    <$> argument str (metavar "SOURCE-DIR")+    <*> argument str (metavar "DESTINATION-DIR") +commandGenerateSnapshot :: Parser (IO ())+commandGenerateSnapshot =+  ( \src dst -> do+      createSnapshot src dst+      T.putStrLn "Snapshot generated"+  )+    <$> argument str (metavar "SOURCE-DIR")+    <*> argument str (metavar "DESTINATION-DIR")+ commandHelp :: Parser (IO ()) commandHelp =   ( \mCmd ->       let args = maybe id (:) mCmd ["-h"]-      in void $ handleParseResult $ execParserPure defaultPrefs cliOpts args+       in void $ handleParseResult $ execParserPure defaultPrefs cliOpts args   )-  <$> optional (argument str (metavar "COMMAND"))+    <$> optional (argument str (metavar "COMMAND"))  versionRangeReader :: ReadM VersionRange versionRangeReader = eitherReader eitherParsec@@ -153,24 +174,21 @@ withAdvisory go file = do   input <- maybe T.getContents T.readFile file -  oob <- ($ emptyOutOfBandAttributes) <$> case file of-    Nothing -> pure id-    Just path ->-      getAdvisoryGitInfo path <&> \case-        Left _ -> id-        Right gitInfo -> \oob -> oob-          { oobPublished = Just (firstAppearanceCommitDate gitInfo)-          , oobModified = Just (lastModificationCommitDate gitInfo)-          }+  oob <- runExceptT $ case file of+    Nothing -> throwE StdInHasNoOOB+    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     Left e -> do-      T.hPutStrLn stderr $-        case e of-          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-          AdvisoryError _ explanation -> "Advisory structure error:\n" <> explanation+      hPutStrLn stderr (displayException e)       exitFailure     Right advisory -> do       go file advisory

@@ -0,0 +1,21 @@+{-# LANGUAGE LambdaCase #-}++module Util where++import Data.Maybe (fromMaybe)+import System.Exit (die)++import Security.Advisories.Filesystem (isSecurityAdvisoriesRepo)+import Security.Advisories.Git (getRepoRoot)++-- | Ensure the given path (or current directory "." if @Nothing@)+-- is an advisory Git repo.  Return the (valid) repo root, or die+-- with an error message.+--+ensureRepo :: Maybe FilePath -> IO FilePath+ensureRepo mPath =+  getRepoRoot (fromMaybe "." mPath) >>= \case+    Left _          -> die "Not a git repo"+    Right repoPath  -> isSecurityAdvisoriesRepo repoPath >>= \case+      False -> die "Not a security-advisories repo"+      True  -> pure repoPath

@@ -0,0 +1,156 @@+:root{+    --bg-color:#FFFFFF;+    --text-color:#333;+    --outline-color:#DB83ED;+    --header-color:#5E5184;+    --anchor-color:#9E358F;+    --anchor-visited-color:#6F5F9C;+    --code-bg-color:#FAFAFA;+    --filename-bg:#EAEAEA;+    --code-color:#383a42;+    --code-bg-color:#fafafa;+    --code-comment-color:#a0a1a7;+    --code-kw-color:#af005f;+    --code-name-color:#e45649;+    --code-literal-color:#268bd2;+    --code-string-color:#cb4b16;+    --code-attr-color:#986801;+    --code-constructor-color:#5f5faf;+    --code-symbol-color:#4078f2;+    --code-record-field-color:#c18401;+    --code-pragma-color:#2aa198+}+@media (prefers-color-scheme:dark){+    :root{+        --bg-color:#333;+        --text-color:#C9D1D9;+        --header-color:#BBA1FF;+        --anchor-color:#EB82DC;+        --anchor-visited-color:#D5C5FF;+        --code-bg-color:transparent;+        --filename-bg:#2C2C2C;+        --code-color:#C9D1D9;+        --code-bg-color:#333;+        --code-comment-color:#a0a1a7;+        --code-kw-color:#BBA1FF;+        --code-name-color:#e45649;+        --code-literal-color:#268bd2;+        --code-string-color:#cb4b16;+        --code-attr-color:#986801;+        --code-constructor-color:#d079c9;+        --code-symbol-color:var(--code-color);+        --code-record-field-color:#c18401;+        --code-pragma-color:#2aa198+    }+}+*:focus-visible{+    outline-color:var(--outline-color)+}+body{+    color:var(--text-color);+    background-color:var(--bg-color)+}+a{+    color:var(--anchor-color)+}+a:visited{+    color:var(--anchor-visited-color)+}+h1,h2,h3,h4,h5,h6{+    color:var(--header-color)+}+input{+    background-color:rgba(255,255,255,0.06);+    color:var(--text-color)+}+.nav-bar{+    text-align: right;+}+.nav-bar ul{+    display: inline-block;+    list-style: none;+    margin: 0;+    padding: 0;+}+.nav-bar li{+    display: inline-block;+    vertical-align: middle;+    padding: 0;+    margin: 0;+    height: 100%;+    position: relative;+}+ *:focus-visible{+    outline-offset:4px;+    outline-width:1px+}+body{+    font-size:1.6rem;+    margin:0 auto;+    max-width:120rem+}+footer{+    margin-top:3rem;+    padding:1.2rem 0;+    border-top:0.2rem solid #000;+    font-size:1.2rem;+    color:#555+}+h1{+    font-size:2.4rem+}+h2{+    font-size:2rem+}+html{+    font-size:62.5%;+    font-family:Helvetica,sans-serif+}+table tbody td{+    padding:5px+}+footer{+    padding: 0 2%;+    text-align: center;+}+footer .HF{+    height:50px;+    line-height:50px;+    display:inline-block;+    background-repeat:no-repeat;+    background-image:url('../images/hf-logo.png');+    background-size:50px;+    background-position:left center;+    padding-left:60px+}+@media (max-width:319px){+    .nav-bar{+        margin:0 1.5rem 0 0;+    }+    .nav-bar a{+        display:block;+        line-height:1.6+    }+}+@media (min-width:320px){+    .nav-bar{+        margin:0 2rem 0 0;+    }+    .nav-bar a{+        display:inline;+        margin:0 0.6rem+    }+}+@media (min-width:640px){+    .nav-bar{+        margin:0 3rem 0 0;+    }+    .nav-bar a{+        margin:0 0 0 1.2rem;+        display:inline+    }+}++#advisory dt {+    margin-top: 0.75em;+}

binary file changed (absent → 12105 bytes)

@@ -1,6 +1,6 @@-cabal-version:      2.4+cabal-version:      3.0 name:               hsec-tools-version:            0.1.0.0+version:            0.2.0.2  -- A short (one-line) description of the package. synopsis:@@ -21,13 +21,15 @@ -- A copyright notice. -- copyright: category:           Data-extra-doc-files:    CHANGELOG.md+extra-doc-files:    CHANGELOG.md, README.md extra-source-files:+  assets/css/*.css+  assets/images/*.png   test/golden/*.golden   test/golden/*.md  tested-with:-  GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.3 || ==9.8.1+  GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.3 || ==9.10.1 || ==9.12.1  library   exposed-modules:@@ -35,34 +37,55 @@     Security.Advisories.Convert.OSV     Security.Advisories.Filesystem     Security.Advisories.Generate.HTML+    Security.Advisories.Generate.Snapshot+    Security.Advisories.Generate.TH     Security.Advisories.Git+    Security.Advisories.Format     Security.Advisories.Parse     Security.Advisories.Queries +  other-modules:+      Paths_hsec_tools+  autogen-modules:+      Paths_hsec_tools+   build-depends:     , aeson                 >=2.0.1.0  && <3-    , base                  >=4.14     && <4.20-    , Cabal-syntax          >=3.8.1.0  && <3.11+    , atom-conduit          >=0.9      && <0.10+    , base                  >=4.14     && <5+    , bytestring            >=0.10     && <0.14+    , Cabal-syntax          >=3.8.1.0  && <3.15     , commonmark            ^>=0.2.2     , commonmark-pandoc     >=0.2      && <0.3-    , containers            >=0.6      && <0.7-    , cvss+    , conduit               >=1.3      && <1.4+    , conduit-extra         >=1.3      && <1.4+    , containers            >=0.6      && <0.8+    , cvss                  >= 0.2     && < 0.3+    , data-default          >=0.7      && <0.8     , directory             <2-    , extra                 ^>=1.7.5-    , filepath              >=1.4      && <1.5-    , hsec-core             >= 0.1     && < 0.2-    , feed                  ==1.3.*+    , extra                 >=1.7      && <1.9+    , filepath              >=1.4      && <1.6+    , hsec-core             ^>= 0.2+    , file-embed            >=0.0.13.0 && <0.0.17     , lucid                 >=2.9.0    && < 3     , mtl                   >=2.2      && <2.4-    , osv                   >= 0.1     && < 0.2+    , osv                   >=0.1      && <0.3+    , pandoc                >=2.0      && <3.8     , pandoc-types          >=1.22     && <2     , parsec                >=3        && <4-    , pathwalk              >=0.3      && < 0.4+    , pathwalk              >=0.3      && <0.4+    , pretty                >=1.0      && <1.2+    , prettyprinter         >=1.7      && <1.8     , process               >=1.6      && <1.7-    , safe                  >=0.3      && < 0.4+    , refined               >=0.7      && <0.9+    , resourcet             >=1.2      && <1.4+    , safe                  >=0.3      && <0.4     , text                  >=1.2      && <3-    , time                  >=1.9      && <1.14-    , toml-parser           ^>=2.0.0.0+    , template-haskell      >=2.16.0.0 && <2.24+    , time                  >=1.9      && <1.15+    , toml-parser           >=2.0.0.0  && <2.1+    , uri-bytestring        >=0.3      && <0.5+    , xml-conduit           >=1.9      && <1.11     , validation-selective  >=0.1      && <1    hs-source-dirs:   src@@ -74,6 +97,8 @@ executable hsec-tools   main-is:          Main.hs   other-modules:    Command.Reserve+                    , Command.NextID+                    , Util    -- Modules included in this executable, other than Main.   -- other-modules:@@ -82,14 +107,15 @@   -- other-extensions:   build-depends:     , aeson                 >=2.0.1.0 && <3-    , base                  >=4.14    && <4.20+    , base                  >=4.14    && <5     , bytestring            >=0.10    && <0.13-    , Cabal-syntax          >=3.8.1.0 && <3.11-    , filepath              >=1.4     && <1.5-    , hsec-core             >= 0.1    && < 0.2+    , Cabal-syntax          >=3.8.1.0 && <3.15+    , filepath              >=1.4     && <1.6+    , hsec-core             ^>= 0.2     , hsec-tools     , optparse-applicative  >=0.17    && <0.19     , text                  >=1.2     && <3+    , transformers     , validation-selective  >=0.1     && <1    hs-source-dirs:   app@@ -102,21 +128,32 @@   type:             exitcode-stdio-1.0   hs-source-dirs:   test   main-is:          Spec.hs-  other-modules:    Spec.QueriesSpec+  autogen-modules:+    Paths_hsec_tools+  other-modules:+    Paths_hsec_tools+    Spec.FormatSpec+    Spec.QueriesSpec   build-depends:     , aeson-pretty   <2-    , base           <5+    , base     , Cabal-syntax+    , containers     , cvss     , directory+    , hedgehog       <2     , hsec-core     , hsec-tools+    , osv     , pretty-simple  <5-    , tasty          <1.5+    , prettyprinter+    , tasty          <2     , tasty-golden   <2.4+    , tasty-hedgehog <2     , tasty-hunit    <0.11     , text     , time+    , toml-parser    default-language: Haskell2010   ghc-options:

@@ -6,7 +6,6 @@   where  import qualified Data.Text as T-import Data.Time (zonedTimeToUTC) import Data.Void import Distribution.Pretty (prettyShow) @@ -17,9 +16,9 @@ convert adv =   ( OSV.newModel'     (T.pack . printHsecId $ advisoryId adv)-    (zonedTimeToUTC $ advisoryModified adv)+    (advisoryModified adv)   )-  { OSV.modelPublished = Just $ zonedTimeToUTC (advisoryPublished adv)+  { OSV.modelPublished = Just $ advisoryPublished adv   , OSV.modelAliases = advisoryAliases adv   , OSV.modelRelated = advisoryRelated adv   , OSV.modelSummary = Just $ advisorySummary adv@@ -31,19 +30,23 @@ 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 =

@@ -1,5 +1,3 @@-{-# LANGUAGE LambdaCase #-}- {-|  Helpers for the /security-advisories/ file system.@@ -22,26 +20,31 @@   , forReserved   , forAdvisory   , listAdvisories+  , advisoryFromFile+  , parseComponentIdentifier   ) where  import Control.Applicative (liftA2) import Data.Bifunctor (bimap) import Data.Foldable (fold)-import Data.Functor ((<&>)) import Data.Semigroup (Max(Max, getMax)) 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, eitherToValidation)+import Validation (Validation (..)) -import Security.Advisories (Advisory, AttributeOverridePolicy (NoOverrides), OutOfBandAttributes (..), ParseAdvisoryError, emptyOutOfBandAttributes, 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, PathHasNoComponentIdentifier))+import Security.Advisories.Core.Advisory (ghcComponentFromText)   dirNameAdvisories :: FilePath@@ -121,24 +124,35 @@ -- | List deduplicated parsed Advisories listAdvisories   :: (MonadIO m)-  => FilePath -> m (Validation [ParseAdvisoryError] [Advisory])+  => FilePath -> m (Validation [(FilePath, ParseAdvisoryError)] [Advisory]) listAdvisories root =   forAdvisory root $ \advisoryPath _advisoryId -> do     isSym <- liftIO $ pathIsSymbolicLink advisoryPath     if isSym       then return $ pure []-      else do-        oob <--          liftIO (getAdvisoryGitInfo advisoryPath) <&> \case-            Left _ -> emptyOutOfBandAttributes-            Right gitInfo ->-              emptyOutOfBandAttributes-                { oobPublished = Just (firstAppearanceCommitDate gitInfo),-                  oobModified = Just (lastModificationCommitDate gitInfo)-                }-        fileContent <- liftIO $ T.readFile advisoryPath-        return $ eitherToValidation $ bimap return return $ parseAdvisory NoOverrides oob fileContent+      else+        bimap (\err -> [(advisoryPath, err)]) pure+        <$> advisoryFromFile advisoryPath +-- | Parse an advisory from a file system path+advisoryFromFile+  :: (MonadIO m)+  => FilePath -> m (Validation ParseAdvisoryError Advisory)+advisoryFromFile advisoryPath = 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+    $ either Failure Success+    $ parseAdvisory NoOverrides oob fileContent+ -- | Get names (not paths) of subdirectories of the given directory -- (one level).  There's no monoidal, interruptible variant of -- @pathWalk@ so we use @WriterT@ to smuggle the result out.@@ -161,3 +175,10 @@       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

@@ -0,0 +1,376 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Security.Advisories.Format+  ( FrontMatter (..),+    fromAdvisory,+    AdvisoryMetadata (..),+    Toml.ToTable (..),+    Toml.ToValue (..),+    Toml.FromValue (..),+  )+where++import Control.Applicative ((<|>))+import Commonmark.Types (HasAttributes (..), IsBlock (..), IsInline (..), Rangeable (..), SourceRange (..))+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Monoid (First (..))+import Data.List (intercalate)+import Data.Tuple (swap)+import GHC.Generics (Generic)++import Data.Text (Text)+import qualified Data.Text as T+import Data.Time (utc, UTCTime(..), zonedTimeToUTC, localTimeToUTC)+import Distribution.Parsec (eitherParsec)+import Distribution.Pretty (pretty)+import Distribution.Types.Version (Version)+import Distribution.Types.VersionRange (VersionRange)+import qualified Text.PrettyPrint as Pretty+import qualified Toml+import qualified Toml.Schema as Toml++import Security.Advisories.Core.Advisory+import Security.Advisories.Core.HsecId+import qualified Security.CVSS as CVSS+import Security.OSV (Reference (..), ReferenceType, referenceTypes)++fromAdvisory :: Advisory -> FrontMatter+fromAdvisory advisory =+  FrontMatter+    { frontMatterAdvisory =+        AdvisoryMetadata+          { amdId = advisoryId advisory,+            amdPublished = Just $ advisoryPublished advisory,+            amdModified = Just $ advisoryModified advisory,+            amdCAPECs = advisoryCAPECs advisory,+            amdCWEs = advisoryCWEs advisory,+            amdKeywords = advisoryKeywords advisory,+            amdAliases = advisoryAliases advisory,+            amdRelated = advisoryRelated advisory+          },+      frontMatterReferences = advisoryReferences advisory,+      frontMatterAffected = advisoryAffected advisory+    }++-- advisory markdown file.+data FrontMatter = FrontMatter {+  frontMatterAdvisory :: AdvisoryMetadata,+  frontMatterReferences :: [Reference],+  frontMatterAffected :: [Affected]+} deriving (Show, Generic)++instance Toml.FromValue FrontMatter where+  fromValue = Toml.parseTableFromValue $+   do advisory   <- Toml.reqKey "advisory"+      affected   <- Toml.reqKey "affected"+      references <- fromMaybe [] <$> Toml.optKey "references"+      pure FrontMatter {+        frontMatterAdvisory = advisory,+        frontMatterAffected = affected,+        frontMatterReferences = references+        }++instance Toml.ToValue FrontMatter where+  toValue = Toml.defaultTableToValue++instance Toml.ToTable FrontMatter where+  toTable x = Toml.table+    [ "advisory" Toml..= frontMatterAdvisory x+    , "affected" Toml..= frontMatterAffected x+    , "references" Toml..= frontMatterReferences x+    ]++-- | Internal type corresponding to the @[advisory]@ subsection of the+-- TOML frontmatter in an advisory markdown file.+data AdvisoryMetadata = AdvisoryMetadata+  { amdId         :: HsecId+  , amdModified   :: Maybe UTCTime+  , amdPublished  :: Maybe UTCTime+  , amdCAPECs     :: [CAPEC]+  , amdCWEs       :: [CWE]+  , amdKeywords   :: [Keyword]+  , amdAliases    :: [T.Text]+  , amdRelated    :: [T.Text]+  }+  deriving (Show, Generic)++instance Toml.FromValue AdvisoryMetadata where+  fromValue = Toml.parseTableFromValue $+   do identifier  <- Toml.reqKey "id"+      published   <- Toml.optKeyOf "date" getDefaultedZonedTime+      modified    <- Toml.optKeyOf "modified"  getDefaultedZonedTime+      let optList key = fromMaybe [] <$> Toml.optKey key+      capecs      <- optList "capec"+      cwes        <- optList "cwe"+      kwds        <- optList "keywords"+      aliases     <- optList "aliases"+      related     <- optList "related"+      pure AdvisoryMetadata+        { amdId = identifier+        , amdModified = modified+        , amdPublished = published+        , amdCAPECs = capecs+        , amdCWEs = cwes+        , amdKeywords = kwds+        , amdAliases = aliases+        , amdRelated = related+        }++instance Toml.ToValue AdvisoryMetadata where+  toValue = Toml.defaultTableToValue++instance Toml.ToTable AdvisoryMetadata where+  toTable x = Toml.table $+    ["id"        Toml..= amdId x] +++    ["modified"  Toml..= y | Just y <- [amdModified x]] +++    ["date"      Toml..= y | Just y <- [amdPublished x]] +++    ["capec"     Toml..= amdCAPECs x | not (null (amdCAPECs x))] +++    ["cwe"       Toml..= amdCWEs x | not (null (amdCWEs x))] +++    ["keywords"  Toml..= amdKeywords x | not (null (amdKeywords x))] +++    ["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 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+        { affectedComponentIdentifier = ecosystem+        , affectedCVSS = cvss+        , affectedVersions = versions+        , affectedArchitectures = arch+        , affectedOS = os+        , affectedDeclarations = decls+        }++instance Toml.ToValue Affected where+  toValue = Toml.defaultTableToValue++instance Toml.ToTable Affected where+  toTable x = Toml.table $+    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+  fromValue = Toml.parseTableFromValue $+   do introduced <- Toml.reqKey "introduced"+      fixed      <- Toml.optKey "fixed"+      pure AffectedVersionRange {+        affectedVersionRangeIntroduced = introduced,+        affectedVersionRangeFixed = fixed+        }++instance Toml.ToValue AffectedVersionRange where+  toValue = Toml.defaultTableToValue++instance Toml.ToTable AffectedVersionRange where+  toTable x = Toml.table $+    ("introduced" Toml..= affectedVersionRangeIntroduced x) :+    ["fixed" Toml..= y | Just y <- [affectedVersionRangeFixed x]]+++instance Toml.FromValue HsecId where+  fromValue v =+   do s <- Toml.fromValue v+      case parseHsecId s of+        Nothing -> Toml.failAt (Toml.valueAnn v) "invalid HSEC-ID: expected HSEC-[0-9]{4,}-[0-9]{4,}"+        Just x -> pure x++instance Toml.ToValue HsecId where+  toValue = Toml.toValue . printHsecId++instance Toml.FromValue CAPEC where+  fromValue v = CAPEC <$> Toml.fromValue v++instance Toml.ToValue CAPEC where+  toValue (CAPEC x) = Toml.toValue x++instance Toml.FromValue CWE where+  fromValue v = CWE <$> Toml.fromValue v++instance Toml.ToValue CWE where+  toValue (CWE x) = Toml.toValue x++instance Toml.FromValue Keyword where+  fromValue v = Keyword <$> Toml.fromValue v++instance Toml.ToValue Keyword where+  toValue (Keyword x) = Toml.toValue x++-- | Get a datetime with the timezone defaulted to UTC and the time defaulted to midnight+getDefaultedZonedTime :: Toml.Value' l -> Toml.Matcher l UTCTime+getDefaultedZonedTime (Toml.ZonedTime' _ x) = pure (zonedTimeToUTC x)+getDefaultedZonedTime (Toml.LocalTime' _ x) = pure (localTimeToUTC utc x)+getDefaultedZonedTime (Toml.Day' _       x) = pure (UTCTime x 0)+getDefaultedZonedTime v                     = Toml.failAt (Toml.valueAnn v) "expected a date with optional time and timezone"++instance Toml.FromValue Reference where+  fromValue = Toml.parseTableFromValue $+   do refType <- Toml.reqKey "type"+      url     <- Toml.reqKey "url"+      pure (Reference refType url)++instance Toml.FromValue ReferenceType where+  fromValue (Toml.Text' _ refTypeStr)+    | Just a <- lookup refTypeStr (fmap swap referenceTypes) = pure a+  fromValue v =+    Toml.failAt (Toml.valueAnn v) $+      "reference.type should be one of: " ++ intercalate ", " (T.unpack . snd <$> referenceTypes)++instance Toml.ToValue Reference where+  toValue = Toml.defaultTableToValue++instance Toml.ToTable Reference where+  toTable x = Toml.table+    [ "type" Toml..= fromMaybe "UNKNOWN" (lookup (referencesType x) referenceTypes)+    , "url" Toml..= referencesUrl x+    ]++instance Toml.FromValue OS where+  fromValue v =+   do s <- Toml.fromValue v+      case s :: String of+        "darwin" -> pure MacOS+        "freebsd" -> pure FreeBSD+        "linux" -> pure Linux+        "linux-android" -> pure Android+        "mingw32" -> pure Windows+        "netbsd" -> pure NetBSD+        "openbsd" -> pure OpenBSD+        other -> Toml.failAt (Toml.valueAnn v) ("Invalid OS: " ++ show other)++instance Toml.ToValue OS where+  toValue x =+    Toml.toValue $+    case x of+      MacOS -> "darwin" :: String+      FreeBSD -> "freebsd"+      Linux -> "linux"+      Android -> "linux-android"+      Windows -> "mingw32"+      NetBSD -> "netbsd"+      OpenBSD -> "openbsd"++instance Toml.FromValue Architecture where+  fromValue v =+   do s <- Toml.fromValue v+      case parseArchitecture s of+        Just a -> pure a+        Nothing -> Toml.failAt (Toml.valueAnn v) ("Invalid architecture: " ++ show s)++instance Toml.ToValue Architecture where+  toValue = Toml.toValue . printArchitecture++printArchitecture :: Architecture -> Text+printArchitecture = T.toLower . T.pack . show++parseArchitecture :: Text -> Maybe Architecture+parseArchitecture = flip lookup [(printArchitecture arch, arch) | arch <- [minBound .. maxBound]]++instance Toml.FromValue Version where+  fromValue v =+   do s <- Toml.fromValue v+      case eitherParsec s of+        Left err -> Toml.failAt (Toml.valueAnn v) ("parse error in version: " ++ err)+        Right affected -> pure affected++instance Toml.ToValue Version where+  toValue = Toml.toValue . Pretty.render . pretty++instance Toml.FromValue VersionRange where+  fromValue v =+   do s <- Toml.fromValue v+      case eitherParsec s of+        Left err -> Toml.failAt (Toml.valueAnn v) ("parse error in version range: " ++ err)+        Right affected -> pure affected++instance Toml.ToValue VersionRange where+  toValue = Toml.toValue . Pretty.render . pretty++instance Toml.FromValue CVSS.CVSS where+  fromValue v =+    do s <- Toml.fromValue v+       case CVSS.parseCVSS s of+         Left err -> Toml.failAt (Toml.valueAnn v) ("parse error in cvss: " ++ show err)+         Right cvss -> pure cvss++instance Toml.ToValue CVSS.CVSS where+  toValue = Toml.toValue . CVSS.cvssVectorString++-- | A solution to an awkward problem: how to delete the TOML+-- block.  We parse into this type to get the source range of+-- the first block element.  We can use it to delete the lines+-- from the input.+--+newtype FirstSourceRange = FirstSourceRange (First SourceRange)+  deriving (Show, Semigroup, Monoid)++instance Rangeable FirstSourceRange where+  ranged range = (FirstSourceRange (First (Just range)) <>)++instance HasAttributes FirstSourceRange where+  addAttributes _ = id++instance IsBlock FirstSourceRange FirstSourceRange where+  paragraph _ = mempty+  plain _ = mempty+  thematicBreak = mempty+  blockQuote _ = mempty+  codeBlock _ = mempty+  heading _ = mempty+  rawBlock _ = mempty+  referenceLinkDefinition _ = mempty+  list _ = mempty++instance IsInline FirstSourceRange where+  lineBreak = mempty+  softBreak = mempty+  str _ = mempty+  entity _ = mempty+  escapedChar _ = mempty+  emph = id+  strong = id+  link _ _ _ = mempty+  image _ _ _ = mempty+  code _ = mempty+  rawInline _ _ = mempty

@@ -1,6 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}  module Security.Advisories.Generate.HTML   ( renderAdvisoriesIndex,@@ -8,30 +9,44 @@ where  import Control.Monad (forM_)+import qualified Data.ByteString.Char8 as BS8 import Data.List (sortOn) import Data.List.Extra (groupSort) import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe) import Data.Ord (Down (..)) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as BSE import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as TL-import Data.Time (ZonedTime, zonedTimeToUTC)-import Data.Time.Format.ISO8601+import Data.Time (UTCTime, formatTime, defaultTimeLocale) import System.Directory (createDirectoryIfMissing) import System.Exit (exitFailure)-import System.FilePath ((</>))-import System.IO (hPrint, stderr)+import System.FilePath ((</>), takeDirectory)+import System.IO (hPrint, hPutStrLn, stderr)+import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Trans.Resource (ResourceT)+import qualified Data.Conduit as Conduit+import qualified Data.Conduit.Binary as ConduitBinary+import Data.Default (def) import Distribution.Pretty (prettyShow)+import Distribution.Types.VersionRange (earlierVersion, intersectVersionRanges, orLaterVersion) import Lucid-import Safe (maximumMay)-import qualified Text.Atom.Feed as Feed-import qualified Text.Atom.Feed.Export as FeedExport+import Refined (refineTH)+import qualified Text.Atom.Types as Feed+import qualified Text.Atom.Conduit.Render as FeedExport+import Text.Pandoc (runIOorExplode)+import Text.Pandoc.Writers (writeHtml5String)+import qualified Text.XML.Stream.Render as ConduitXML+import qualified URI.ByteString as URI 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)+import qualified Security.OSV as OSV  -- * Actions @@ -48,7 +63,7 @@         return advisories    let renderHTMLToFile path content = do-        putStrLn $ "Rendering " <> path+        hPutStrLn stderr $ "Rendering " <> path         renderToFile path content    createDirectoryIfMissing False dst@@ -58,27 +73,35 @@    let advisoriesDir = dst </> "advisory"   createDirectoryIfMissing False advisoriesDir-  forM_ advisories $ \advisory ->-    renderHTMLToFile (advisoriesDir </> advisoryHtmlFilename (Advisories.advisoryId advisory)) $-      inPage PageAdvisory $-        div_ [class_ "pure-u-1"] $-          toHtmlRaw (Advisories.advisoryHtml advisory)+  forM_ advisories $ \advisory -> do+    let advisoryPath = advisoriesDir </> advisoryHtmlFilename (Advisories.advisoryId advisory)+    hPutStrLn stderr $ "Rendering " <> advisoryPath+    renderHTMLToFile advisoryPath $+      inPage (T.pack $ Advisories.printHsecId $ Advisories.advisoryId advisory) PageAdvisory $+        renderAdvisory advisory -  putStrLn $ "Rendering " <> (dst </> "atom.xml")-  writeFile (dst </> "atom.xml") $ T.unpack $ renderFeed advisories+  hPutStrLn stderr $ "Rendering " <> (dst </> "atom.xml")+  Conduit.runConduitRes $ renderFeed advisories Conduit..| ConduitBinary.sinkFile (dst </> "atom.xml") +  putStrLn "Copying assets"+  let assetsDir = dst </> "assets"+  forM_ $(readDirFilesTH "assets") $ \(path, content) -> do+    createDirectoryIfMissing True $ assetsDir </> takeDirectory path+    putStrLn $ "Copying " <> (assetsDir </> path)+    BS8.writeFile (assetsDir </> path) content+ -- * Rendering types  data AdvisoryR = AdvisoryR   { advisoryId :: Advisories.HsecId,     advisorySummary :: Text,     advisoryAffected :: [AffectedPackageR],-    advisoryModified :: ZonedTime+    advisoryModified :: UTCTime   }   deriving stock (Show)  data AffectedPackageR = AffectedPackageR-  { packageName :: Text,+  { ecosystem :: ComponentIdentifier,     introduced :: Text,     fixed :: Maybe Text   }@@ -88,63 +111,150 @@  listByDates :: [AdvisoryR] -> Html () listByDates advisories =-  inPage PageListByDates $-    div_ [class_ "pure-u-1"] $ do+  inPage "Advisories list" PageListByDates $ do+    indexDescription+    div_ [class_ "advisories"] $ do+      table_ [class_ "pure-table pure-table-horizontal"] $ do+        thead_ $ do+          tr_ $ do+            th_ "#"+            th_ "Package(s)"+            th_ "Summary"++        tbody_ $ do+          let sortedAdvisories =+                zip+                  (sortOn (Down . advisoryId) advisories)+                  (cycle [[], [class_ "pure-table-odd"]])+          forM_ sortedAdvisories $ \(advisory, trClasses) ->+            tr_ trClasses $ do+              td_ [class_ "advisory-id"] $ a_ [href_ $ advisoryLink (advisoryId advisory)] $ toHtml (Advisories.printHsecId (advisoryId advisory))+              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 "Advisories list" PageListByPackages $ do+    indexDescription++    let byPackage :: Map.Map Text [(AdvisoryR, AffectedPackageR)]+        byPackage =+          Map.fromList $+            groupSort+              [ (packageName package, (advisory, package))+                | advisory <- advisories,+                  package <- advisoryAffected advisory+              ]++    forM_ (Map.toList byPackage) $ \(currentPackageName, perPackageAdvisory) -> do+      h2_ $ toHtml currentPackageName       div_ [class_ "advisories"] $ do-        table_ [class_ "pure-table pure-table-horizontal"] $ do+        table_ [] $ do           thead_ $ do             tr_ $ do               th_ "#"-              th_ "Package(s)"+              th_ "Introduced"+              th_ "Fixed"               th_ "Summary"            tbody_ $ do             let sortedAdvisories =-                  zip-                    (sortOn (Down . advisoryId) advisories)-                    (cycle [[], [class_ "pure-table-odd"]])-            forM_ sortedAdvisories $ \(advisory, trClasses) ->-              tr_ trClasses $ do-                td_ [class_ "advisory-id"] $ a_ [href_ $ advisoryLink (advisoryId advisory)] $ toHtml (Advisories.printHsecId (advisoryId advisory))-                td_ [class_ "advisory-packages"] $ toHtml $ T.intercalate "," $ packageName <$> advisoryAffected advisory+                    sortOn (Down . advisoryId . fst) perPackageAdvisory+            forM_ sortedAdvisories $ \(advisory, package) -> do+              tr_ $ do+                td_ [class_ "advisory-id"] $+                  a_ [href_ $ advisoryLink $ advisoryId advisory] $+                    toHtml (Advisories.printHsecId $ advisoryId advisory)+                td_ [class_ "advisory-introduced"] $ toHtml $ introduced package+                td_ [class_ "advisory-fixed"] $ maybe (return ()) toHtml $ fixed package                 td_ [class_ "advisory-summary"] $ toHtml $ advisorySummary advisory -listByPackages :: [AdvisoryR] -> Html ()-listByPackages advisories =-  inPage PageListByPackages $-    div_ [class_ "pure-u-1"] $ do-      let byPackage :: Map.Map Text [(AdvisoryR, AffectedPackageR)]-          byPackage =-            Map.fromList $-              groupSort-                [ (packageName package, (advisory, package))-                  | advisory <- advisories,-                    package <- advisoryAffected advisory-                ]+indexDescription :: Html ()+indexDescription =+  div_ [class_ "description"] $ do+    p_ "The Haskell Security Advisory Database is a repository of security advisories filed against packages published via Hackage."+    p_  $ do+      "It is generated from "+      a_ [href_ "https://github.com/haskell/security-advisories/", target_ "_blank", rel_ "noopener noreferrer"] "Haskell Security Advisory Database"+      ". "+      "Feel free to "+      a_ [href_ "https://github.com/haskell/security-advisories/blob/main/PROCESS.md", target_ "_blank", rel_ "noopener noreferrer"] "report new or historic security issues"+      "." -      forM_ (Map.toList byPackage) $ \(currentPackageName, perPackageAdvisory) -> do-        h2_ $ toHtml currentPackageName-        div_ [class_ "advisories"] $ do-          table_ [class_ "pure-table pure-table-horizontal"] $ do-            thead_ $ do-              tr_ $ do-                th_ "#"-                th_ "Introduced"-                th_ "Fixed"-                th_ "Summary"+renderAdvisory :: Advisories.Advisory -> Html ()+renderAdvisory advisory =+  div_ [id_ "advisory"] $ do+    let renderedDescription = unsafePerformIO $ runIOorExplode $ writeHtml5String def $ Advisories.advisoryPandoc advisory+    toHtmlRaw renderedDescription -            tbody_ $ do-              let sortedAdvisories =-                    zip-                      (sortOn (Down . advisoryId . fst) perPackageAdvisory)-                      (cycle [[], [class_ "pure-table-odd"]])-              forM_ sortedAdvisories $ \((advisory, package), trClasses) ->-                tr_ trClasses $ do-                  td_ [class_ "advisory-id"] $ a_ [href_ $ advisoryLink $ advisoryId advisory] $ toHtml (Advisories.printHsecId $ advisoryId advisory)-                  td_ [class_ "advisory-introduced"] $ toHtml $ introduced package-                  td_ [class_ "advisory-fixed"] $ maybe (return ()) toHtml $ fixed package-                  td_ [class_ "advisory-summary"] $ toHtml $ advisorySummary advisory+    let placeholderWhenEmptyOr :: [a] -> ([a] -> Html ()) -> Html ()+        placeholderWhenEmptyOr xs f = if null xs then dd_ [] $ i_ "< none >" else f xs +    h3_ [] "Info"+    dl_ [] $ do+      dt_ "Published"+      dd_ [] $ toHtml $ formatTime defaultTimeLocale "%B %d, %Y" $ Advisories.advisoryPublished advisory+      dt_ "Modified"+      dd_ [] $ toHtml $ formatTime defaultTimeLocale "%B %d, %Y" $ Advisories.advisoryModified advisory+      dt_ "CAPECs"+      placeholderWhenEmptyOr (Advisories.advisoryCAPECs advisory) $ \capecs ->+        forM_ capecs $ \(Advisories.CAPEC capec) ->+            dd_ [] $ a_ [href_ $ "https://capec.mitre.org/data/definitions/" <> T.pack (show capec) <> ".html"] $ toHtml $ show capec+      dt_ "CWEs"+      placeholderWhenEmptyOr (Advisories.advisoryCWEs advisory) $ \cwes ->+        forM_ cwes $ \(Advisories.CWE cwe) ->+          dd_ [] $ a_ [href_ $ "https://cwe.mitre.org/data/definitions/" <> T.pack (show cwe) <> ".html"] $ toHtml $ show cwe+      dt_ "Keywords"+      placeholderWhenEmptyOr (Advisories.advisoryKeywords advisory) $ dd_ [] . toHtml . T.intercalate ", " . map Advisories.unKeyword+      dt_ "Aliases"+      placeholderWhenEmptyOr (Advisories.advisoryAliases advisory) $ dd_ [] . toHtml . T.intercalate ", "+      dt_ "Related"+      placeholderWhenEmptyOr (Advisories.advisoryRelated advisory) $ dd_ [] . toHtml . T.intercalate ", "+      dt_ "References"+      placeholderWhenEmptyOr (Advisories.advisoryReferences advisory) $ \references ->+        forM_ references $ \reference ->+          dd_ [] $ a_ [href_ $ OSV.referencesUrl reference] $ toHtml $ "[" <> fromMaybe "WEB" (lookup (OSV.referencesType reference) OSV.referenceTypes) <> "] " <> OSV.referencesUrl reference++    h4_ [] "Affected"+    forM_ (Advisories.advisoryAffected advisory) $ \affected -> do+      h5_ [] $+        case Advisories.affectedComponentIdentifier affected of+          Hackage package -> a_ [href_ $ "https://hackage.haskell.org/package/" <> package] $ code_ [] $ toHtml package+          GHC component -> code_ [] $ toHtml $ Advisories.ghcComponentToText component++      dl_ [] $ do+        dt_ "CVSS"+        dd_ [] $ toHtml $ T.pack $ show $ Advisories.affectedCVSS affected+        dt_ "Versions"+        forM_ (Advisories.affectedVersions affected) $ \affectedVersionRange ->+          dd_ [] $+            code_ [] $+              toHtml $+                T.pack $+                  prettyShow $+                    let introducedVersionRange = orLaterVersion $ Advisories.affectedVersionRangeIntroduced affectedVersionRange+                    in case Advisories.affectedVersionRangeFixed affectedVersionRange of+                      Nothing -> introducedVersionRange+                      Just fixedVersion -> introducedVersionRange `intersectVersionRanges` earlierVersion fixedVersion+        forM_ (Advisories.affectedArchitectures affected) $ \architectures -> do+          dt_ "Architectures"+          dd_ [] $ toHtml $ T.intercalate ", " $ T.toLower . T.pack . show <$> architectures+        forM_ (Advisories.affectedOS affected) $ \oses -> do+          dt_ "OSes"+          dd_ [] $ toHtml $ T.intercalate ", " $ T.toLower . T.pack . show <$> oses+        dt_ "Declarations"+        placeholderWhenEmptyOr (Advisories.affectedDeclarations affected) $ \declarations ->+          forM_ declarations $ \(declaration, versionRange) ->+            dd_ [] $ do+              code_ [] $ toHtml declaration+              ": "+              code_ [] $ toHtml $ T.pack $ prettyShow versionRange+ -- * Utils  data NavigationPage@@ -159,48 +269,36 @@   PageListByPackages -> "."   PageAdvisory -> ".." -inPage :: NavigationPage -> Html () -> Html ()-inPage page content =+inPage :: Text -> NavigationPage -> Html () -> Html ()+inPage title page content =   doctypehtml_ $-    html_ $ do+    html_ [lang_ "en"] $ do       head_ $ do         meta_ [charset_ "UTF-8"]         base_ [href_ $ baseUrlForPage page]         link_ [rel_ "alternate", type_ "application/atom+xml", href_ atomFeedUrl]-        link_ [rel_ "stylesheet", href_ "https://cdn.jsdelivr.net/npm/purecss@3.0.0/build/pure-min.css", integrity_ "sha384-X38yfunGUhNzHpBaEBsWLO+A0HDYOQi8ufWDkZ0k9e0eXz/tH3II7uKZ9msv++Ls", crossorigin_ "anonymous"]+        link_ [rel_ "stylesheet", href_ "assets/css/default.css"]         meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1"]-        title_ "Haskell Security.Advisories.Core"-        style_ $-          T.intercalate-            "\n"-            [ ".advisories, .content {",-              "    margin: 1em;",-              "}",-              "a {",-              "    text-decoration: none;",-              "}",-              "a:visited {",-              "    text-decoration: none;",-              "    color: darkblue;",-              "}",-              "pre {",-              "    background: lightgrey;",-              "}"-            ]+        meta_ [name_ "description", content_ "Haskell Security advisories"]+        title_ "Haskell Security advisories"       body_ $ do-        div_ [class_ "pure-u-1"] $ do-          div_ [class_ "pure-menu pure-menu-horizontal"] $ do-            let selectedOn p cls =-                  if page == p-                    then cls <> " pure-menu-selected"-                    else cls-            span_ [class_ "pure-menu-heading pure-menu-link"] "Advisories list"-            ul_ [class_ "pure-menu-list"] $ do-              li_ [class_ $ selectedOn PageListByDates "pure-menu-item"] $-                a_ [href_ "by-dates.html", class_ "pure-menu-link"] "by date"-              li_ [class_ $ selectedOn PageListByPackages "pure-menu-item"] $-                a_ [href_ "by-packages.html", class_ "pure-menu-link"] "by package"+        div_ [class_ "nav-bar"] $ do+          let selectedOn p =+                if page == p+                  then "selected"+                  else ""+          ul_ [class_ "items"] $ do+            li_ [class_ $ selectedOn PageListByDates] $+              a_ [href_ "by-dates.html"] "by date"+            li_ [class_ $ selectedOn PageListByPackages] $+              a_ [href_ "by-packages.html"] "by package"+        h1_ [] $ toHtml title         div_ [class_ "content"] content+        footer_ [] $ do+          div_ [class_ "HF"] $ do+            "This site is a project of "+            a_ [href_ "https://haskell.foundation", target_ "_blank", rel_ "noopener noreferrer"] "The Haskell Foundation"+            "."  advisoryHtmlFilename :: Advisories.HsecId -> FilePath advisoryHtmlFilename advisoryId' = Advisories.printHsecId advisoryId' <> ".html"@@ -221,46 +319,89 @@     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           }  -- * Atom/RSS feed -feed :: [Advisories.Advisory] -> Feed.Feed+feed :: [Advisories.Advisory] -> Feed.AtomFeed feed advisories =-  ( Feed.nullFeed-      atomFeedUrl-      (Feed.TextString "Haskell Security Advisory DB") -- Title-      (maybe "" (T.pack . iso8601Show) . maximumMay . fmap (zonedTimeToUTC . Advisories.advisoryModified) $ advisories)-  )-    { Feed.feedEntries = fmap toEntry advisories-    , Feed.feedLinks = [(Feed.nullLink atomFeedUrl) { Feed.linkRel = Just (Left "self") }]-    , Feed.feedAuthors = [Feed.nullPerson { Feed.personName = "Haskell Security Response Team" }]+  Feed.AtomFeed+    { Feed.feedAuthors      = [ hsrt ]+    , Feed.feedCategories   = []+    , Feed.feedContributors = []+    , Feed.feedEntries      = toEntry <$> advisories+    , Feed.feedGenerator    = Nothing+    , Feed.feedIcon         = Nothing+    , Feed.feedId           = "73b10e73-16bc-4bf2-a56c-ad7d09213e45"+    , Feed.feedLinks        = [+          Feed.AtomLink+            { Feed.linkHref   = toAtomURI atomFeedUrl+            , Feed.linkRel    = "self"+            , Feed.linkType   = ""+            , Feed.linkLang   = ""+            , Feed.linkTitle  = ""+            , Feed.linkLength = ""+            }+    ]+    , Feed.feedLogo         = Nothing+    , Feed.feedRights       = Nothing+    , Feed.feedSubtitle     = Nothing+    , Feed.feedTitle        = Feed.AtomPlainText Feed.TypeText "Haskell Security Advisory DB"+    , Feed.feedUpdated      = maximum $ Advisories.advisoryModified <$> advisories     }   where     toEntry advisory =-      ( Feed.nullEntry-        (toUrl advisory)-        (mkSummary advisory)-        (T.pack . iso8601Show $ Advisories.advisoryModified advisory)-      )-        { Feed.entryLinks = [(Feed.nullLink (toUrl advisory)) { Feed.linkRel = Just (Left "alternate") }]-        , Feed.entryContent = Just (Feed.HTMLContent (Advisories.advisoryHtml advisory))+      Feed.AtomEntry+        { Feed.entryAuthors      = [hsrt]+        , Feed.entryCategories   = []+        , Feed.entryContent      = Just $ Feed.AtomContentInlineText Feed.TypeHTML $ Advisories.advisoryHtml advisory+        , Feed.entryContributors = []+        , Feed.entryId           = T.pack $ Advisories.printHsecId $ Advisories.advisoryId advisory+        , Feed.entryLinks        = [+            Feed.AtomLink+              { Feed.linkHref   = toAtomURI $ toUrl advisory+              , Feed.linkRel    = "alternate"+              , Feed.linkType   = ""+              , Feed.linkLang   = ""+              , Feed.linkTitle  = ""+              , Feed.linkLength = ""+              }+          ]+        , Feed.entryPublished    = Just $ Advisories.advisoryPublished advisory+        , Feed.entryRights       = Nothing+        , Feed.entrySource       = Nothing+        , Feed.entrySummary      = Nothing+        , Feed.entryTitle        = Feed.AtomPlainText Feed.TypeText $ mkTitle advisory+        , Feed.entryUpdated      = Advisories.advisoryModified advisory         } -    mkSummary advisory =-      Feed.TextString $-        T.pack (Advisories.printHsecId (Advisories.advisoryId advisory))+    mkTitle advisory =+      T.pack (Advisories.printHsecId (Advisories.advisoryId advisory))         <> " - "         <> Advisories.advisorySummary advisory+     toUrl advisory = advisoriesRootUrl <> "/" <> advisoryLink (Advisories.advisoryId advisory) -renderFeed :: [Advisories.Advisory] -> Text+    toAtomURI =+      Feed.AtomURI+        . either (error . show) id+        . URI.parseURI URI.strictURIParserOptions+        . BSE.encodeUtf8++    hsrt =+        Feed.AtomPerson+          { Feed.personName = $$(refineTH "Haskell Security Response Team")+          , Feed.personEmail = "security-advisories@haskell.org"+          , Feed.personUri = Nothing+          }++renderFeed :: [Advisories.Advisory] -> Conduit.ConduitT () BS8.ByteString (ResourceT IO) () renderFeed =-  maybe (error "Cannot render atom feed") TL.toStrict-    . FeedExport.textFeed+  (Conduit..| ConduitXML.renderBytes def)+    . FeedExport.renderAtomFeed     . feed  advisoriesRootUrl :: T.Text

@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Security.Advisories.Generate.Snapshot+  ( createSnapshot,+  )+where++import Data.Aeson (ToJSON, encodeFile)+import Data.Default (def)+import qualified Data.Text.IO as T+import Data.Time (UTCTime)+import Data.Version (Version)+import GHC.Generics (Generic)+import Paths_hsec_tools (version)+import qualified Prettyprinter as Pretty+import qualified Prettyprinter.Render.Text as Pretty+import Security.Advisories.Core.Advisory+import Security.Advisories.Filesystem (advisoryFromFile, forAdvisory, forReserved)+import Security.Advisories.Format (fromAdvisory)+import System.Directory (copyFileWithMetadata, createDirectoryIfMissing)+import System.FilePath (takeDirectory, (</>))+import System.IO (hPrint, hPutStrLn, stderr)+import Text.Pandoc (Block (CodeBlock), Pandoc (Pandoc), nullMeta, runIOorExplode)+import Text.Pandoc.Writers (writeCommonMark)+import qualified Toml+import Validation (Validation (..))++-- * Actions++createSnapshot :: FilePath -> FilePath -> IO ()+createSnapshot src dst = do+  let toDstFilePath orig = dst </> drop (length src + 1) orig++  forReserved src $ \p _ -> do+    createDirectoryIfMissing True $ takeDirectory $ toDstFilePath p+    hPutStrLn stderr $ "Copying '" <> p <> "' to '" <> toDstFilePath p <> "'"+    copyFileWithMetadata p $ toDstFilePath p++  advisoriesLatestUpdates <-+    forAdvisory src $ \p _ -> do+      createDirectoryIfMissing True $ takeDirectory $ toDstFilePath p+      hPutStrLn stderr $ "Taking a snapshot of '" <> p <> "' to '" <> toDstFilePath p <> "'"+      advisoryFromFile p+        >>= \case+          Failure e -> do+            hPrint stderr e+            return []+          Success advisory -> do+            let pandoc =+                  Pandoc+                    nullMeta+                    ( CodeBlock+                        ("", ["toml"], [])+                        ( Pretty.renderStrict $+                            Pretty.layoutPretty Pretty.defaultLayoutOptions $+                              Toml.encode $+                                fromAdvisory advisory+                        )+                        : blocks (advisoryPandoc advisory)+                    )+                blocks (Pandoc _ xs) = xs+            rendered <- runIOorExplode $ writeCommonMark def pandoc+            T.writeFile (toDstFilePath p) rendered+            return [advisoryModified advisory]++  let metadataPath = dst </> "snapshot.json"+      metadata =+        SnapshotMetadata+          { latestUpdate = maximum advisoriesLatestUpdates,+            snapshotVersion = version+          }+  hPutStrLn stderr $ "Writing snapshot metadata to '" <> metadataPath <> "'"+  encodeFile metadataPath metadata++data SnapshotMetadata = SnapshotMetadata+  { latestUpdate :: UTCTime,+    snapshotVersion :: Version+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)

@@ -0,0 +1,22 @@+module Security.Advisories.Generate.TH ( +  readFileTH,+  readDirFilesTH,+  fileLocation,+  ) where++import Control.Monad.IO.Class (liftIO)+import Data.ByteString.Char8 as BS8+import Data.FileEmbed (embedDir, makeRelativeToLocationPredicate)+import Language.Haskell.TH (Exp (LitE), Lit (StringL), Q)++-- | Read file at compile-time.+readFileTH :: FilePath -> Q Exp+readFileTH p = fileLocation p $ \p' -> LitE . StringL . BS8.unpack <$> liftIO (BS8.readFile p')++-- | Read files in (sub-)directory at compile-time.+-- Gives a [(FilePath, ByteString)]+readDirFilesTH :: FilePath -> Q Exp+readDirFilesTH p = fileLocation p embedDir++fileLocation :: FilePath -> (FilePath -> Q Exp) -> Q Exp+fileLocation fp act = makeRelativeToLocationPredicate (== "hsec-tools.cabal") fp >>= act

@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DerivingStrategies #-}  {-| @@ -18,21 +19,22 @@  import Data.Char (isSpace) import Data.List (dropWhileEnd)-import Data.Time (ZonedTime)+import Data.Time (UTCTime, zonedTimeToUTC) import Data.Time.Format.ISO8601 (iso8601ParseM) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath (splitFileName) import System.Process (readProcessWithExitCode)+import Control.Applicative ((<|>))  data AdvisoryGitInfo = AdvisoryGitInfo-  { firstAppearanceCommitDate :: ZonedTime-  , lastModificationCommitDate :: ZonedTime+  { firstAppearanceCommitDate :: UTCTime+  , lastModificationCommitDate :: UTCTime   }  data GitError   = GitProcessError ExitCode String String -- ^ exit code, stdout and stderr   | GitTimeParseError String -- ^ unable to parse this input as a datetime-  deriving (Show)+  deriving stock (Eq, Ord, Show)  explainGitError :: GitError -> String explainGitError = \case@@ -117,4 +119,7 @@       -- the same as `ExitFailure`       pure . Left $ GitProcessError status stdout stderr   where-    parseTime s = maybe (Left $ GitTimeParseError s) Right $ iso8601ParseM s+    parseTime :: String -> Either GitError UTCTime+    parseTime s = maybe (Left $ GitTimeParseError s) Right $+       iso8601ParseM s+         <|> zonedTimeToUTC <$> iso8601ParseM s

@@ -1,35 +1,41 @@+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-}-module Security.Advisories.Parse-  ( parseAdvisory-  , OutOfBandAttributes(..)-  , emptyOutOfBandAttributes-  , AttributeOverridePolicy(..)-  , ParseAdvisoryError(..)-  )-  where + module Security.Advisories.Parse+ ( parseAdvisory+ , OOB+ , OOBError (..)+ , OutOfBandAttributes(..)+ , displayOOBError+ , AttributeOverridePolicy(..)+ , ParseAdvisoryError(..)+ , validateComponentIdentifier+ )+where++import Control.Exception (Exception(displayException)) import Data.Bifunctor (first) import Data.Foldable (toList)-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 import Data.Sequence (Seq((:<|)))+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as T (toStrict)-import Data.Time (ZonedTime(..), LocalTime (LocalTime), midnight, utc)-import Distribution.Parsec (eitherParsec)-import Distribution.Types.Version (Version)-import Distribution.Types.VersionRange (VersionRange)+import Data.Time (UTCTime(..))  import Commonmark.Html (Html, renderHtml) import qualified Commonmark.Parser as Commonmark@@ -43,30 +49,25 @@ import Text.Pandoc.Walk (query) import Text.Parsec.Pos (sourceLine) -import Security.Advisories.Core.HsecId import Security.Advisories.Core.Advisory-import Security.OSV (Reference(..), ReferenceType, referenceTypes)-import qualified Security.CVSS as CVSS+import Security.Advisories.Format (FrontMatter(..), AdvisoryMetadata(..))+import Security.Advisories.Git (GitError, explainGitError)++-- | if there are no out of band attributes, attach a reason why that's the case+--+-- @since 0.2.0.0+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 :: Maybe ZonedTime-  , oobPublished :: Maybe ZonedTime+  { oobModified :: UTCTime+  , oobPublished :: UTCTime+  , oobComponentIdentifier :: Maybe ComponentIdentifier   }   deriving (Show) -emptyOutOfBandAttributes :: OutOfBandAttributes-emptyOutOfBandAttributes = OutOfBandAttributes-  { oobModified = Nothing-  , oobPublished = Nothing-  }- data AttributeOverridePolicy   = PreferInBand   | PreferOutOfBand@@ -74,18 +75,39 @@   deriving (Show, Eq)  data ParseAdvisoryError-  = MarkdownError Commonmark.ParseError T.Text-  | MarkdownFormatError T.Text-  | TomlError String T.Text-  | AdvisoryError [Toml.MatchMessage Toml.Position] T.Text-  deriving stock (Eq, Show, Generic)+    = MarkdownError Commonmark.ParseError Text+    | MarkdownFormatError Text+    | TomlError String Text+    | AdvisoryError [Toml.MatchMessage Toml.Position] T.Text+    deriving stock (Eq, Show, Generic) --- | The main parsing function.  'OutOfBandAttributes' are handled--- according to the 'AttributeOverridePolicy'.+-- | @since 0.2.0.0+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+    AdvisoryError _ explanation -> "Advisory structure error:\n" <> explanation++-- | errors that may occur while ingesting oob data --+-- @since 0.2.0.0+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+  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+ parseAdvisory   :: AttributeOverridePolicy-  -> OutOfBandAttributes+  -> OOB   -> T.Text -- ^ input (CommonMark with TOML header)   -> Either ParseAdvisoryError Advisory parseAdvisory policy attrs raw = do@@ -117,7 +139,6 @@         -- no block elements?  empty range list?         -- these shouldn't happen, but better be total         raw-   -- Re-parse input as HTML.  This will probably go away; we now store the   -- Pandoc doc and can render that instead, where needed.   html <-@@ -131,26 +152,26 @@    where     firstPretty-      :: (e -> T.Text -> ParseAdvisoryError)-      -> (e -> T.Text)+      :: (e -> Text -> ParseAdvisoryError)+      -> (e -> Text)       -> Either e a       -> Either ParseAdvisoryError a     firstPretty ctr pretty = first $ mkPretty ctr pretty      mkPretty-      :: (e -> T.Text -> ParseAdvisoryError)-      -> (e -> T.Text)+      :: (e -> Text -> ParseAdvisoryError)+      -> (e -> Text)       -> e       -> ParseAdvisoryError     mkPretty ctr pretty x = ctr x $ pretty x  parseAdvisoryTable-  :: OutOfBandAttributes+  :: OOB   -> AttributeOverridePolicy   -> Pandoc -- ^ parsed document (without frontmatter)-  -> T.Text -- ^ summary-  -> T.Text -- ^ details-  -> T.Text -- ^ rendered HTML+  -> Text -- ^ summary+  -> Text -- ^ details+  -> Text -- ^ rendered HTML   -> Toml.Table' Toml.Position   -> Either [Toml.MatchMessage Toml.Position] Advisory parseAdvisoryTable oob policy doc summary details html tab =@@ -158,15 +179,20 @@    do fm <- Toml.fromValue (Toml.Table' Toml.startPos tab)       published <-         mergeOobMandatory policy-          (oobPublished oob)+          (oobPublished <$> oob)+          displayOOBError           "advisory.date"           (amdPublished (frontMatterAdvisory fm))       modified <-         fromMaybe published <$>           mergeOobOptional policy-            (oobPublished oob)+            (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@@ -176,7 +202,7 @@         , advisoryKeywords = amdKeywords (frontMatterAdvisory fm)         , advisoryAliases = amdAliases (frontMatterAdvisory fm)         , advisoryRelated = amdRelated (frontMatterAdvisory fm)-        , advisoryAffected = frontMatterAffected fm+        , advisoryAffected = affected         , advisoryReferences = frontMatterReferences fm         , advisoryPandoc = doc         , advisoryHtml = html@@ -184,412 +210,123 @@         , advisoryDetails = details         } --- | Internal type corresponding to the complete raw TOML content of an--- advisory markdown file.-data FrontMatter = FrontMatter {-  frontMatterAdvisory :: AdvisoryMetadata,-  frontMatterReferences :: [Reference],-  frontMatterAffected :: [Affected]-} deriving (Generic)--instance Toml.FromValue FrontMatter where-  fromValue = Toml.parseTableFromValue $-   do advisory   <- Toml.reqKey "advisory"-      affected   <- Toml.reqKey "affected"-      references <- fromMaybe [] <$> Toml.optKey "references"-      pure FrontMatter {-        frontMatterAdvisory = advisory,-        frontMatterAffected = affected,-        frontMatterReferences = references-        }--instance Toml.ToValue FrontMatter where-  toValue = Toml.defaultTableToValue--instance Toml.ToTable FrontMatter where-  toTable x = Toml.table-    [ "advisory" Toml..= frontMatterAdvisory x-    , "affected" Toml..= frontMatterAffected x-    , "references" Toml..= frontMatterReferences x-    ]---- | Internal type corresponding to the @[advisory]@ subsection of the--- TOML frontmatter in an advisory markdown file.-data AdvisoryMetadata = AdvisoryMetadata-  { amdId         :: HsecId-  , amdModified   :: Maybe ZonedTime-  , amdPublished  :: Maybe ZonedTime-  , amdCAPECs     :: [CAPEC]-  , amdCWEs       :: [CWE]-  , amdKeywords   :: [Keyword]-  , amdAliases    :: [T.Text]-  , amdRelated    :: [T.Text]-  }--instance Toml.FromValue AdvisoryMetadata where-  fromValue = Toml.parseTableFromValue $-   do identifier  <- Toml.reqKey "id"-      published   <- Toml.optKeyOf "date" getDefaultedZonedTime-      modified    <- Toml.optKeyOf "modified"  getDefaultedZonedTime-      let optList key = fromMaybe [] <$> Toml.optKey key-      capecs      <- optList "capec"-      cwes        <- optList "cwe"-      kwds        <- optList "keywords"-      aliases     <- optList "aliases"-      related     <- optList "related"-      pure AdvisoryMetadata-        { amdId = identifier-        , amdModified = modified-        , amdPublished = published-        , amdCAPECs = capecs-        , amdCWEs = cwes-        , amdKeywords = kwds-        , amdAliases = aliases-        , amdRelated = related-        }--instance Toml.ToValue AdvisoryMetadata where-  toValue = Toml.defaultTableToValue--instance Toml.ToTable AdvisoryMetadata where-  toTable x = Toml.table $-    ["id"        Toml..= amdId x] ++-    ["modified"  Toml..= y | Just y <- [amdModified x]] ++-    ["date"      Toml..= y | Just y <- [amdPublished x]] ++-    ["capec"     Toml..= amdCAPECs x | not (null (amdCAPECs x))] ++-    ["cwe"       Toml..= amdCWEs x | not (null (amdCWEs x))] ++-    ["keywords"  Toml..= amdKeywords x | not (null (amdKeywords x))] ++-    ["aliases"   Toml..= amdAliases x | not (null (amdAliases x))] ++-    ["Related"   Toml..= amdRelated x | not (null (amdRelated x))]--instance Toml.FromValue Affected where-  fromValue = Toml.parseTableFromValue $-   do package   <- Toml.reqKey "package"-      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-        , affectedCVSS = cvss-        , affectedVersions = versions-        , affectedArchitectures = arch-        , affectedOS = os-        , affectedDeclarations = decls-        }--instance Toml.ToValue Affected where-  toValue = Toml.defaultTableToValue--instance Toml.ToTable Affected where-  toTable x = Toml.table $-    [ "package" Toml..= affectedPackage x-    , "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-      asTable kvs = Map.fromList [(T.unpack k, v) | (k,v) <- kvs]--instance Toml.FromValue AffectedVersionRange where-  fromValue = Toml.parseTableFromValue $-   do introduced <- Toml.reqKey "introduced"-      fixed      <- Toml.optKey "fixed"-      pure AffectedVersionRange {-        affectedVersionRangeIntroduced = introduced,-        affectedVersionRangeFixed = fixed-        }--instance Toml.ToValue AffectedVersionRange where-  toValue = Toml.defaultTableToValue--instance Toml.ToTable AffectedVersionRange where-  toTable x = Toml.table $-    ("introduced" Toml..= affectedVersionRangeIntroduced x) :-    ["fixed" Toml..= y | Just y <- [affectedVersionRangeFixed x]]---instance Toml.FromValue HsecId where-  fromValue v =-   do s <- Toml.fromValue v-      case parseHsecId s of-        Nothing -> Toml.failAt (Toml.valueAnn v) "invalid HSEC-ID: expected HSEC-[0-9]{4,}-[0-9]{4,}"-        Just x -> pure x--instance Toml.ToValue HsecId where-  toValue = Toml.toValue . printHsecId--instance Toml.FromValue CAPEC where-  fromValue v = CAPEC <$> Toml.fromValue v--instance Toml.ToValue CAPEC where-  toValue (CAPEC x) = Toml.toValue x--instance Toml.FromValue CWE where-  fromValue v = CWE <$> Toml.fromValue v--instance Toml.ToValue CWE where-  toValue (CWE x) = Toml.toValue x--instance Toml.FromValue Keyword where-  fromValue v = Keyword <$> Toml.fromValue v--instance Toml.ToValue Keyword where-  toValue (Keyword x) = Toml.toValue x---- | Get a datetime with the timezone defaulted to UTC and the time defaulted to midnight-getDefaultedZonedTime :: Toml.Value' l -> Toml.Matcher l ZonedTime-getDefaultedZonedTime (Toml.ZonedTime' _ x) = pure x-getDefaultedZonedTime (Toml.LocalTime' _ x) = pure (ZonedTime x utc)-getDefaultedZonedTime (Toml.Day' _       x) = pure (ZonedTime (LocalTime x midnight) utc)-getDefaultedZonedTime v                     = Toml.failAt (Toml.valueAnn v) "expected a date with optional time and timezone"+-- | 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 T.Text (T.Text, [Block])+advisoryDoc :: Blocks -> Either Text (Text, [Block]) advisoryDoc (Many blocks) = case blocks of-  CodeBlock (_, classes, _) frontMatter :<| t-    | "toml" `elem` classes-    -> pure (frontMatter, toList t)-  _-    -> Left "Does not have toml code block as first element"+    CodeBlock (_, classes, _) frontMatter :<| t+        | "toml" `elem` classes ->+            pure (frontMatter, toList t)+    _ ->+        Left "Does not have toml code block as first element" -parseAdvisorySummary :: Pandoc -> Either T.Text T.Text+parseAdvisorySummary :: Pandoc -> Either Text Text parseAdvisorySummary = fmap inlineText . firstHeading -firstHeading :: Pandoc -> Either T.Text [Inline]+firstHeading :: Pandoc -> Either Text [Inline] firstHeading (Pandoc _ xs) = go xs   where-  go [] = Left "Does not have summary heading"-  go (Header _ _ ys : _) = Right ys-  go (_ : t) = go t+    go [] = Left "Does not have summary heading"+    go (Header _ _ ys : _) = Right ys+    go (_ : t) = go t  -- yield "plain" terminal inline content; discard formatting-inlineText :: [Inline] -> T.Text+inlineText :: [Inline] -> Text inlineText = query f   where-  f inl = case inl of-    Str s -> s-    Code _ s -> s-    Space -> " "-    SoftBreak -> " "-    LineBreak -> "\n"-    Math _ s -> s-    RawInline _ s -> s-    _ -> ""--instance Toml.FromValue Reference where-  fromValue = Toml.parseTableFromValue $-   do refType <- Toml.reqKey "type"-      url     <- Toml.reqKey "url"-      pure (Reference refType url)--instance Toml.FromValue ReferenceType where-  fromValue (Toml.Text' _ refTypeStr)-    | Just a <- lookup refTypeStr (fmap swap referenceTypes) = pure a-  fromValue v =-    Toml.failAt (Toml.valueAnn v) $-      "reference.type should be one of: " ++ intercalate ", " (T.unpack . snd <$> referenceTypes)--instance Toml.ToValue Reference where-  toValue = Toml.defaultTableToValue--instance Toml.ToTable Reference where-  toTable x = Toml.table-    [ "type" Toml..= fromMaybe "UNKNOWN" (lookup (referencesType x) referenceTypes)-    , "url" Toml..= referencesUrl x-    ]--instance Toml.FromValue OS where-  fromValue v =-   do s <- Toml.fromValue v-      case s :: String of-        "darwin" -> pure MacOS-        "freebsd" -> pure FreeBSD-        "linux" -> pure Linux-        "linux-android" -> pure Android-        "mingw32" -> pure Windows-        "netbsd" -> pure NetBSD-        "openbsd" -> pure OpenBSD-        other -> Toml.failAt (Toml.valueAnn v) ("Invalid OS: " ++ show other)--instance Toml.ToValue OS where-  toValue x =-    Toml.toValue $-    case x of-      MacOS -> "darwin" :: String-      FreeBSD -> "freebsd"-      Linux -> "linux"-      Android -> "linux-android"-      Windows -> "mingw32"-      NetBSD -> "netbsd"-      OpenBSD -> "openbsd"--instance Toml.FromValue Architecture where-  fromValue v =-   do s <- Toml.fromValue v-      case s :: String of-        "aarch64" -> pure AArch64-        "alpha" -> pure Alpha-        "arm" -> pure Arm-        "hppa" -> pure HPPA-        "hppa1_1" -> pure HPPA1_1-        "i386" -> pure I386-        "ia64" -> pure IA64-        "m68k" -> pure M68K-        "mips" -> pure MIPS-        "mipseb" -> pure MIPSEB-        "mipsel" -> pure MIPSEL-        "nios2" -> pure NIOS2-        "powerpc" -> pure PowerPC-        "powerpc64" -> pure PowerPC64-        "powerpc64le" -> pure PowerPC64LE-        "riscv32" -> pure RISCV32-        "riscv64" -> pure RISCV64-        "rs6000" -> pure RS6000-        "s390" -> pure S390-        "s390x" -> pure S390X-        "sh4" -> pure SH4-        "sparc" -> pure SPARC-        "sparc64" -> pure SPARC64-        "vax" -> pure VAX-        "x86_64" -> pure X86_64-        other -> Toml.failAt (Toml.valueAnn v) ("Invalid architecture: " ++ show other)--instance Toml.ToValue Architecture where-  toValue x =-    Toml.toValue $-    case x of-        AArch64 -> "aarch64" :: String-        Alpha -> "alpha"-        Arm -> "arm"-        HPPA -> "hppa"-        HPPA1_1 -> "hppa1_1"-        I386 -> "i386"-        IA64 -> "ia64"-        M68K -> "m68k"-        MIPS -> "mips"-        MIPSEB -> "mipseb"-        MIPSEL -> "mipsel"-        NIOS2 -> "nios2"-        PowerPC -> "powerpc"-        PowerPC64 -> "powerpc64"-        PowerPC64LE -> "powerpc64le"-        RISCV32 -> "riscv32"-        RISCV64 -> "riscv64"-        RS6000 -> "rs6000"-        S390 -> "s390"-        S390X -> "s390x"-        SH4 -> "sh4"-        SPARC -> "sparc"-        SPARC64 -> "sparc64"-        VAX -> "vax"-        X86_64 -> "x86_64"--instance Toml.FromValue Version where-  fromValue v =-   do s <- Toml.fromValue v-      case eitherParsec s of-        Left err -> Toml.failAt (Toml.valueAnn v) ("parse error in version range: " ++ err)-        Right affected -> pure affected--instance Toml.ToValue Version where-  toValue = Toml.toValue . show--instance Toml.FromValue VersionRange where-  fromValue v =-   do s <- Toml.fromValue v-      case eitherParsec s of-        Left err -> Toml.failAt (Toml.valueAnn v) ("parse error in version range: " ++ err)-        Right affected -> pure affected--instance Toml.ToValue VersionRange where-  toValue = Toml.toValue . show--instance Toml.FromValue CVSS.CVSS where-  fromValue v =-    do s <- Toml.fromValue v-       case CVSS.parseCVSS s of-         Left err -> Toml.failAt (Toml.valueAnn v) ("parse error in cvss: " ++ show err)-         Right cvss -> pure cvss--instance Toml.ToValue CVSS.CVSS where-  toValue = Toml.toValue . CVSS.cvssVectorString+    f inl = case inl of+        Str s -> s+        Code _ s -> s+        Space -> " "+        SoftBreak -> " "+        LineBreak -> "\n"+        Math _ s -> s+        RawInline _ s -> s+        _ -> ""  mergeOob   :: MonadFail m   => AttributeOverridePolicy-  -> Maybe a  -- ^ out-of-band value+  -> Either e a  -- ^ out-of-band value   -> String  -- ^ key   -> Maybe a -- ^ in-band-value-  -> m b  -- ^ when key and out-of-band value absent+  -> (e -> m b)  -- ^ when key and out-of-band value absent   -> (a -> m b) -- ^ when value present   -> m b mergeOob policy oob k ib absent present = do   case (oob, ib) of-    (Just l, Just r) -> case policy of+    (Right l, Just r) -> case policy of       NoOverrides -> fail ("illegal out of band override: " ++ k)       PreferOutOfBand -> present l       PreferInBand -> present r-    (Just a, Nothing) -> present a-    (Nothing, Just a) -> present a-    (Nothing, Nothing) -> absent+    (Right a, Nothing) -> present a+    (Left _, Just a) -> present a+    (Left e, Nothing) -> absent e  mergeOobOptional   :: MonadFail m   => AttributeOverridePolicy-  -> Maybe a  -- ^ out-of-band value+  -> Either e a  -- ^ out-of-band value   -> String -- ^ key   -> Maybe a -- ^ in-band-value   -> m (Maybe a) mergeOobOptional policy oob k ib =-  mergeOob policy oob k ib (pure Nothing) (pure . Just)+  mergeOob policy oob k ib (const $ pure Nothing) (pure . Just)  mergeOobMandatory   :: MonadFail m   => AttributeOverridePolicy-  -> Maybe a  -- ^ out-of-band value+  -> Either e a  -- ^ out-of-band value+  -> (e -> String) -- ^ how to display information about a missing out of band value   -> String  -- ^ key   -> Maybe a -- ^ in-band value   -> m a-mergeOobMandatory policy oob k ib =-  mergeOob policy oob k ib (fail ("missing mandatory key: " ++ k)) pure+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+        ] --- | A solution to an awkward problem: how to delete the TOML--- block.  We parse into this type to get the source range of--- the first block element.  We can use it to delete the lines--- from the input.---+{- | A solution to an awkward problem: how to delete the TOML+ block.  We parse into this type to get the source range of+ the first block element.  We can use it to delete the lines+ from the input.+-} newtype FirstSourceRange = FirstSourceRange (First SourceRange)-  deriving (Show, Semigroup, Monoid)+    deriving (Show, Semigroup, Monoid)  instance Rangeable FirstSourceRange where-  ranged range = (FirstSourceRange (First (Just range)) <>)+    ranged range = (FirstSourceRange (First (Just range)) <>)  instance HasAttributes FirstSourceRange where-  addAttributes _ = id+    addAttributes _ = id  instance IsBlock FirstSourceRange FirstSourceRange where-  paragraph _ = mempty-  plain _ = mempty-  thematicBreak = mempty-  blockQuote _ = mempty-  codeBlock _ = mempty-  heading _ = mempty-  rawBlock _ = mempty-  referenceLinkDefinition _ = mempty-  list _ = mempty+    paragraph _ = mempty+    plain _ = mempty+    thematicBreak = mempty+    blockQuote _ = mempty+    codeBlock _ = mempty+    heading _ = mempty+    rawBlock _ = mempty+    referenceLinkDefinition _ = mempty+    list _ = mempty  instance IsInline FirstSourceRange where-  lineBreak = mempty-  softBreak = mempty-  str _ = mempty-  entity _ = mempty-  escapedChar _ = mempty-  emph = id-  strong = id-  link _ _ _ = mempty-  image _ _ _ = mempty-  code _ = mempty-  rawInline _ _ = mempty+    lineBreak = mempty+    softBreak = mempty+    str _ = mempty+    entity _ = mempty+    escapedChar _ = mempty+    emph = id+    strong = id+    link _ _ _ = mempty+    image _ _ _ = mempty+    code _ = mempty+    rawInline _ _ = mempty

@@ -38,9 +38,10 @@     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@@ -50,16 +51,24 @@         (orLaterVersion (affectedVersionRangeIntroduced avr))         (maybe anyVersion earlierVersion (affectedVersionRangeFixed avr)) +type QueryResult = Validation [(FilePath, ParseAdvisoryError)] [Advisory]+ -- | List the advisories matching a package name and a version-listVersionAffectedBy :: MonadIO m => FilePath -> Text -> Version -> m (Validation [ParseAdvisoryError] [Advisory])+listVersionAffectedBy+  :: MonadIO m+  => FilePath -> Text -> Version -> m QueryResult listVersionAffectedBy = listAffectedByHelper isVersionAffectedBy  -- | List the advisories matching a package name and a version range-listVersionRangeAffectedBy :: MonadIO m => FilePath -> Text -> VersionRange -> m (Validation [ParseAdvisoryError] [Advisory])+listVersionRangeAffectedBy+  :: (MonadIO m)+  => FilePath -> Text -> VersionRange -> m QueryResult listVersionRangeAffectedBy = listAffectedByHelper isVersionRangeAffectedBy  -- | Helper function for 'listVersionAffectedBy' and 'listVersionRangeAffectedBy'-listAffectedByHelper :: MonadIO m => (Text -> a -> Advisory -> Bool) -> FilePath -> Text -> a -> m (Validation [ParseAdvisoryError] [Advisory])+listAffectedByHelper+  :: (MonadIO m)+  => (Text -> a -> Advisory -> Bool) -> FilePath -> Text -> a -> m QueryResult listAffectedByHelper checkAffectedBy root queryPackageName queryVersionish =   fmap (filter (checkAffectedBy queryPackageName queryVersionish)) <$>     listAdvisories root

@@ -7,28 +7,31 @@ import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Encoding as LText+import Data.Time (UTCTime(UTCTime)) import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)-import Data.Time.LocalTime-import System.Directory (listDirectory)-import Test.Tasty-import Test.Tasty.Golden (goldenVsString)-import Text.Pretty.Simple (pShowNoColor)-+import Paths_hsec_tools (getDataFileName) import qualified Security.Advisories.Convert.OSV as OSV import Security.Advisories.Parse+import qualified Spec.FormatSpec as FormatSpec import qualified Spec.QueriesSpec as QueriesSpec+import System.Directory (listDirectory)+import Test.Tasty (defaultMain, testGroup, TestTree)+import Test.Tasty.Golden (goldenVsString)+import Text.Pretty.Simple (pShowNoColor)  main :: IO () main = do     goldenFiles <- listGoldenFiles     defaultMain $-      testGroup "Tests"-        [ goldenTestsSpec goldenFiles-        , QueriesSpec.spec-        ]+        testGroup+            "Tests"+            [ goldenTestsSpec goldenFiles+            , QueriesSpec.spec+            , FormatSpec.spec+            ]  listGoldenFiles :: IO [FilePath]-listGoldenFiles = map (mappend dpath) . filter (not . isSuffixOf ".golden") <$> listDirectory dpath+listGoldenFiles = map (mappend dpath) . filter (not . isSuffixOf ".golden") <$> (getDataFileName dpath >>= listDirectory)   where     dpath = "test/golden/" @@ -40,14 +43,14 @@   where     doCheck :: IO LText.Text     doCheck = do-        input <- T.readFile fp-        let fakeDate = ZonedTime (LocalTime (fromOrdinalDate 1970 0) midnight) utc-            attr =-                emptyOutOfBandAttributes-                    { oobPublished = Just fakeDate-                    , oobModified = Just fakeDate-                    }-            res = parseAdvisory NoOverrides attr input+        input <- getDataFileName fp >>= T.readFile+        let fakeDate = UTCTime (fromOrdinalDate 1970 0) 0+            attr = OutOfBandAttributes+              { oobPublished = fakeDate+              , oobModified = fakeDate+              , oobComponentIdentifier = Nothing+              }+            res = parseAdvisory NoOverrides (Right attr) input             osvExport = case res of                 Right adv ->                     let osv = OSV.convert adv

@@ -0,0 +1,168 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Spec.FormatSpec (spec) where++import Data.Fixed (Fixed (MkFixed))+import Data.Function (on)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import Distribution.Types.Version+import Distribution.Types.VersionRange+import qualified Hedgehog as Gen+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import qualified Prettyprinter as Pretty+import qualified Prettyprinter.Render.Text as Pretty+import Security.Advisories.Core.Advisory+import Security.Advisories.Core.HsecId+import Security.Advisories.Format+import Security.CVSS+import Security.OSV (Reference (..), ReferenceType (..))+import Test.Tasty+import Test.Tasty.Hedgehog+import qualified Toml++spec :: TestTree+spec =+  testGroup+    "Format"+    [ testGroup+        "FrontMatter"+        [ testProperty "parse . render == id" $+            Gen.property $ do+              fm <- Gen.forAll genFrontMatter+              let rendered =+                    Pretty.renderStrict $ Pretty.layoutPretty Pretty.defaultLayoutOptions $ Toml.encode fm+              Gen.footnote $ T.unpack rendered+              Toml.decode rendered Gen.=== Toml.Success mempty (FrontMatterEq fm)+        ]+    ]++newtype FrontMatterEq = FrontMatterEq {unFrontMatter :: FrontMatter}+  deriving newtype (Show, FromValue)++instance Eq FrontMatterEq where+  (==) = (==) `on` show . unFrontMatter++genFrontMatter :: Gen.Gen FrontMatter+genFrontMatter =+  FrontMatter+    <$> genAdvisoryMetadata+    <*> Gen.list (Range.linear 0 10) genReference+    <*> Gen.list (Range.linear 0 10) genAffected++genAdvisoryMetadata :: Gen.Gen AdvisoryMetadata+genAdvisoryMetadata =+  AdvisoryMetadata+    <$> genHsecId+    <*> Gen.maybe genUTCTime+    <*> Gen.maybe genUTCTime+    <*> Gen.list (Range.linear 0 5) genCAPEC+    <*> Gen.list (Range.linear 0 5) genCWE+    <*> Gen.list (Range.linear 0 5) genKeyword+    <*> Gen.list (Range.linear 0 5) genText+    <*> Gen.list (Range.linear 0 5) genText++genAffected :: Gen.Gen Affected+genAffected =+  Affected+    <$> 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 $+    map+      (\x -> either (\e -> error $ "Cannot parse CVSS " <> show x <> " " <> show e) return $ parseCVSS x)+      [ "CVSS:3.1/AV:N/AC:L/PR:N/UI:N/S:C/C:N/I:L/A:N",+        "CVSS:3.1/AV:N/AC:L/PR:L/UI:N/S:C/C:L/I:L/A:N",+        "CVSS:3.1/AV:N/AC:H/PR:N/UI:R/S:U/C:L/I:N/A:N",+        "CVSS:3.0/AV:N/AC:L/PR:N/UI:R/S:C/C:L/I:L/A:N",+        "CVSS:3.0/AV:N/AC:L/PR:L/UI:N/S:C/C:L/I:L/A:N",+        "CVSS:3.0/AV:N/AC:H/PR:N/UI:R/S:U/C:L/I:N/A:N",+        "CVSS:3.0/AV:L/AC:L/PR:N/UI:N/S:U/C:N/I:L/A:N",+        "CVSS:3.0/AV:N/AC:L/PR:L/UI:N/S:C/C:H/I:H/A:H",+        "CVSS:3.0/AV:L/AC:L/PR:H/UI:N/S:U/C:L/I:L/A:L",+        "AV:N/AC:L/Au:N/C:N/I:N/A:C",+        "AV:N/AC:L/Au:N/C:C/I:C/A:C",+        "AV:L/AC:H/Au:N/C:C/I:C/A:C"+      ]++genCAPEC :: Gen.Gen CAPEC+genCAPEC = CAPEC <$> Gen.integral (Range.linear 100 999)++genCWE :: Gen.Gen CWE+genCWE = CWE <$> Gen.integral (Range.linear 100 999)++genHsecId :: Gen.Gen HsecId+genHsecId = flip nextHsecId placeholder <$> Gen.integral (Range.linear 2024 2032)++genUTCTime :: Gen.Gen UTCTime+genUTCTime =+  UTCTime+    <$> genDay+    <*> fmap secondsToDiffTime (Gen.integral $ Range.constant 0 86401)++genDay :: Gen.Gen Day+genDay = do+  y <- toInteger <$> Gen.int (Range.constant 1968 2019)+  m <- Gen.int (Range.constant 1 12)+  d <- Gen.int (Range.constant 1 28)+  pure $ fromGregorian y m d++genVersionRange :: Gen.Gen VersionRange+genVersionRange =+  Gen.recursive+    Gen.choice+    [ pure anyVersion,+      pure noVersion,+      thisVersion <$> genVersion,+      notThisVersion <$> genVersion,+      laterVersion <$> genVersion,+      earlierVersion <$> genVersion,+      orLaterVersion <$> genVersion,+      orEarlierVersion <$> genVersion,+      withinVersion <$> genVersion,+      majorBoundVersion <$> genVersion+    ]+    [ Gen.subterm2 genVersionRange genVersionRange unionVersionRanges,+      Gen.subterm2 genVersionRange genVersionRange intersectVersionRanges+    ]++genText :: Gen.Gen Text+genText = Gen.text (Range.linear 1 20) Gen.alphaNum++genAffectedVersionRange :: Gen.Gen AffectedVersionRange+genAffectedVersionRange = AffectedVersionRange <$> genVersion <*> Gen.maybe genVersion++genVersion :: Gen.Gen Version+genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.integral (Range.linear 0 999))++genArchitecture :: Gen.Gen Architecture+genArchitecture = Gen.enumBounded++genOS :: Gen.Gen OS+genOS = Gen.enumBounded++genKeyword :: Gen.Gen Keyword+genKeyword = Keyword <$> genText++genReference :: Gen.Gen Reference+genReference = Reference <$> genReferenceType <*> genText++genReferenceType :: Gen.Gen ReferenceType+genReferenceType = Gen.enumBounded

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

@@ -17,7 +17,7 @@             ]         , 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