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/hsec-tools.cabal b/code/hsec-tools/hsec-tools.cabal index e6edad22..50431575 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: diff --git a/code/hsec-tools/src/Security/Advisories/Filesystem.hs b/code/hsec-tools/src/Security/Advisories/Filesystem.hs index 48757d0a..b4fabb76 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,12 @@ 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)) dirNameAdvisories :: FilePath @@ -129,18 +126,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 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/Parse.hs b/code/hsec-tools/src/Security/Advisories/Parse.hs index 8302a34d..aed6b108 100644 --- a/code/hsec-tools/src/Security/Advisories/Parse.hs +++ b/code/hsec-tools/src/Security/Advisories/Parse.hs @@ -9,7 +9,6 @@ module Security.Advisories.Parse ( parseAdvisory , OutOfBandAttributes(..) - , emptyOutOfBandAttributes , AttributeOverridePolicy(..) , ParseAdvisoryError(..) ) @@ -49,6 +48,7 @@ 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) -- | A source of attributes supplied out of band from the advisory -- content. Values provided out of band are treated according to @@ -59,17 +59,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 @@ -96,7 +90,7 @@ instance Exception ParseAdvisoryError where -- parseAdvisory :: AttributeOverridePolicy - -> OutOfBandAttributes + -> Either GitError OutOfBandAttributes -> T.Text -- ^ input (CommonMark with TOML header) -> Either ParseAdvisoryError Advisory parseAdvisory policy attrs raw = do @@ -156,7 +150,7 @@ parseAdvisory policy attrs raw = do mkPretty ctr pretty x = ctr x $ pretty x parseAdvisoryTable - :: OutOfBandAttributes + :: Either GitError OutOfBandAttributes -> AttributeOverridePolicy -> Pandoc -- ^ parsed document (without frontmatter) -> T.Text -- ^ summary @@ -169,13 +163,13 @@ parseAdvisoryTable oob policy doc summary details html tab = do fm <- Toml.fromValue (Toml.Table' Toml.startPos tab) published <- mergeOobMandatory policy - (oobPublished oob) + (oobPublished <$> oob) "advisory.date" (amdPublished (frontMatterAdvisory fm)) modified <- fromMaybe published <$> mergeOobOptional policy - (oobPublished oob) + (oobPublished <$> oob) "advisory.modified" (amdModified (frontMatterAdvisory fm)) pure Advisory @@ -531,41 +525,43 @@ 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 GitError a -- ^ 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 k ib = + mergeOob policy eoob k ib everythingFailed pure + where + everythingFailed e = fail ("missing mandatory key: " <> k <> "\nwith git error:\n" <> explainGitError 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