feature: add query command to check wheter a package/version is affected

code/hsec-tools/app/Main.hs

@@ -3,22 +3,28 @@
 
 module Main where
 
-import Control.Monad (join, void, when)
+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 qualified Data.Text.IO as T
-import Options.Applicative
+import Distribution.Parsec (eitherParsec)
+import Distribution.Types.VersionRange (VersionRange, anyVersion)
 import System.Exit (die, exitFailure, exitSuccess)
-import System.IO (stderr)
+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
@@ -37,6 +43,7 @@ cliOpts = info (commandsParser <**> helper) (fullDesc <> header "Haskell Advisor
         <> 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"))
         )
 
@@ -94,6 +101,37 @@ commandRender =
   <$> optional (argument str (metavar "FILE"))
   <**> helper
 
+commandQuery :: Parser (IO ())
+commandQuery =
+  subparser
+    ( command "is-affected" (info isAffected (progDesc "Check if a package/version range is marked vulnerable"))
+    )
+    <**> helper
+  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"))
+        <**> helper
+      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
@@ -113,6 +151,9 @@ commandHelp =
   <$> optional (argument str (metavar "COMMAND"))
   <**> helper
 
+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

code/hsec-tools/hsec-tools.cabal

@@ -3,7 +3,8 @@ 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
+synopsis:
+  Tools for working with the Haskell security advisory database
 
 -- A longer description of the package.
 description:
@@ -19,97 +20,100 @@ maintainer:         [email protected]
 
 -- A copyright notice.
 -- copyright:
