hsec-tools (empty) → 0.1.0.0
raw patch · 19 files changed
+2227/−0 lines, 19 filesdep +Cabal-syntaxdep +aesondep +aeson-pretty
Dependencies added: Cabal-syntax, aeson, aeson-pretty, base, bytestring, commonmark, commonmark-pandoc, containers, cvss, directory, extra, feed, filepath, hsec-core, hsec-tools, lucid, mtl, optparse-applicative, osv, pandoc-types, parsec, pathwalk, pretty-simple, process, safe, tasty, tasty-golden, tasty-hunit, text, time, toml-parser, validation-selective
Files
- CHANGELOG.md +0/−0
- app/Command/Reserve.hs +71/−0
- app/Main.hs +177/−0
- hsec-tools.cabal +124/−0
- src/Security/Advisories.hs +10/−0
- src/Security/Advisories/Convert/OSV.hs +55/−0
- src/Security/Advisories/Filesystem.hs +163/−0
- src/Security/Advisories/Generate/HTML.hs +270/−0
- src/Security/Advisories/Git.hs +120/−0
- src/Security/Advisories/Parse.hs +595/−0
- src/Security/Advisories/Queries.hs +65/−0
- test/Spec.hs +59/−0
- test/Spec/QueriesSpec.hs +194/−0
- test/golden/EXAMPLE_ADVISORY.md +32/−0
- test/golden/EXAMPLE_ADVISORY.md.golden +259/−0
- test/golden/MISSING_AFFECTED.md +7/−0
- test/golden/MISSING_AFFECTED.md.golden +17/−0
- test/golden/MISSING_TITLE.md +6/−0
- test/golden/MISSING_TITLE.md.golden +3/−0
+ CHANGELOG.md view
+ app/Command/Reserve.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE LambdaCase #-}++module Command.Reserve where++import Control.Monad (unless, when)+import Data.Maybe (fromMaybe)+import System.Exit (die)+import System.FilePath ((</>), (<.>))++import Security.Advisories.Git+ ( add+ , commit+ , explainGitError+ , getRepoRoot+ )+import Security.Advisories.Core.HsecId+ ( placeholder+ , printHsecId+ , getNextHsecId+ )+import Security.Advisories.Filesystem+ ( dirNameAdvisories+ , dirNameReserved+ , isSecurityAdvisoriesRepo+ , getGreatestId+ )++-- | How to choose IDs when creating advisories or+-- reservations.+data IdMode+ = IdModePlaceholder+ -- ^ Create a placeholder ID (e.g. HSEC-0000-0000). Real IDs+ -- will be assigned later.+ | IdModeAuto+ -- ^ Use the next available ID. This option is more likely to+ -- result in conflicts when submitting advisories or reservations.++data CommitFlag = Commit | DoNotCommit+ deriving (Eq)++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"++ hsid <- case idMode of+ IdModePlaceholder -> pure placeholder+ IdModeAuto -> do+ curMax <- getGreatestId repoPath+ getNextHsecId curMax++ let+ advisoriesPath = repoPath </> dirNameAdvisories+ fileName = printHsecId hsid <.> "md"+ filePath = advisoriesPath </> dirNameReserved </> fileName+ writeFile filePath "" -- write empty file++ when (commitFlag == Commit) $ do+ let msg = printHsecId hsid <> ": reserve id"+ add repoPath [filePath] >>= \case+ Left e -> die $ "Failed to update Git index: " <> explainGitError e+ Right _ -> pure ()+ commit repoPath msg >>= \case+ Left e -> die $ "Failed to create Git commit: " <> explainGitError e+ Right _ -> pure ()
+ app/Main.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad (forM_, join, void, when)+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 qualified Data.Text as T+import qualified Data.Text.IO as T+import Options.Applicative++import Security.Advisories+import qualified Security.Advisories.Convert.OSV as OSV+import Security.Advisories.Git+import Security.Advisories.Queries (listVersionRangeAffectedBy)+import Security.Advisories.Generate.HTML++import qualified Command.Reserve++main :: IO ()+main = join $+ customExecParser+ (prefs showHelpOnEmpty)+ cliOpts++cliOpts :: ParserInfo (IO ())+cliOpts = info (commandsParser <**> helper) (fullDesc <> header "Haskell Advisories tools")+ where+ 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"))+ )++-- | 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)++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"+ )++commandCheck :: Parser (IO ())+commandCheck =+ withAdvisory go+ <$> 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+ T.putStrLn "no error"++commandOsv :: Parser (IO ())+commandOsv =+ withAdvisory go+ <$> optional (argument str (metavar "FILE"))+ where+ go _ adv = do+ L.putStr (Data.Aeson.encode (OSV.convert adv))+ putChar '\n'++commandRender :: Parser (IO ())+commandRender =+ withAdvisory (\_ -> T.putStrLn . advisoryHtml)+ <$> optional (argument str (metavar "FILE"))++commandQuery :: Parser (IO ())+commandQuery =+ subparser+ ( command "is-affected" (info isAffected (progDesc "Check if a package/version range is marked vulnerable"))+ )+ where+ isAffected :: Parser (IO ())+ isAffected =+ go+ <$> 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++commandGenerateIndex :: Parser (IO ())+commandGenerateIndex =+ ( \src dst -> do+ renderAdvisoriesIndex src dst+ T.putStrLn "Index 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+ )+ <$> optional (argument str (metavar "COMMAND"))++versionRangeReader :: ReadM VersionRange+versionRangeReader = eitherReader eitherParsec++withAdvisory :: (Maybe FilePath -> Advisory -> IO ()) -> Maybe FilePath -> IO ()+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)+ }++ 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+ exitFailure+ Right advisory -> do+ go file advisory+ exitSuccess
+ hsec-tools.cabal view
@@ -0,0 +1,124 @@+cabal-version: 2.4+name: hsec-tools+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis:+ Tools for working with the Haskell security advisory database++-- A longer description of the package.+description:+ Tools for working with the Haskell security advisory database.++-- A URL where users can report bugs.+-- bug-reports:++-- The license under which the package is released.+license: BSD-3-Clause+author: Haskell Security Response Team+maintainer: security-advisories@haskell.org++-- A copyright notice.+-- copyright:+category: Data+extra-doc-files: CHANGELOG.md+extra-source-files:+ 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++library+ exposed-modules:+ Security.Advisories+ Security.Advisories.Convert.OSV+ Security.Advisories.Filesystem+ Security.Advisories.Generate.HTML+ Security.Advisories.Git+ Security.Advisories.Parse+ Security.Advisories.Queries++ build-depends:+ , aeson >=2.0.1.0 && <3+ , base >=4.14 && <4.20+ , Cabal-syntax >=3.8.1.0 && <3.11+ , commonmark ^>=0.2.2+ , commonmark-pandoc >=0.2 && <0.3+ , containers >=0.6 && <0.7+ , cvss+ , directory <2+ , extra ^>=1.7.5+ , filepath >=1.4 && <1.5+ , hsec-core >= 0.1 && < 0.2+ , feed ==1.3.*+ , lucid >=2.9.0 && < 3+ , mtl >=2.2 && <2.4+ , osv >= 0.1 && < 0.2+ , pandoc-types >=1.22 && <2+ , parsec >=3 && <4+ , pathwalk >=0.3 && < 0.4+ , process >=1.6 && <1.7+ , safe >=0.3 && < 0.4+ , text >=1.2 && <3+ , time >=1.9 && <1.14+ , toml-parser ^>=2.0.0.0+ , validation-selective >=0.1 && <1++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++executable hsec-tools+ main-is: Main.hs+ other-modules: Command.Reserve++ -- Modules included in this executable, other than Main.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ build-depends:+ , aeson >=2.0.1.0 && <3+ , base >=4.14 && <4.20+ , bytestring >=0.10 && <0.13+ , Cabal-syntax >=3.8.1.0 && <3.11+ , filepath >=1.4 && <1.5+ , hsec-core >= 0.1 && < 0.2+ , hsec-tools+ , optparse-applicative >=0.17 && <0.19+ , text >=1.2 && <3+ , validation-selective >=0.1 && <1++ hs-source-dirs: app+ default-language: Haskell2010+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Spec.QueriesSpec+ build-depends:+ , aeson-pretty <2+ , base <5+ , Cabal-syntax+ , cvss+ , directory+ , hsec-core+ , hsec-tools+ , pretty-simple <5+ , tasty <1.5+ , tasty-golden <2.4+ , tasty-hunit <0.11+ , text+ , time++ default-language: Haskell2010+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints
+ src/Security/Advisories.hs view
@@ -0,0 +1,10 @@+module Security.Advisories+ ( module Security.Advisories.Core.Advisory+ , module Security.Advisories.Core.HsecId+ , module Security.Advisories.Parse+ )+where++import Security.Advisories.Core.Advisory+import Security.Advisories.Core.HsecId+import Security.Advisories.Parse
+ src/Security/Advisories/Convert/OSV.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Security.Advisories.Convert.OSV+ ( convert+ )+ where++import qualified Data.Text as T+import Data.Time (zonedTimeToUTC)+import Data.Void+import Distribution.Pretty (prettyShow)++import Security.Advisories+import qualified Security.OSV as OSV++convert :: Advisory -> OSV.Model Void Void Void Void+convert adv =+ ( OSV.newModel'+ (T.pack . printHsecId $ advisoryId adv)+ (zonedTimeToUTC $ advisoryModified adv)+ )+ { OSV.modelPublished = Just $ zonedTimeToUTC (advisoryPublished adv)+ , OSV.modelAliases = advisoryAliases adv+ , OSV.modelRelated = advisoryRelated adv+ , OSV.modelSummary = Just $ advisorySummary adv+ , OSV.modelDetails = Just $ advisoryDetails adv+ , OSV.modelReferences = advisoryReferences adv+ , OSV.modelAffected = fmap mkAffected (advisoryAffected adv)+ }++mkAffected :: Affected -> OSV.Affected Void Void Void+mkAffected aff =+ OSV.Affected+ { OSV.affectedPackage = mkPackage (affectedPackage aff)+ , OSV.affectedRanges = pure $ mkRange (affectedVersions aff)+ , OSV.affectedSeverity = [OSV.Severity (affectedCVSS aff)]+ , OSV.affectedEcosystemSpecific = Nothing+ , OSV.affectedDatabaseSpecific = Nothing+ }++mkPackage :: T.Text -> OSV.Package+mkPackage name = OSV.Package+ { OSV.packageName = name+ , OSV.packageEcosystem = "Hackage"+ , OSV.packagePurl = Nothing+ }++mkRange :: [AffectedVersionRange] -> OSV.Range Void+mkRange ranges =+ OSV.RangeEcosystem (foldMap mkEvs ranges) Nothing+ where+ mkEvs :: AffectedVersionRange -> [OSV.Event T.Text]+ mkEvs range =+ OSV.EventIntroduced (T.pack $ prettyShow $ affectedVersionRangeIntroduced range)+ : maybe [] (pure . OSV.EventFixed . T.pack . prettyShow) (affectedVersionRangeFixed range)
+ src/Security/Advisories/Filesystem.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE LambdaCase #-}++{-|++Helpers for the /security-advisories/ file system.++Top-level functions that take a @FilePath@ expect the path to the+top-level directory of the /security-advisories/ repository (i.e.+it must have the @advisories/@ subdirectory).++-}+module Security.Advisories.Filesystem+ (+ dirNameAdvisories+ , dirNameReserved+ , isSecurityAdvisoriesRepo+ , getReservedIds+ , getAdvisoryIds+ , getAllocatedIds+ , greatestId+ , getGreatestId+ , forReserved+ , forAdvisory+ , listAdvisories+ ) 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.IO as T+import System.FilePath ((</>), takeBaseName)+import System.Directory (doesDirectoryExist, pathIsSymbolicLink)+import System.Directory.PathWalk+import Validation (Validation, eitherToValidation)++import Security.Advisories (Advisory, AttributeOverridePolicy (NoOverrides), OutOfBandAttributes (..), ParseAdvisoryError, emptyOutOfBandAttributes, parseAdvisory)+import Security.Advisories.Core.HsecId (HsecId, parseHsecId, placeholder)+import Security.Advisories.Git(firstAppearanceCommitDate, getAdvisoryGitInfo, lastModificationCommitDate)+++dirNameAdvisories :: FilePath+dirNameAdvisories = "advisories"++dirNameReserved :: FilePath+dirNameReserved = "reserved"++-- | Check whether the directory appears to be the root of a+-- /security-advisories/ filesystem. Only checks that the+-- @advisories@ subdirectory exists.+--+isSecurityAdvisoriesRepo :: FilePath -> IO Bool+isSecurityAdvisoriesRepo path =+ doesDirectoryExist (path </> dirNameAdvisories)+++-- | Get a list of reserved HSEC IDs. The order is unspecified.+--+getReservedIds :: FilePath -> IO [HsecId]+getReservedIds root =+ forReserved root (\_ hsid -> pure [hsid])++-- | Get a list of used IDs (does not include reserved IDs)+-- There may be duplicates and the order is unspecified.+--+getAdvisoryIds :: FilePath -> IO [HsecId]+getAdvisoryIds root =+ forAdvisory root (\_ hsid -> pure [hsid])++-- | Get all allocated IDs, including reserved IDs.+-- There may be duplicates and the order is unspecified.+--+getAllocatedIds :: FilePath -> IO [HsecId]+getAllocatedIds root =+ liftA2 (<>)+ (getAdvisoryIds root)+ (getReservedIds root)++-- | Return the greatest ID in a collection of IDs. If the+-- collection is empty, return the 'placeholder'.+--+greatestId :: (Foldable t) => t HsecId -> HsecId+greatestId = getMax . foldr ((<>) . Max) (Max placeholder)++-- | Return the greatest ID in the database, including reserved IDs.+-- If there are IDs in the database, returns the 'placeholder'.+--+getGreatestId :: FilePath -> IO HsecId+getGreatestId = fmap greatestId . getAllocatedIds+++-- | Invoke a callback for each HSEC ID in the reserved+-- directory. The results are combined monoidally.+--+forReserved+ :: (MonadIO m, Monoid r)+ => FilePath -> (FilePath -> HsecId -> m r) -> m r+forReserved root =+ _forFiles (root </> dirNameAdvisories </> dirNameReserved)++-- | Invoke a callback for each HSEC ID under each of the advisory+-- subdirectories, excluding the @reserved@ directory. The results+-- are combined monoidally.+--+-- The same ID could appear multiple times. In particular, the callback+-- is invoked for symbolic links as well as regular files.+--+forAdvisory+ :: (MonadIO m, Monoid r)+ => FilePath -> (FilePath -> HsecId -> m r) -> m r+forAdvisory root go = do+ let dir = root </> dirNameAdvisories+ subdirs <- filter (/= dirNameReserved) <$> _getSubdirs dir+ fmap fold $ for subdirs $ \subdir -> _forFiles (dir </> subdir) go++-- | List deduplicated parsed Advisories+listAdvisories+ :: (MonadIO m)+ => FilePath -> m (Validation [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++-- | 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.+--+_getSubdirs :: (MonadIO m) => FilePath -> m [FilePath]+_getSubdirs root =+ execWriterT $+ pathWalkInterruptible root $ \_ subdirs _ -> do+ tell subdirs+ pure Stop++_forFiles+ :: (MonadIO m, Monoid r)+ => FilePath -- ^ (sub)directory name+ -> (FilePath -> HsecId -> m r)+ -> m r+_forFiles root go =+ pathWalkAccumulate root $ \dir _ files ->+ fmap fold $ for files $ \file ->+ case parseHsecId (takeBaseName file) of+ Nothing -> pure mempty+ Just hsid -> go (dir </> file) hsid
+ src/Security/Advisories/Generate/HTML.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Security.Advisories.Generate.HTML+ ( renderAdvisoriesIndex,+ )+where++import Control.Monad (forM_)+import Data.List (sortOn)+import Data.List.Extra (groupSort)+import qualified Data.Map.Strict as Map+import Data.Ord (Down (..))+import Data.Text (Text)+import qualified Data.Text as T+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 System.Directory (createDirectoryIfMissing)+import System.Exit (exitFailure)+import System.FilePath ((</>))+import System.IO (hPrint, stderr)++import Distribution.Pretty (prettyShow)+import Lucid+import Safe (maximumMay)+import qualified Text.Atom.Feed as Feed+import qualified Text.Atom.Feed.Export as FeedExport+import Validation (Validation (..))++import qualified Security.Advisories as Advisories+import Security.Advisories.Filesystem (listAdvisories)++-- * Actions++renderAdvisoriesIndex :: FilePath -> FilePath -> IO ()+renderAdvisoriesIndex src dst = do+ advisories <-+ listAdvisories src >>= \case+ Failure errors -> do+ T.hPutStrLn stderr "Cannot parse some advisories"+ forM_ errors $+ hPrint stderr+ exitFailure+ Success advisories ->+ return advisories++ let renderHTMLToFile path content = do+ putStrLn $ "Rendering " <> path+ renderToFile path content++ createDirectoryIfMissing False dst+ let indexAdvisories = map toAdvisoryR advisories+ renderHTMLToFile (dst </> "by-dates.html") $ listByDates indexAdvisories+ renderHTMLToFile (dst </> "by-packages.html") $ listByPackages indexAdvisories++ 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)++ putStrLn $ "Rendering " <> (dst </> "atom.xml")+ writeFile (dst </> "atom.xml") $ T.unpack $ renderFeed advisories++-- * Rendering types++data AdvisoryR = AdvisoryR+ { advisoryId :: Advisories.HsecId,+ advisorySummary :: Text,+ advisoryAffected :: [AffectedPackageR],+ advisoryModified :: ZonedTime+ }+ deriving stock (Show)++data AffectedPackageR = AffectedPackageR+ { packageName :: Text,+ introduced :: Text,+ fixed :: Maybe Text+ }+ deriving stock (Eq, Show)++-- * Pages++listByDates :: [AdvisoryR] -> Html ()+listByDates advisories =+ inPage PageListByDates $+ div_ [class_ "pure-u-1"] $ do+ 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++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+ ]++ 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"++ 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++-- * Utils++data NavigationPage+ = PageListByDates+ | PageListByPackages+ | PageAdvisory+ deriving stock (Eq, Show)++baseUrlForPage :: NavigationPage -> Text+baseUrlForPage = \case+ PageListByDates -> "."+ PageListByPackages -> "."+ PageAdvisory -> ".."++inPage :: NavigationPage -> Html () -> Html ()+inPage page content =+ doctypehtml_ $+ html_ $ 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"]+ 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;",+ "}"+ ]+ 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_ "content"] content++advisoryHtmlFilename :: Advisories.HsecId -> FilePath+advisoryHtmlFilename advisoryId' = Advisories.printHsecId advisoryId' <> ".html"++advisoryLink :: Advisories.HsecId -> Text+advisoryLink advisoryId' = "advisory/" <> T.pack (advisoryHtmlFilename advisoryId')++toAdvisoryR :: Advisories.Advisory -> AdvisoryR+toAdvisoryR x =+ AdvisoryR+ { advisoryId = Advisories.advisoryId x,+ advisorySummary = Advisories.advisorySummary x,+ advisoryAffected = concatMap toAffectedPackageR $ Advisories.advisoryAffected x,+ advisoryModified = Advisories.advisoryModified x+ }+ where+ toAffectedPackageR :: Advisories.Affected -> [AffectedPackageR]+ toAffectedPackageR p =+ flip map (Advisories.affectedVersions p) $ \versionRange ->+ AffectedPackageR+ { packageName = Advisories.affectedPackage 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 =+ ( 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" }]+ }+ 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))+ }++ mkSummary advisory =+ Feed.TextString $+ T.pack (Advisories.printHsecId (Advisories.advisoryId advisory))+ <> " - "+ <> Advisories.advisorySummary advisory+ toUrl advisory = advisoriesRootUrl <> "/" <> advisoryLink (Advisories.advisoryId advisory)++renderFeed :: [Advisories.Advisory] -> Text+renderFeed =+ maybe (error "Cannot render atom feed") TL.toStrict+ . FeedExport.textFeed+ . feed++advisoriesRootUrl :: T.Text+advisoriesRootUrl = "https://haskell.github.io/security-advisories"++atomFeedUrl :: T.Text+atomFeedUrl = advisoriesRootUrl <> "/atom.xml"
+ src/Security/Advisories/Git.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE LambdaCase #-}++{-|++Helpers for deriving advisory metadata from a Git repo.++-}+module Security.Advisories.Git+ ( AdvisoryGitInfo(..)+ , GitError(..)+ , explainGitError+ , getAdvisoryGitInfo+ , getRepoRoot+ , add+ , commit+ )+ where++import Data.Char (isSpace)+import Data.List (dropWhileEnd)+import Data.Time (ZonedTime)+import Data.Time.Format.ISO8601 (iso8601ParseM)+import System.Exit (ExitCode(ExitSuccess))+import System.FilePath (splitFileName)+import System.Process (readProcessWithExitCode)++data AdvisoryGitInfo = AdvisoryGitInfo+ { firstAppearanceCommitDate :: ZonedTime+ , lastModificationCommitDate :: ZonedTime+ }++data GitError+ = GitProcessError ExitCode String String -- ^ exit code, stdout and stderr+ | GitTimeParseError String -- ^ unable to parse this input as a datetime+ deriving (Show)++explainGitError :: GitError -> String+explainGitError = \case+ GitProcessError status stdout stderr ->+ unlines+ [ "git exited with status " <> show status+ , ">>> standard output:"+ , stdout+ , ">>> standard error:"+ , stderr+ ]+ GitTimeParseError s ->+ "failed to parse time: " <> s++-- | Get top-level directory of the working tree.+--+getRepoRoot :: FilePath -> IO (Either GitError FilePath)+getRepoRoot path = do+ (status, stdout, stderr) <- readProcessWithExitCode+ "git"+ [ "-C", path+ , "rev-parse"+ , "--show-toplevel"+ ]+ "" -- standard input+ pure $ case status of+ ExitSuccess -> Right $ trim stdout+ _ -> Left $ GitProcessError status stdout stderr+ where+ trim = dropWhileEnd isSpace . dropWhile isSpace++-- | Add changes to index+--+add+ :: FilePath -- ^ path to working tree+ -> [FilePath] -- ^ files to update in index+ -> IO (Either GitError ())+add path pathspecs = do+ (status, stdout, stderr) <- readProcessWithExitCode+ "git"+ ( ["-C", path, "add"] <> pathspecs )+ "" -- standard input+ pure $ case status of+ ExitSuccess -> Right ()+ _ -> Left $ GitProcessError status stdout stderr++-- | Commit changes to repo.+--+commit+ :: FilePath -- ^ path to working tree+ -> String -- ^ commit message+ -> IO (Either GitError ())+commit path msg = do+ (status, stdout, stderr) <- readProcessWithExitCode+ "git"+ ["-C", path, "commit", "-m", msg]+ "" -- standard input+ pure $ case status of+ ExitSuccess -> Right ()+ _ -> Left $ GitProcessError status stdout stderr++getAdvisoryGitInfo :: FilePath -> IO (Either GitError AdvisoryGitInfo)+getAdvisoryGitInfo path = do+ let (dir, file) = splitFileName path+ (status, stdout, stderr) <- readProcessWithExitCode+ "git"+ [ "-C", dir+ , "log"+ , "--pretty=format:%cI" -- print committer date+ , "--find-renames"+ , file+ ]+ "" -- standard input+ let timestamps = filter (not . null) $ lines stdout+ case status of+ ExitSuccess | not (null timestamps) ->+ pure $ AdvisoryGitInfo+ <$> parseTime (last timestamps) -- first commit is last line+ <*> parseTime (head timestamps) -- most recent commit is first line+ _ ->+ -- `null lines` should not happen, but if it does we treat it+ -- the same as `ExitFailure`+ pure . Left $ GitProcessError status stdout stderr+ where+ parseTime s = maybe (Left $ GitTimeParseError s) Right $ iso8601ParseM s
+ src/Security/Advisories/Parse.hs view
@@ -0,0 +1,595 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Security.Advisories.Parse+ ( parseAdvisory+ , OutOfBandAttributes(..)+ , emptyOutOfBandAttributes+ , AttributeOverridePolicy(..)+ , ParseAdvisoryError(..)+ )+ where++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 GHC.Generics (Generic)++import qualified Data.Map as Map+import Data.Sequence (Seq((:<|)))+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 Commonmark.Html (Html, renderHtml)+import qualified Commonmark.Parser as Commonmark+import Commonmark.Types (HasAttributes(..), IsBlock(..), IsInline(..), Rangeable(..), SourceRange(..))+import Commonmark.Pandoc (Cm(unCm))+import qualified Toml+import qualified Toml.Syntax as Toml (startPos)+import qualified Toml.Schema as Toml+import Text.Pandoc.Builder (Blocks, Many(..))+import Text.Pandoc.Definition (Block(..), Inline(..), Pandoc(..))+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+-- | 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+ }+ deriving (Show)++emptyOutOfBandAttributes :: OutOfBandAttributes+emptyOutOfBandAttributes = OutOfBandAttributes+ { oobModified = Nothing+ , oobPublished = Nothing+ }++data AttributeOverridePolicy+ = PreferInBand+ | PreferOutOfBand+ | NoOverrides -- ^ Parse error if attribute occurs both in-band and out-of-band+ 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)++-- | The main parsing function. 'OutOfBandAttributes' are handled+-- according to the 'AttributeOverridePolicy'.+--+parseAdvisory+ :: AttributeOverridePolicy+ -> OutOfBandAttributes+ -> T.Text -- ^ input (CommonMark with TOML header)+ -> Either ParseAdvisoryError Advisory+parseAdvisory policy attrs raw = do+ markdown <-+ unCm+ <$> firstPretty MarkdownError (T.pack . show)+ (Commonmark.commonmark "input" raw :: Either Commonmark.ParseError (Cm () Blocks))+ (frontMatter, rest) <- first MarkdownFormatError $ advisoryDoc markdown+ let doc = Pandoc mempty rest+ !summary <- first MarkdownFormatError $ parseAdvisorySummary doc+ table <- case Toml.parse frontMatter of+ Left e -> Left (TomlError e (T.pack e))+ Right t -> Right t++ -- Re-parse as FirstSourceRange to find the source range of+ -- the TOML header.+ FirstSourceRange (First mRange) <-+ firstPretty MarkdownError (T.pack . show) (Commonmark.commonmark "input" raw)+ let+ details = case mRange of+ Just (SourceRange ((_,end):_)) ->+ T.unlines+ . dropWhile T.null+ . fmap snd+ . dropWhile ((< sourceLine end) . fst)+ . zip [1..]+ $ T.lines raw+ _ ->+ -- 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 <-+ T.toStrict . renderHtml+ <$> firstPretty MarkdownError (T.pack . show)+ (Commonmark.commonmark "input" raw :: Either Commonmark.ParseError (Html ()))++ case parseAdvisoryTable attrs policy doc summary details html table of+ Left es -> Left (AdvisoryError es (T.pack (unlines (map Toml.prettyMatchMessage es))))+ Right adv -> pure adv++ where+ firstPretty+ :: (e -> T.Text -> ParseAdvisoryError)+ -> (e -> T.Text)+ -> Either e a+ -> Either ParseAdvisoryError a+ firstPretty ctr pretty = first $ mkPretty ctr pretty++ mkPretty+ :: (e -> T.Text -> ParseAdvisoryError)+ -> (e -> T.Text)+ -> e+ -> ParseAdvisoryError+ mkPretty ctr pretty x = ctr x $ pretty x++parseAdvisoryTable+ :: OutOfBandAttributes+ -> AttributeOverridePolicy+ -> Pandoc -- ^ parsed document (without frontmatter)+ -> T.Text -- ^ summary+ -> T.Text -- ^ details+ -> T.Text -- ^ rendered HTML+ -> Toml.Table' Toml.Position+ -> Either [Toml.MatchMessage Toml.Position] Advisory+parseAdvisoryTable oob policy doc summary details html tab =+ Toml.runMatcherFatalWarn $+ do fm <- Toml.fromValue (Toml.Table' Toml.startPos tab)+ published <-+ mergeOobMandatory policy+ (oobPublished oob)+ "advisory.date"+ (amdPublished (frontMatterAdvisory fm))+ modified <-+ fromMaybe published <$>+ mergeOobOptional policy+ (oobPublished oob)+ "advisory.modified"+ (amdModified (frontMatterAdvisory fm))+ pure Advisory+ { advisoryId = amdId (frontMatterAdvisory fm)+ , advisoryPublished = published+ , advisoryModified = modified+ , advisoryCAPECs = amdCAPECs (frontMatterAdvisory fm)+ , advisoryCWEs = amdCWEs (frontMatterAdvisory fm)+ , advisoryKeywords = amdKeywords (frontMatterAdvisory fm)+ , advisoryAliases = amdAliases (frontMatterAdvisory fm)+ , advisoryRelated = amdRelated (frontMatterAdvisory fm)+ , advisoryAffected = frontMatterAffected fm+ , advisoryReferences = frontMatterReferences fm+ , advisoryPandoc = doc+ , advisoryHtml = html+ , advisorySummary = summary+ , 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"++advisoryDoc :: Blocks -> Either T.Text (T.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"++parseAdvisorySummary :: Pandoc -> Either T.Text T.Text+parseAdvisorySummary = fmap inlineText . firstHeading++firstHeading :: Pandoc -> Either T.Text [Inline]+firstHeading (Pandoc _ xs) = go xs+ where+ 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 = 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++mergeOob+ :: MonadFail m+ => AttributeOverridePolicy+ -> Maybe a -- ^ out-of-band value+ -> String -- ^ key+ -> Maybe a -- ^ in-band-value+ -> 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+ 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++mergeOobOptional+ :: MonadFail m+ => AttributeOverridePolicy+ -> Maybe 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)++mergeOobMandatory+ :: MonadFail m+ => AttributeOverridePolicy+ -> Maybe a -- ^ 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++-- | 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
+ src/Security/Advisories/Queries.hs view
@@ -0,0 +1,65 @@+module Security.Advisories.Queries+ ( listVersionAffectedBy+ , listVersionRangeAffectedBy+ , isVersionAffectedBy+ , isVersionRangeAffectedBy+ )+where++import Control.Monad.IO.Class (MonadIO)+import Data.Text (Text)+import Distribution.Types.Version (Version)+import Distribution.Types.VersionInterval (asVersionIntervals)+import Distribution.Types.VersionRange (VersionRange, anyVersion, earlierVersion, intersectVersionRanges, noVersion, orLaterVersion, unionVersionRanges, withinRange)+import Validation (Validation(..))++import Security.Advisories.Core.Advisory+import Security.Advisories.Filesystem+import Security.Advisories.Parse++-- | Check whether a package and a version is concerned by an advisory+isVersionAffectedBy :: Text -> Version -> Advisory -> Bool+isVersionAffectedBy = isAffectedByHelper withinRange++-- | Check whether a package and a version range is concerned by an advisory+isVersionRangeAffectedBy :: Text -> VersionRange -> Advisory -> Bool+isVersionRangeAffectedBy = isAffectedByHelper $+ \queryVersionRange affectedVersionRange ->+ isSomeVersion (affectedVersionRange `intersectVersionRanges` queryVersionRange)+ where+ isSomeVersion :: VersionRange -> Bool+ isSomeVersion range+ | [] <- asVersionIntervals range = False+ | otherwise = True++-- | Helper function for 'isVersionAffectedBy' and 'isVersionRangeAffectedBy'+isAffectedByHelper :: (a -> VersionRange -> Bool) -> Text -> a -> Advisory -> Bool+isAffectedByHelper checkWithRange queryPackageName queryVersionish =+ any checkAffected . advisoryAffected+ where+ checkAffected :: Affected -> Bool+ checkAffected affected =+ queryPackageName == affectedPackage affected+ && checkWithRange queryVersionish (fromAffected affected)++ fromAffected :: Affected -> VersionRange+ fromAffected = foldr (unionVersionRanges . fromAffectedVersionRange) noVersion . affectedVersions++ fromAffectedVersionRange :: AffectedVersionRange -> VersionRange+ fromAffectedVersionRange avr = intersectVersionRanges+ (orLaterVersion (affectedVersionRangeIntroduced avr))+ (maybe anyVersion earlierVersion (affectedVersionRangeFixed avr))++-- | List the advisories matching a package name and a version+listVersionAffectedBy :: MonadIO m => FilePath -> Text -> Version -> m (Validation [ParseAdvisoryError] [Advisory])+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 = listAffectedByHelper isVersionRangeAffectedBy++-- | Helper function for 'listVersionAffectedBy' and 'listVersionRangeAffectedBy'+listAffectedByHelper :: MonadIO m => (Text -> a -> Advisory -> Bool) -> FilePath -> Text -> a -> m (Validation [ParseAdvisoryError] [Advisory])+listAffectedByHelper checkAffectedBy root queryPackageName queryVersionish =+ fmap (filter (checkAffectedBy queryPackageName queryVersionish)) <$>+ listAdvisories root
+ test/Spec.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Aeson.Encode.Pretty (encodePretty)+import Data.List (isSuffixOf)+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.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 qualified Security.Advisories.Convert.OSV as OSV+import Security.Advisories.Parse+import qualified Spec.QueriesSpec as QueriesSpec++main :: IO ()+main = do+ goldenFiles <- listGoldenFiles+ defaultMain $+ testGroup "Tests"+ [ goldenTestsSpec goldenFiles+ , QueriesSpec.spec+ ]++listGoldenFiles :: IO [FilePath]+listGoldenFiles = map (mappend dpath) . filter (not . isSuffixOf ".golden") <$> listDirectory dpath+ where+ dpath = "test/golden/"++goldenTestsSpec :: [FilePath] -> TestTree+goldenTestsSpec goldenFiles = testGroup "Golden test" $ map doGoldenTest goldenFiles++doGoldenTest :: FilePath -> TestTree+doGoldenTest fp = goldenVsString fp (fp <> ".golden") (LText.encodeUtf8 <$> doCheck)+ 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+ osvExport = case res of+ Right adv ->+ let osv = OSV.convert adv+ in LText.unlines+ [ pShowNoColor osv+ , LText.decodeUtf8 (encodePretty osv)+ ]+ Left _ -> ""+ pure (LText.unlines [pShowNoColor res, osvExport])
+ test/Spec/QueriesSpec.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Spec.QueriesSpec (spec) where++import Data.Bifunctor (first)+import Data.Either (fromRight)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Distribution.Parsec (eitherParsec)+import Distribution.Types.Version (version0, alterVersion)+import Distribution.Types.VersionRange (VersionRange, VersionRangeF(..), anyVersion, projectVersionRange)+import Test.Tasty+import Test.Tasty.HUnit++import Security.CVSS (parseCVSS)+import Security.Advisories.Core.Advisory+import Security.Advisories.Core.HsecId+import Security.Advisories.Queries++spec :: TestTree+spec =+ testGroup "Queries" [+ testGroup "isAffectedBy" $+ flip concatMap cases $ map $ \(actual, query, expected) ->+ let title x y =+ if expected+ then show x <> " is vulnerable to " <> show y+ else show x <> " is not vulnerable to " <> show y+ versionRange x =+ either (\e -> error $ "Cannot parse version range " <> show x <> " : " <> show e) id $+ parseVersionRange $+ if x == ""+ then Nothing+ else Just x+ in testCase (title actual query) $+ let query' = versionRange query+ affectedVersion' = versionRange actual+ in isVersionRangeAffectedBy packageName query' (mkAdvisory affectedVersion')+ @?= expected+ ]++cases :: [[(Text, Text, Bool)]]+cases =+ [+ reversible ("", "", True)+ , reversible ("", "==1", True)+ , reversible ("==1.1", "<=2", True)+ , reversible ("==1.1", ">1", True)+ , reversible ("==1", "==1", True)+ , reversible ("==2||==1", "==1", True)+ , reversible ("==1.1", "<=2&&>1", True)+ , reversible ("^>=1", ">1&&<1.2", True)+ , reversible (">=1", "==2", True)+ , reversible (">=1", "==1", True)+ , reversible ("==2", ">=2", True)+ , reversible ("==2", ">1", True)+ , reversible (">5", ">=2", True)+ , reversible (">5", ">2", True)+ , reversible ("==5", ">=2", True)+ , reversible ("==5", ">2", True)+ , reversible (">=5", ">2", True)+ , reversible ("<=5", ">2", True)+ , reversible ("<=5", "<=2", True)+ , reversible ("<5", ">=2", True)+ , reversible (">=2", "==5", True)+ , reversible (">2", "==5", True)+ , reversible (">5", ">=5", True)+ , reversible ("^>=1.1", ">1", True)+ , reversible ("^>=1.1", "<2", True)+ , reversible ("^>=1.1", "<=1.2", True)+ , reversible ("^>=1.1", ">1.1", True)+ , reversible ("^>=1.1", ">=1.1.5", True)+ , reversible ("^>=1.1", ">=1", True)+ , reversible ("==1.1", "<1", False)+ , reversible ("==2.1", "<=2", False)+ , reversible ("==1", ">1.1", False)+ , reversible ("==2", "==1", False)+ , reversible ("==2||==1", ">3", False)+ , notReversible ("<=2&&>1", "==3", True)+ , reversible (">=2", "==1.1", False)+ , reversible (">=1.1", "==1", False)+ , reversible ("==2", ">=2.1", False)+ , notReversible (">1", "==1", False)+ , reversible ("<2", ">=2", False)+ , reversible ("==2", ">=5", False)+ , reversible ("==2", ">5", False)+ , reversible ("<=2", ">5", False)+ , reversible ("<=2", ">5", False)+ , reversible ("<2", ">=5", False)+ , reversible (">=2", "==1.1", False)+ , reversible ("<2", "==5", False)+ , reversible ("<5", ">=5", False)+ , reversible ("^>=1.1", "<1", False)+ , reversible ("^>=1.1", "<1.1", False)+ , reversible ("^>=1.1", ">=1.2", False)+ , reversible ("^>=1.1", "<=1", False)+ , reversible ("^>=1.1", ">2", False)+ , reversible ("^>=1", ">=2", False)+ ]+ where reversible (query, affectedVersion, expected) = [(query, affectedVersion, expected), (query, affectedVersion, expected)]+ notReversible (query, affectedVersion, expected) = [(query, affectedVersion, expected), (affectedVersion, query, not expected)]++mkAdvisory :: VersionRange -> Advisory+mkAdvisory versionRange =+ Advisory+ { advisoryId = fromMaybe (error "Cannot mkHsecId") $ mkHsecId 2023 42+ , advisoryModified = read "2023-01-01T00:00:00"+ , advisoryPublished = read "2023-01-01T00:00:00"+ , advisoryCAPECs = []+ , advisoryCWEs = []+ , advisoryKeywords = []+ , advisoryAliases = [ "CVE-2022-XXXX" ]+ , advisoryRelated = [ "CVE-2022-YYYY" , "CVE-2022-ZZZZ" ]+ , advisoryAffected =+ [ Affected+ { affectedPackage = packageName+ , affectedCVSS = cvss+ , affectedVersions = mkAffectedVersions versionRange+ , affectedArchitectures = Nothing+ , affectedOS = Nothing+ , affectedDeclarations = []+ }+ ]+ , advisoryReferences = []+ , advisoryPandoc = mempty+ , advisoryHtml = ""+ , advisorySummary = ""+ , advisoryDetails = ""+ }+ where+ cvss = fromRight (error "Cannot parseCVSS") (parseCVSS "CVSS:3.1/AV:N/AC:L/PR:N/UI:N/S:U/C:H/I:H/A:H")++mkAffectedVersions :: VersionRange -> [AffectedVersionRange]+mkAffectedVersions vr =+ let+ fixed from to =+ AffectedVersionRange+ { affectedVersionRangeIntroduced = from+ , affectedVersionRangeFixed = Just to+ }+ onlyFixed to =+ AffectedVersionRange+ { affectedVersionRangeIntroduced = version0+ , affectedVersionRangeFixed = Just to+ }+ vulnerable from =+ AffectedVersionRange+ { affectedVersionRangeIntroduced = from+ , affectedVersionRangeFixed = Nothing+ }+ nextMinor =+ \case+ [] -> [1]+ [x] -> [x, 1]+ [x, y] -> [x, y, 1]+ [x, y, z] -> [x, y, z, 1]+ [w, x, y, z] -> [w, x, y, z + 1]+ xs -> xs ++ [1]+ previousMinor =+ \case+ [] -> [0]+ [x] -> [x - 1 , 99]+ [x, y] -> [x, y - 1, 99]+ [x, y, z] -> [x, y, z - 1, 99]+ [w, x, y, z] -> [w, x, y, z - 1]+ _ -> error "TODO"+ mkMajorBoundVersion =+ \case+ [] -> [0]+ [x] -> [x, 1]+ (x:y:_) -> [x, y + 1]+ in+ case projectVersionRange vr of+ ThisVersionF x -> [fixed x $ alterVersion (<> [0,0,1]) x]+ LaterVersionF x -> [vulnerable $ alterVersion nextMinor x]+ OrLaterVersionF x -> [vulnerable x]+ EarlierVersionF x -> [onlyFixed $ alterVersion previousMinor x]+ OrEarlierVersionF x -> [onlyFixed x]+ MajorBoundVersionF x -> [fixed x $ alterVersion mkMajorBoundVersion x]+ UnionVersionRangesF x y -> mkAffectedVersions x <> mkAffectedVersions y+ IntersectVersionRangesF x y ->+ [ low { affectedVersionRangeFixed = affectedVersionRangeFixed high }+ | low <- mkAffectedVersions x+ , high <- mkAffectedVersions y+ ]++packageName :: Text+packageName = "package-name"++-- | Parse 'VersionRange' as given to the CLI+parseVersionRange :: Maybe Text -> Either Text VersionRange+parseVersionRange = maybe (return anyVersion) (first T.pack . eitherParsec . T.unpack)
+ test/golden/EXAMPLE_ADVISORY.md view
@@ -0,0 +1,32 @@+```toml++[advisory]+id = "HSEC-0000-0000"+cwe = []+keywords = ["example", "freeform", "keywords"]+aliases = ["CVE-2022-XXXX"]+related = ["CVE-2022-YYYY", "CVE-2022-ZZZZ"]++[[affected]]+package = "package-name"+cvss = "CVSS:3.1/AV:N/AC:L/PR:N/UI:N/S:U/C:H/I:H/A:H"++[[affected.versions]]+introduced = "1.0.8"+fixed = "1.1"+[[affected.versions]]+introduced = "1.1.2"++[[references]]+type = "ARTICLE"+url = "https://example.com"+```++# Advisory Template - Title Goes Here++This is an example template.++ * Markdown+ * TOML "front matter".++ > Acme Broken.
+ test/golden/EXAMPLE_ADVISORY.md.golden view
@@ -0,0 +1,259 @@+Right+ ( Advisory+ { advisoryId = HSEC-0000-0000+ , advisoryModified = 1970-01-01 00:00:00 UTC+ , advisoryPublished = 1970-01-01 00:00:00 UTC+ , advisoryCAPECs = []+ , advisoryCWEs = []+ , advisoryKeywords =+ [ "example"+ , "freeform"+ , "keywords"+ ]+ , advisoryAliases = [ "CVE-2022-XXXX" ]+ , advisoryRelated =+ [ "CVE-2022-YYYY"+ , "CVE-2022-ZZZZ"+ ]+ , advisoryAffected =+ [ Affected+ { affectedPackage = "package-name"+ , affectedCVSS = CVSS:3.1/AV:N/AC:L/PR:N/UI:N/S:U/C:H/I:H/A:H+ , affectedVersions =+ [ AffectedVersionRange+ { affectedVersionRangeIntroduced = mkVersion+ [ 1+ , 0+ , 8+ ]+ , affectedVersionRangeFixed = Just+ ( mkVersion+ [ 1+ , 1+ ]+ )+ }+ , AffectedVersionRange+ { affectedVersionRangeIntroduced = mkVersion+ [ 1+ , 1+ , 2+ ]+ , affectedVersionRangeFixed = Nothing+ }+ ]+ , affectedArchitectures = Nothing+ , affectedOS = Nothing+ , affectedDeclarations = []+ }+ ]+ , advisoryReferences =+ [ Reference+ { referencesType = ReferenceTypeArticle+ , referencesUrl = "https://example.com"+ }+ ]+ , advisoryPandoc = Pandoc+ ( Meta+ { unMeta = fromList [] }+ )+ [ Header 1+ ( ""+ , []+ , []+ )+ [ Str "Advisory"+ , Space+ , Str "Template"+ , Space+ , Str "-"+ , Space+ , Str "Title"+ , Space+ , Str "Goes"+ , Space+ , Str "Here"+ ]+ , Para+ [ Str "This"+ , Space+ , Str "is"+ , Space+ , Str "an"+ , Space+ , Str "example"+ , Space+ , Str "template."+ ]+ , BulletList+ [+ [ Plain+ [ Str "Markdown" ]+ ]+ ,+ [ Plain+ [ Str "TOML"+ , Space+ , Str ""front"+ , Space+ , Str "matter"."+ ]+ ]+ ]+ , BlockQuote+ [ Para+ [ Str "Acme"+ , Space+ , Str "Broken."+ ]+ ]+ ]+ , advisoryHtml = "<pre><code class="language-toml">+ [advisory]+ id = "HSEC-0000-0000"+ cwe = []+ keywords = ["example", "freeform", "keywords"]+ aliases = ["CVE-2022-XXXX"]+ related = ["CVE-2022-YYYY", "CVE-2022-ZZZZ"]++ [[affected]]+ package = "package-name"+ cvss = "CVSS:3.1/AV:N/AC:L/PR:N/UI:N/S:U/C:H/I:H/A:H"++ [[affected.versions]]+ introduced = "1.0.8"+ fixed = "1.1"+ [[affected.versions]]+ introduced = "1.1.2"++ [[references]]+ type = "ARTICLE"+ url = "https://example.com"+ </code></pre>+ <h1>Advisory Template - Title Goes Here</h1>+ <p>This is an example template.</p>+ <ul>+ <li>Markdown+ </li>+ <li>TOML "front matter".+ </li>+ </ul>+ <blockquote>+ <p>Acme Broken.</p>+ </blockquote>+ "+ , advisorySummary = "Advisory Template - Title Goes Here"+ , advisoryDetails = "# Advisory Template - Title Goes Here++ This is an example template.++ * Markdown+ * TOML "front matter".++ > Acme Broken.+ "+ }+ )+Model+ { modelSchemaVersion = "1.5.0"+ , modelId = "HSEC-0000-0000"+ , modelModified = 1970-01-01 00:00:00 UTC+ , modelPublished = Just 1970-01-01 00:00:00 UTC+ , modelWithdrawn = Nothing+ , modelAliases = [ "CVE-2022-XXXX" ]+ , modelRelated =+ [ "CVE-2022-YYYY"+ , "CVE-2022-ZZZZ"+ ]+ , modelSummary = Just "Advisory Template - Title Goes Here"+ , modelDetails = Just "# Advisory Template - Title Goes Here++ This is an example template.++ * Markdown+ * TOML "front matter".++ > Acme Broken.+ "+ , modelSeverity = []+ , modelAffected =+ [ Affected+ { affectedRanges =+ [ RangeEcosystem+ [ EventIntroduced "1.0.8"+ , EventFixed "1.1"+ , EventIntroduced "1.1.2"+ ] Nothing+ ]+ , affectedPackage = Package+ { packageName = "package-name"+ , packageEcosystem = "Hackage"+ , packagePurl = Nothing+ }+ , affectedSeverity =+ [ Severity CVSS:3.1/AV:N/AC:L/PR:N/UI:N/S:U/C:H/I:H/A:H ]+ , affectedEcosystemSpecific = Nothing+ , affectedDatabaseSpecific = Nothing+ }+ ]+ , modelReferences =+ [ Reference+ { referencesType = ReferenceTypeArticle+ , referencesUrl = "https://example.com"+ }+ ]+ , modelCredits = []+ , modelDatabaseSpecific = Nothing+ }+{+ "affected": [+ {+ "package": {+ "ecosystem": "Hackage",+ "name": "package-name"+ },+ "ranges": [+ {+ "events": [+ {+ "introduced": "1.0.8"+ },+ {+ "fixed": "1.1"+ },+ {+ "introduced": "1.1.2"+ }+ ],+ "type": "ECOSYSTEM"+ }+ ],+ "severity": [+ {+ "score": "CVSS:3.1/AV:N/AC:L/PR:N/UI:N/S:U/C:H/I:H/A:H",+ "type": "CVSS_V3"+ }+ ]+ }+ ],+ "aliases": [+ "CVE-2022-XXXX"+ ],+ "details": "# Advisory Template - Title Goes Here\n\nThis is an example template.\n\n * Markdown\n * TOML \"front matter\".\n\n > Acme Broken.\n",+ "id": "HSEC-0000-0000",+ "modified": "1970-01-01T00:00:00Z",+ "published": "1970-01-01T00:00:00Z",+ "references": [+ {+ "type": "ARTICLE",+ "url": "https://example.com"+ }+ ],+ "related": [+ "CVE-2022-YYYY",+ "CVE-2022-ZZZZ"+ ],+ "schema_version": "1.5.0",+ "summary": "Advisory Template - Title Goes Here"+}+
+ test/golden/MISSING_AFFECTED.md view
@@ -0,0 +1,7 @@+```toml+[advisory]+id = "HSEC-0000-0000"+cwe = []+```++## Title
+ test/golden/MISSING_AFFECTED.md.golden view
@@ -0,0 +1,17 @@+Left+ ( AdvisoryError+ [ MatchMessage+ { matchAnn = Just+ ( Position+ { posIndex = 0+ , posLine = 1+ , posColumn = 1+ }+ )+ , matchPath = []+ , matchMessage = "missing key: affected"+ }+ ] "1:1: missing key: affected in <top-level>+ "+ )+
+ test/golden/MISSING_TITLE.md view
@@ -0,0 +1,6 @@+```toml+[advisory]+id = "HSEC-0000-0000"+cwe = []+date = 1970-01-01+```
+ test/golden/MISSING_TITLE.md.golden view
@@ -0,0 +1,3 @@+Left+ ( MarkdownFormatError "Does not have summary heading" )+