[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

@@ -4,3 +4,5 @@ package hsec-core
 package hsec-tools
 package cvss
 package osv
+
+test-show-details: direct

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

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

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

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

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

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