From 4591de759ef2e2b6c7be70028863d628a8ff7c44 Mon Sep 17 00:00:00 2001 From: mangoiv Date: Tue, 13 Feb 2024 00:47:47 +0100 Subject: [PATCH] [wip] add part of the implementation of looking up advisories in the DB --- code/hsec-cabal/hsec-cabal.cabal | 15 +++- code/hsec-cabal/src/Distribution/Audit.hs | 67 +++++++++++---- .../src/Security/Advisories/Cabal.hs | 84 ++++++++++++++++++- .../test/assets/test-a/test-a.cabal | 4 +- flake.lock | 6 +- 5 files changed, 151 insertions(+), 25 deletions(-) diff --git a/code/hsec-cabal/hsec-cabal.cabal b/code/hsec-cabal/hsec-cabal.cabal index ae492df4..6dbe9f02 100644 --- a/code/hsec-cabal/hsec-cabal.cabal +++ b/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 diff --git a/code/hsec-cabal/src/Distribution/Audit.hs b/code/hsec-cabal/src/Distribution/Audit.hs index 5a7c410b..8e826fd5 100644 --- a/code/hsec-cabal/src/Distribution/Audit.hs +++ b/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" + [""] + 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 diff --git a/code/hsec-cabal/src/Security/Advisories/Cabal.hs b/code/hsec-cabal/src/Security/Advisories/Cabal.hs index 23de1a0f..aba3bd6c 100644 --- a/code/hsec-cabal/src/Security/Advisories/Cabal.hs +++ b/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}) diff --git a/code/hsec-cabal/test/assets/test-a/test-a.cabal b/code/hsec-cabal/test/assets/test-a/test-a.cabal index 6e6ea329..58fb9d8f 100644 --- a/code/hsec-cabal/test/assets/test-a/test-a.cabal +++ b/code/hsec-cabal/test/assets/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 diff --git a/flake.lock b/flake.lock index ef2fe8d7..d378e273 100644 --- a/flake.lock +++ b/flake.lock @@ -72,11 +72,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1707205916, - "narHash": "sha256-fmRJilYGlB7VCt3XsdYxrA0u8e/K84O5xYucerUY0iM=", + "lastModified": 1707907779, + "narHash": "sha256-dtktfFJn+36yBkZ1mnQGdiDsqnzC9pXt/Ecpsui0hiY=", "owner": "nixos", "repo": "nixpkgs", - "rev": "8cc79aa39bbc6eaedaf286ae655b224c71e02907", + "rev": "c5e9528855e4e6feda2b16dec28de880ce774b93", "type": "github" }, "original": {