[wip] 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,14 +25,39 @@ 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} <-
@@ -43,7 +67,17 @@ auditMain =
         OtherCommand
     (_, 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
+
+    planAdvisories <- print $ matchAdvisoriesForPlan plan advisories
+
+    pure ()
 
 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,86 @@
-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.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)
+import Data.Maybe (mapMaybe)
 
+-- | 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 = undefined
+
+        advPkgs :: [ElaboratedPackageInfoAdvised]
+        advPkgs = flip mapMaybe (advisoryAffected adv) \Affected {affectedPackage, affectedVersions} -> do
+          MkElaboratedPackageInfoWith {elaboratedPackageVersion = elabv} <- planTable !? mkPackageName (T.unpack affectedPackage)
+          if versionAffected elabv affectedVersions 
+            then Just (MkElaboratedPackageInfoWith {elaboratedPackageVersion = elabv, packageAdvisories = Identity [adv]})
+            else Nothing
+
+    Map.insertWith _ _ _
+
+  combinedElaboratedPackageInfos MkElaboratedPackageInfoWith {elaboratedPackageVersion = ver1, packageAdvisories = advs1} advs2 =
+    MkElaboratedPackageInfoWith {elaboratedPackageVersion = ver1, packageAdvisories = advs1 <> advs2}
+
+  planTable = installPlanToLookupTable plan
+
+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})