[feat] bubble up git errors

- OutOfBandAttributes now have two mandatory fields - the git error is bubbled up until it can be handled in validation
haskell · May 31, 2024 · fbb65f6 · fbb65f6
1 parent fe0ca8d
commit fbb65f6
Show file tree

Hide file tree

Showing 5 changed files with 43 additions and 51 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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