From c1703e8cdb1b78a8692921a74a0584b66bef917e Mon Sep 17 00:00:00 2001 From: mangoiv Date: Fri, 31 May 2024 21:02:32 +0200 Subject: [PATCH] [feat] bubble up git errors - OutOfBandAttributes now have two mandatory fields - the git error is bubbled up until it can be handled in validation --- cabal.project | 2 + code/hsec-tools/app/Main.hs | 22 ++--- code/hsec-tools/hsec-tools.cabal | 3 +- .../src/Security/Advisories/Filesystem.hs | 34 ++++---- .../hsec-tools/src/Security/Advisories/Git.hs | 3 +- .../src/Security/Advisories/Parse.hs | 83 ++++++++++++------- code/hsec-tools/test/Spec.hs | 13 ++- 7 files changed, 91 insertions(+), 69 deletions(-) diff --git a/cabal.project b/cabal.project index 3f2ec970..36ba4583 100644 --- a/cabal.project +++ b/cabal.project @@ -4,3 +4,5 @@ package hsec-core package hsec-tools package cvss package osv + +test-show-details: direct diff --git a/code/hsec-tools/app/Main.hs b/code/hsec-tools/app/Main.hs index f5077f68..620454f3 100644 --- a/code/hsec-tools/app/Main.hs +++ b/code/hsec-tools/app/Main.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} module Main where import Control.Monad (forM_, join, void, when) +import Control.Monad.Trans.Except (runExceptT, ExceptT (ExceptT), withExceptT, throwE) +import Control.Monad.IO.Class (liftIO) 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) @@ -154,15 +155,14 @@ 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) - } + oob <- runExceptT case file of + Nothing -> throwE StdInHasNoOOB + Just path -> withExceptT GitHasNoOOB do + gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo path + pure OutOfBandAttributes + { oobPublished = firstAppearanceCommitDate gitInfo + , oobModified = lastModificationCommitDate gitInfo + } case parseAdvisory NoOverrides oob input of Left e -> do diff --git a/code/hsec-tools/hsec-tools.cabal b/code/hsec-tools/hsec-tools.cabal index e6edad22..4097bb8c 100644 --- a/code/hsec-tools/hsec-tools.cabal +++ b/code/hsec-tools/hsec-tools.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hsec-tools -version: 0.1.1.0 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: @@ -90,6 +90,7 @@ executable hsec-tools , hsec-tools , optparse-applicative >=0.17 && <0.19 , text >=1.2 && <3 + , transformers , validation-selective >=0.1 && <1 hs-source-dirs: app diff --git a/code/hsec-tools/src/Security/Advisories/Filesystem.hs b/code/hsec-tools/src/Security/Advisories/Filesystem.hs index 48757d0a..d97e9b0a 100644 --- a/code/hsec-tools/src/Security/Advisories/Filesystem.hs +++ b/code/hsec-tools/src/Security/Advisories/Filesystem.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE LambdaCase #-} - +{-# LANGUAGE BlockArguments #-} {-| Helpers for the /security-advisories/ file system. @@ -25,9 +24,7 @@ module Security.Advisories.Filesystem ) 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) @@ -37,12 +34,13 @@ 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 Validation (Validation (..)) -import Security.Advisories (Advisory, AttributeOverridePolicy (NoOverrides), OutOfBandAttributes (..), ParseAdvisoryError, emptyOutOfBandAttributes, parseAdvisory) +import Security.Advisories (Advisory, AttributeOverridePolicy (NoOverrides), OutOfBandAttributes (..), ParseAdvisoryError, parseAdvisory) import Security.Advisories.Core.HsecId (HsecId, parseHsecId, placeholder) -import Security.Advisories.Git(firstAppearanceCommitDate, getAdvisoryGitInfo, lastModificationCommitDate, explainGitError) -import System.IO (stderr, hPutStrLn) +import Security.Advisories.Git(firstAppearanceCommitDate, getAdvisoryGitInfo, lastModificationCommitDate) +import Control.Monad.Except (runExceptT, ExceptT (ExceptT), withExceptT) +import Security.Advisories.Parse (OOBError(GitHasNoOOB)) dirNameAdvisories :: FilePath @@ -129,18 +127,16 @@ listAdvisories root = if isSym then return $ pure [] else do - oob <- - liftIO (getAdvisoryGitInfo advisoryPath) >>= \case - Left gitErr -> - liftIO (hPutStrLn stderr ("obtaining out of band attributes failed: \n" <> explainGitError gitErr)) - $> emptyOutOfBandAttributes - Right gitInfo -> - pure emptyOutOfBandAttributes - { oobPublished = Just (firstAppearanceCommitDate gitInfo), - oobModified = Just (lastModificationCommitDate gitInfo) - } + oob <- runExceptT $ withExceptT GitHasNoOOB do + gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo advisoryPath + pure OutOfBandAttributes + { oobPublished = firstAppearanceCommitDate gitInfo + , oobModified = lastModificationCommitDate gitInfo + } fileContent <- liftIO $ T.readFile advisoryPath - return $ eitherToValidation $ bimap return return $ parseAdvisory NoOverrides oob fileContent + pure + $ either (Failure . (: [])) (Success . (: [])) + $ parseAdvisory NoOverrides oob fileContent -- | Get names (not paths) of subdirectories of the given directory -- (one level). There's no monoidal, interruptible variant of diff --git a/code/hsec-tools/src/Security/Advisories/Git.hs b/code/hsec-tools/src/Security/Advisories/Git.hs index a6e9c908..2ee937b5 100644 --- a/code/hsec-tools/src/Security/Advisories/Git.hs +++ b/code/hsec-tools/src/Security/Advisories/Git.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingStrategies #-} {-| @@ -33,7 +34,7 @@ data AdvisoryGitInfo = AdvisoryGitInfo data GitError = GitProcessError ExitCode String String -- ^ exit code, stdout and stderr | GitTimeParseError String -- ^ unable to parse this input as a datetime - deriving (Show) + deriving stock (Eq, Ord, Show) explainGitError :: GitError -> String explainGitError = \case diff --git a/code/hsec-tools/src/Security/Advisories/Parse.hs b/code/hsec-tools/src/Security/Advisories/Parse.hs index 8302a34d..8dc59d97 100644 --- a/code/hsec-tools/src/Security/Advisories/Parse.hs +++ b/code/hsec-tools/src/Security/Advisories/Parse.hs @@ -2,14 +2,16 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE LambdaCase #-} module Security.Advisories.Parse ( parseAdvisory + , OOB + , OOBError (..) , OutOfBandAttributes(..) - , emptyOutOfBandAttributes + , displayOOBError , AttributeOverridePolicy(..) , ParseAdvisoryError(..) ) @@ -49,6 +51,12 @@ import Security.Advisories.Core.Advisory import Security.OSV (Reference(..), ReferenceType, referenceTypes) import qualified Security.CVSS as CVSS import Control.Exception (Exception(displayException)) +import Security.Advisories.Git (GitError, explainGitError) + +-- | if there are no out of band attributes, attach a reason why that's the case +-- +-- @since 0.2.0.0 +type OOB = Either OOBError OutOfBandAttributes -- | A source of attributes supplied out of band from the advisory -- content. Values provided out of band are treated according to @@ -59,17 +67,11 @@ import Control.Exception (Exception(displayException)) -- set particular fields. -- data OutOfBandAttributes = OutOfBandAttributes - { oobModified :: Maybe ZonedTime - , oobPublished :: Maybe ZonedTime + { oobModified :: ZonedTime + , oobPublished :: ZonedTime } deriving (Show) -emptyOutOfBandAttributes :: OutOfBandAttributes -emptyOutOfBandAttributes = OutOfBandAttributes - { oobModified = Nothing - , oobPublished = Nothing - } - data AttributeOverridePolicy = PreferInBand | PreferOutOfBand @@ -83,20 +85,34 @@ data ParseAdvisoryError | AdvisoryError [Toml.MatchMessage Toml.Position] T.Text deriving stock (Eq, Show, Generic) --- | @since 0.1.1.0 +-- | @since 0.2.0.0 instance Exception ParseAdvisoryError where displayException = T.unpack . \case - MarkdownError _ explanation -> "Markdown parsing error:\n\t" <> explanation - MarkdownFormatError explanation -> "Markdown structure error:\n\t" <> explanation - TomlError _ explanation -> "Couldn't parse front matter as TOML:\n\t" <> explanation - AdvisoryError _ explanation -> "Advisory structure error:\n\t" <> explanation + 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 + +-- | errors that may occur while ingesting oob data +-- +-- @since 0.2.0.0 +data OOBError + = StdInHasNoOOB -- ^ we obtain the advisory via stdin and can hence not parse git history + | GitHasNoOOB GitError -- ^ processing oob info via git failed + deriving stock (Eq, Show, Generic) + +displayOOBError :: OOBError -> String +displayOOBError = \case + StdInHasNoOOB -> "stdin doesn't provide out of band information" + GitHasNoOOB gitErr -> "no out of band information obtained with git error:\n" + <> explainGitError gitErr -- | The main parsing function. 'OutOfBandAttributes' are handled -- according to the 'AttributeOverridePolicy'. -- parseAdvisory :: AttributeOverridePolicy - -> OutOfBandAttributes + -> OOB -> T.Text -- ^ input (CommonMark with TOML header) -> Either ParseAdvisoryError Advisory parseAdvisory policy attrs raw = do @@ -156,7 +172,7 @@ parseAdvisory policy attrs raw = do mkPretty ctr pretty x = ctr x $ pretty x parseAdvisoryTable - :: OutOfBandAttributes + :: OOB -> AttributeOverridePolicy -> Pandoc -- ^ parsed document (without frontmatter) -> T.Text -- ^ summary @@ -169,13 +185,14 @@ parseAdvisoryTable oob policy doc summary details html tab = do fm <- Toml.fromValue (Toml.Table' Toml.startPos tab) published <- mergeOobMandatory policy - (oobPublished oob) + (oobPublished <$> oob) + displayOOBError "advisory.date" (amdPublished (frontMatterAdvisory fm)) modified <- fromMaybe published <$> mergeOobOptional policy - (oobPublished oob) + (oobPublished <$> oob) "advisory.modified" (amdModified (frontMatterAdvisory fm)) pure Advisory @@ -531,41 +548,47 @@ instance Toml.ToValue CVSS.CVSS where mergeOob :: MonadFail m => AttributeOverridePolicy - -> Maybe a -- ^ out-of-band value + -> Either e a -- ^ out-of-band value -> String -- ^ key -> Maybe a -- ^ in-band-value - -> m b -- ^ when key and out-of-band value absent + -> (e -> 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 + (Right 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 + (Right a, Nothing) -> present a + (Left _, Just a) -> present a + (Left e, Nothing) -> absent e mergeOobOptional :: MonadFail m => AttributeOverridePolicy - -> Maybe a -- ^ out-of-band value + -> Either e 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) + mergeOob policy oob k ib (const $ pure Nothing) (pure . Just) mergeOobMandatory :: MonadFail m => AttributeOverridePolicy - -> Maybe a -- ^ out-of-band value + -> Either e a -- ^ out-of-band value + -> (e -> String) -- ^ how to display information about a missing 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 +mergeOobMandatory policy eoob doob k ib = + mergeOob policy eoob k ib everythingFailed pure + where + everythingFailed e = fail $ unlines + [ "while trying to lookup mandatory key " <> show k <> ":" + , doob e + ] -- | A solution to an awkward problem: how to delete the TOML -- block. We parse into this type to get the source range of diff --git a/code/hsec-tools/test/Spec.hs b/code/hsec-tools/test/Spec.hs index d8981c2b..b3631e25 100644 --- a/code/hsec-tools/test/Spec.hs +++ b/code/hsec-tools/test/Spec.hs @@ -10,7 +10,7 @@ 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 (defaultMain, testGroup, TestTree) import Test.Tasty.Golden (goldenVsString) import Text.Pretty.Simple (pShowNoColor) @@ -42,12 +42,11 @@ doGoldenTest fp = goldenVsString fp (fp <> ".golden") (LText.encodeUtf8 <$> doCh 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 + attr = OutOfBandAttributes + { oobPublished = fakeDate + , oobModified = fakeDate + } + res = parseAdvisory NoOverrides (Right attr) input osvExport = case res of Right adv -> let osv = OSV.convert adv