-category: Data
-extra-doc-files: CHANGELOG.md
-extra-source-files: test/golden/*.md
-                    test/golden/*.golden
+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.7 || ==9.4.5 || ==9.6.2
 
 library
-    exposed-modules:    Security.Advisories
-                      , Security.Advisories.Definition
-                      , Security.Advisories.Filesystem
-                      , Security.Advisories.Git
-                      , Security.Advisories.HsecId
-                      , Security.Advisories.Parse
-                      , Security.Advisories.Convert.OSV
-                      , Security.Advisories.Generate.HTML
-                      , Security.OSV
-    build-depends:    base >=4.14 && < 4.19,
-                      directory < 2,
-                      extra ^>=1.7.5,
-                      filepath >= 1.4 && < 1.5,
-                      lucid >= 2.9.0,
-                      process >= 1.6 && < 1.7,
-                      text >= 1.2 && < 3,
-                      time >= 1.9 && < 1.14,
-                      Cabal-syntax >= 3.8.1.0 && < 3.11,
-                      mtl >= 2.2 && < 2.4,
-                      containers >= 0.6 && < 0.7,
-                      commonmark ^>= 0.2.2,
-                      aeson >= 2.0.1.0 && < 3,
-                      toml-parser ^>=1.3.0.0,
-                      pandoc-types >= 1.22 && < 2,
-                      pathwalk >= 0.3,
-                      parsec >= 3 && < 4,
-                      commonmark-pandoc >= 0.2 && < 0.3
-                      , safe >= 0.3
-    hs-source-dirs:   src
-    default-language: Haskell2010
-    ghc-options:      -Wall
-                      -Wcompat
-                      -Widentities
-                      -Wincomplete-record-updates
-                      -Wincomplete-uni-patterns
-                      -Wpartial-fields
-                      -Wredundant-constraints
+  exposed-modules:
+    Security.Advisories
+    Security.Advisories.Convert.OSV
+    Security.Advisories.Definition
+    Security.Advisories.Filesystem
+    Security.Advisories.Generate.HTML
+    Security.Advisories.Git
+    Security.Advisories.HsecId
+    Security.Advisories.Parse
+    Security.Advisories.Queries
+    Security.OSV
+
+  build-depends:
+    , aeson                 >=2.0.1.0 && <3
+    , base                  >=4.14    && <4.19
+    , Cabal-syntax          >=3.8.1.0 && <3.11
+    , commonmark            ^>=0.2.2
+    , commonmark-pandoc     >=0.2     && <0.3
+    , containers            >=0.6     && <0.7
+    , directory             <2
+    , extra                 ^>=1.7.5
+    , filepath              >=1.4     && <1.5
+    , lucid                 >=2.9.0
+    , mtl                   >=2.2     && <2.4
+    , pandoc-types          >=1.22    && <2
+    , parsec                >=3       && <4
+    , pathwalk              >=0.3
+    , process               >=1.6     && <1.7
+    , safe                  >=0.3
+    , text                  >=1.2     && <3
+    , time                  >=1.9     && <1.14
+    , toml-parser           ^>=1.3.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
+  main-is:          Main.hs
+  other-modules:    Command.Reserve
 
-    -- Modules included in this executable, other than Main.
-    -- other-modules:
+  -- Modules included in this executable, other than Main.
+  -- other-modules:
 
-    -- LANGUAGE extensions used by modules in this package.
-    -- other-extensions:
-    build-depends:    hsec-tools,
-                      base >=4.14 && < 4.19,
-                      aeson >= 2.0.1.0 && < 3,
-                      bytestring >= 0.10 && < 0.12,
-                      filepath >= 1.4 && < 1.5,
-                      optparse-applicative == 0.17.* || == 0.18.*,
-                      text >= 1.2 && < 3
-    hs-source-dirs:   app
-    default-language: Haskell2010
-    ghc-options:      -Wall
-                      -Wcompat
-                      -Widentities
-                      -Wincomplete-record-updates
-                      -Wincomplete-uni-patterns
-                      -Wpartial-fields
-                      -Wredundant-constraints
+  -- LANGUAGE extensions used by modules in this package.
+  -- other-extensions:
+  build-depends:
+    , aeson                 >=2.0.1.0 && <3
+    , base                  >=4.14    && <4.19
+    , bytestring            >=0.10    && <0.12
+    , Cabal-syntax          >=3.8.1.0 && <3.11
+    , filepath              >=1.4     && <1.5
+    , 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
-    build-depends:    base < 5
-                    , directory
-                    , hsec-tools
-                    , pretty-simple < 5
-                    , tasty < 1.5
-                    , tasty-golden < 2.4
-                    , time
-                    , text
-    default-language: Haskell2010
-    ghc-options:      -Wall
-                      -Wcompat
-                      -Widentities
-                      -Wincomplete-record-updates
-                      -Wincomplete-uni-patterns
-                      -Wpartial-fields
-                      -Wredundant-constraints
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   test
+  main-is:          Spec.hs
+  other-modules:    Spec.QueriesSpec
+  build-depends:
+    , base           <5
+    , Cabal-syntax
+    , directory
+    , 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

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

@@ -8,6 +8,7 @@ module Security.Advisories.Convert.OSV
 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
@@ -54,8 +55,10 @@ mkSeverity s = case T.take 6 s of
   _        -> []  -- unexpected; don't include severity
 
 mkRange :: [AffectedVersionRange] -> OSV.Range Void
-mkRange ranges = OSV.RangeEcosystem (foldMap mkEvs ranges) Nothing
+mkRange ranges =
+    OSV.RangeEcosystem (foldMap mkEvs ranges) Nothing
   where
-  mkEvs range =
-    OSV.EventIntroduced (affectedVersionRangeIntroduced range)
-    : maybe [] (pure . OSV.EventFixed) (affectedVersionRangeFixed range)
+    mkEvs :: AffectedVersionRange -> [OSV.Event T.Text]
+    mkEvs range =
+      OSV.EventIntroduced (T.pack $ prettyShow $ affectedVersionRangeIntroduced range)
+      : maybe [] (pure . OSV.EventFixed . T.pack . prettyShow) (affectedVersionRangeFixed range)

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

@@ -14,6 +14,7 @@ module Security.Advisories.Definition
 
 import Data.Text (Text)
 import Data.Time (ZonedTime)
+import Distribution.Types.Version (Version)
 import Distribution.Types.VersionRange (VersionRange)
 
 import Text.Pandoc.Definition (Pandoc)
@@ -98,7 +99,7 @@ newtype Keyword = Keyword Text
   deriving (Show) via Text
 
 data AffectedVersionRange = AffectedVersionRange
-  { affectedVersionRangeIntroduced :: Text,
-    affectedVersionRangeFixed :: Maybe Text
+  { affectedVersionRangeIntroduced :: Version,
+    affectedVersionRangeFixed :: Maybe Version
   }
   deriving stock (Show)

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+
 {-|
 
 Helpers for the /security-advisories/ file system.
@@ -19,20 +21,27 @@ module Security.Advisories.Filesystem
   , 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)
+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)
+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.HsecId (HsecId, parseHsecId, placeholder)
+import Security.Advisories.Git(firstAppearanceCommitDate, getAdvisoryGitInfo, lastModificationCommitDate)
 
 
 dirNameAdvisories :: FilePath
@@ -109,6 +118,27 @@ forAdvisory root go = do
   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.
@@ -126,8 +156,8 @@ _forFiles
   -> (FilePath -> HsecId -> m r)
   -> m r
 _forFiles root go =
-  pathWalkAccumulate root $ \_ _ files ->
+  pathWalkAccumulate root $ \dir _ files ->
     fmap fold $ for files $ \file ->
       case parseHsecId (takeBaseName file) of
         Nothing -> pure mempty
-        Just hsid -> go (root </> file) hsid
+        Just hsid -> go (dir </> file) hsid