[feat] add part of the implementation of looking up advisories in the DB

code/hsec-cabal/hsec-cabal.cabal

@@ -29,14 +29,22 @@ common common-all
   ghc-options:
     -Wall -Wcompat -Widentities -Wincomplete-record-updates
     -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints
+    -fmax-relevant-binds=0 -fno-show-valid-hole-fits
+
+  if impl(ghc >=9.6.1)
+    ghc-options: -fno-show-error-context
 
   default-extensions:
     BlockArguments
     DeriveGeneric
     DerivingStrategies
     EmptyCase
+    ImportQualifiedPost
     LambdaCase
     NamedFieldPuns
+    ScopedTypeVariables
+    StandaloneDeriving
+    StandaloneKindSignatures
 
 library
   import:           common-all
@@ -45,10 +53,15 @@ library
     Security.Advisories.Cabal
 
   build-depends:
-    , base           <5
+    , base                  <5
     , Cabal
     , cabal-install
+    , containers
+    , filepath
     , hsec-core
+    , hsec-tools
+    , text
+    , validation-selective
 
   hs-source-dirs:   src
   default-language: Haskell2010

code/hsec-cabal/src/Distribution/Audit.hs

@@ -1,7 +1,6 @@
 module Distribution.Audit (auditMain) where
 
 import Data.Foldable (traverse_)
-import qualified Distribution.Client.InstallPlan as Plan
 import Distribution.Client.NixStyleOptions
   ( NixStyleFlags (configFlags)
   , defaultNixStyleFlags
@@ -26,24 +25,59 @@ import Distribution.Simple.Command
   ( CommandParse (CommandErrors, CommandHelp, CommandList, CommandReadyToGo)
   , CommandUI (..)
   , commandParseArgs
+  , mkCommandUI
   )
 import Distribution.Simple.Flag (fromFlagOrDefault)
 import qualified Distribution.Verbosity as Verbosity
 import System.Environment (getArgs)
+import qualified System.FilePath as FP
+import Control.Exception (throwIO, Exception (displayException))
+import Security.Advisories.Filesystem (listAdvisories)
+import Validation (validation)
+import Security.Advisories (ParseAdvisoryError)
+import GHC.Generics (Generic)
+import Security.Advisories.Cabal (matchAdvisoriesForPlan)
+
+data AuditException 
+  = MissingArgs  
+  | TooManyArgs
+  | InvalidFilePath String
+  | ListAdvisoryValidationError FilePath [ParseAdvisoryError]
+  deriving stock (Eq, Show, Generic)
+
+instance Exception AuditException where
+ displayException = \case 
+   MissingArgs -> "You didn't specify where to take the audit results from"
+   TooManyArgs -> "Expected only one argument"
+   InvalidFilePath fp -> show fp <> " is not a valid filepath"
+   ListAdvisoryValidationError dir errs -> unlines 
+     [ "Listing the advisories in directory " <> dir <> " failed with:"
+     , show errs
+     ]
 
 auditMain :: IO ()
 auditMain =
-  handleArgs auditCommandUI \flags -> do
+  handleArgs auditCommandUI \args flags -> do
     let verbosity = verbosityFromFlags flags
         cliConfig = projectConfigFromFlags flags
     ProjectBaseContext {distDirLayout, cabalDirLayout, projectConfig, localPackages} <-
       establishProjectBaseContext
         verbosity
         cliConfig
         OtherCommand
-    (_, plan, _, _, _) <-
+    (plan', plan, _, _, _) <-
       rebuildInstallPlan verbosity distDirLayout cabalDirLayout projectConfig localPackages Nothing
-    print `traverse_` Plan.toList plan
+
+    fp <- case args of 
+      [] -> throwIO MissingArgs
+      [fp] -> if FP.isValid fp then pure fp else throwIO (InvalidFilePath fp) 
+      (_x : _y : _zs) -> throwIO TooManyArgs
+    advisories <- listAdvisories fp 
+      >>= validation (throwIO . ListAdvisoryValidationError fp) pure
+
+    print $ matchAdvisoriesForPlan plan advisories
+    print $ matchAdvisoriesForPlan plan' advisories
+    -- TODO(mangoiv): find out what's the correct plan
 
 projectConfigFromFlags :: NixStyleFlags a -> ProjectConfig
 projectConfigFromFlags flags = commandLineFlagsToProjectConfig defaultGlobalFlags flags mempty
@@ -53,25 +87,22 @@ verbosityFromFlags = fromFlagOrDefault Verbosity.normal . configVerbosity . conf
 
 auditCommandUI :: CommandUI (NixStyleFlags ())
 auditCommandUI =
-  CommandUI
-    { commandName = "cabal-audit"
-    , commandSynopsis = "Audits your cabal project"
-    , commandUsage = ("Usage: " ++)
-    , commandDescription = Nothing
-    , commandNotes = Nothing
-    , commandDefaultFlags = defaultNixStyleFlags ()
-    , commandOptions = nixStyleOptions (const [])
-    }
+  mkCommandUI
+    "audit"
+    "Audits your cabal project"
+    ["<hsec-advisory-directory>"]
+    do defaultNixStyleFlags ()
+    do nixStyleOptions (const [])
 
 -- | handle cabal global command args
 handleArgs
   :: CommandUI flags
-  -> (flags -> IO ())
+  -> ([String] -> flags -> IO ())
   -> IO ()
 handleArgs ui k = do
   args <- getArgs
-  case commandParseArgs ui True args of
-    CommandHelp help -> putStrLn $ help "cabal-audit"
-    CommandList opts -> putStrLn $ "commandList: " <> show opts
-    CommandErrors errs -> putStrLn $ "commandErrors: " <> show errs
-    CommandReadyToGo (flags, _commandParse) -> k $ flags $ commandDefaultFlags ui
+  case commandParseArgs ui False args of
+    CommandHelp help -> putStrLn $ help "cabal"
+    CommandList opts -> putStrLn `traverse_` opts
+    CommandErrors errs -> putStrLn `traverse_` errs
+    CommandReadyToGo (flags, commandParse) -> k commandParse $ flags $ commandDefaultFlags ui

code/hsec-cabal/src/Security/Advisories/Cabal.hs

@@ -1,4 +1,90 @@
-module Security.Advisories.Cabal where
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE UndecidableInstances #-}
 
+module Security.Advisories.Cabal (matchAdvisoriesForPlan) where
 
+import Data.Functor.Identity (Identity (Identity))
+import Data.Kind (Type)
+import Data.Map (Map, (!?))
+import Data.Map.Strict qualified as Map
+import Data.Maybe (mapMaybe)
+import Data.Monoid (Any (Any, getAny))
+import Data.Proxy (Proxy (Proxy))
+import Data.Text qualified as T
+import Distribution.Client.InstallPlan (foldPlanPackage)
+import Distribution.Client.InstallPlan qualified as Plan
+import Distribution.Client.ProjectPlanning (ElaboratedInstallPlan, elabPkgSourceId)
+import Distribution.InstalledPackageInfo (sourcePackageId)
+import Distribution.Package (PackageIdentifier (PackageIdentifier, pkgName, pkgVersion), PackageName, mkPackageName)
+import Distribution.Version (Version)
+import GHC.Generics (Generic)
+import Security.Advisories (Advisory (advisoryAffected), Affected (Affected, affectedPackage, affectedVersions), AffectedVersionRange (affectedVersionRangeIntroduced))
 
+-- | for a given 'ElaboratedInstallPlan' and a list of advisories, construct a map of advisories
+--   and packages within the install plan that are affected by them
+matchAdvisoriesForPlan
+  :: ElaboratedInstallPlan
+  -- ^ the plan as created by cabal
+  -> [Advisory]
+  -- ^ the advisories as discovered in some advisory dir
+  -> Map PackageName ElaboratedPackageInfoAdvised
+matchAdvisoriesForPlan plan = foldr advise Map.empty
+ where
+  advise :: Advisory -> Map PackageName ElaboratedPackageInfoAdvised -> Map PackageName ElaboratedPackageInfoAdvised
+  advise adv = do
+    let versionAffected :: Version -> [AffectedVersionRange] -> Bool
+        versionAffected v = getAny . foldMap (Any . (== v) . affectedVersionRangeIntroduced)
+
+        advPkgs :: [(PackageName, ElaboratedPackageInfoAdvised)]
+        advPkgs = flip mapMaybe (advisoryAffected adv) \Affected {affectedPackage, affectedVersions} -> do
+          let pkgn = mkPackageName (T.unpack affectedPackage)
+          MkElaboratedPackageInfoWith {elaboratedPackageVersion = elabv} <- installPlanToLookupTable plan !? pkgn
+          if versionAffected elabv affectedVersions
+            then Just (pkgn, MkElaboratedPackageInfoWith {elaboratedPackageVersion = elabv, packageAdvisories = Identity [adv]})
+            else Nothing
+
+    flip
+      do foldr . uncurry $ Map.insertWith combinedElaboratedPackageInfos
+      advPkgs
+
+  combinedElaboratedPackageInfos
+    MkElaboratedPackageInfoWith {elaboratedPackageVersion = ver1, packageAdvisories = advs1}
+    MkElaboratedPackageInfoWith {packageAdvisories = advs2} =
+      MkElaboratedPackageInfoWith {elaboratedPackageVersion = ver1, packageAdvisories = advs1 <> advs2}
+
+type ElaboratedPackageInfoAdvised = ElaboratedPackageInfoWith Identity
+
+type ElaboratedPackageInfo = ElaboratedPackageInfoWith Proxy
+
+-- | information about the elaborated package that
+--   is to be looked up that we want to add  to the
+--   information displayed in the advisory
+type ElaboratedPackageInfoWith :: (Type -> Type) -> Type
+data ElaboratedPackageInfoWith f = MkElaboratedPackageInfoWith
+  { elaboratedPackageVersion :: Version
+  -- ^ the version of the package that is installed
+  , packageAdvisories :: f [Advisory]
+  }
+  deriving stock (Generic)
+
+deriving stock instance Eq (f [Advisory]) => (Eq (ElaboratedPackageInfoWith f))
+
+deriving stock instance Ord (f [Advisory]) => (Ord (ElaboratedPackageInfoWith f))
+
+deriving stock instance Show (f [Advisory]) => (Show (ElaboratedPackageInfoWith f))
+
+--   FUTUREWORK(mangoiv): this could probably be done more intelligent by also
+--   looking up via the version range but I don't know exacty how
+
+-- | 'Map' to lookup the package name in the install plan that returns information
+--   about the package
+installPlanToLookupTable :: ElaboratedInstallPlan -> Map PackageName ElaboratedPackageInfo
+installPlanToLookupTable = Map.fromList . fmap planPkgToPackageInfo . Plan.toList
+ where
+  planPkgToPackageInfo pkg = do
+    let (PackageIdentifier {pkgName, pkgVersion}) =
+          foldPlanPackage
+            sourcePackageId
+            elabPkgSourceId
+            pkg
+    (pkgName, MkElaboratedPackageInfoWith {elaboratedPackageVersion = pkgVersion, packageAdvisories = Proxy})

code/hsec-cabal/test/assets/test-cabal-project/cabal.project

@@ -0,0 +1,4 @@
+packages:
+    ./test-a
+index-state: hackage.haskell.org 2023-01-01T00:00:00Z
+active-repositories: hackage.haskell.org

code/hsec-cabal/test/assets/test-cabal-project/cabal.project.local

@@ -0,0 +1,2 @@
+sysconfdir: .
+ignore-project: False

code/hsec-cabal/test/assets/test-cabal-project/flake.nix

@@ -0,0 +1,27 @@
+{
+  nixConfig.allow-import-from-derivation = true;
+  inputs = {
+    nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
+    parts.url = "github:hercules-ci/flake-parts";
+    haskell-flake.url = "github:srid/haskell-flake";
+  };
+  outputs = inputs:
+    inputs.parts.lib.mkFlake { inherit inputs; } {
+      systems = [ "x86_64-linux" ];
+      imports = [
+        inputs.haskell-flake.flakeModule
+      ];
+
+      perSystem =
+        {
+          haskellProjects.default = {
+            defaults.devShell.tools = ps: { inherit (ps) cabal-install; };
+            packages = {
+              toml-reader.source = "0.1.0.0";
+              megaparsec.source = "9.2.0";
+            };
+            settings = { };
+          };
+        };
+    };
+}

code/hsec-cabal/test/assets/test-a/test-a.cabal → code/hsec-cabal/test/assets/test-cabal-project/test-a/test-a.cabal

@@ -3,8 +3,8 @@ name:            test-a
 version:         0.1.0.0
 license:         MIT
 license-file:    LICENSE
-author:          mangoiv
-maintainer:      mail@mangoiv.com
+author:          mustermann
+maintainer:      mustermann@example.com
 category:        Codec
 build-type:      Simple
 extra-doc-files: CHANGELOG.md
@@ -19,7 +19,7 @@ library
   -- hakyll depends on pandoc which has a security report
   build-depends:
     , base
-    , hakyll
+    , toml-reader  ==0.1.0.0
 
   hs-source-dirs:   src
   default-language: Haskell2010