From 4b3059ea6b47acdae6485ceaea1dd8eebb54cf37 Mon Sep 17 00:00:00 2001 From: mangoiv Date: Fri, 31 May 2024 17:52:16 +0200 Subject: [PATCH 1/6] [fix] some minor fixes - introduce Exception instance for ParseAdvisoryError - display if parsing out of band git attributes failed --- code/hsec-tools/app/Main.hs | 8 ++------ code/hsec-tools/hsec-tools.cabal | 2 +- .../src/Security/Advisories/Filesystem.hs | 13 ++++++++----- code/hsec-tools/src/Security/Advisories/Parse.hs | 11 +++++++++++ 4 files changed, 22 insertions(+), 12 deletions(-) diff --git a/code/hsec-tools/app/Main.hs b/code/hsec-tools/app/Main.hs index 0f04f354..f5077f68 100644 --- a/code/hsec-tools/app/Main.hs +++ b/code/hsec-tools/app/Main.hs @@ -19,6 +19,7 @@ import Validation (Validation(..)) import qualified Data.Aeson import qualified Data.Text as T import qualified Data.Text.IO as T +import Control.Exception (Exception(displayException)) import Options.Applicative import Security.Advisories @@ -165,12 +166,7 @@ withAdvisory go file = do case parseAdvisory NoOverrides oob input of Left e -> do - T.hPutStrLn stderr $ - case e of - 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 + hPutStrLn stderr (displayException e) exitFailure Right advisory -> do go file advisory diff --git a/code/hsec-tools/hsec-tools.cabal b/code/hsec-tools/hsec-tools.cabal index fede7e80..e6edad22 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.0.0 +version: 0.1.1.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 f3877a5c..48757d0a 100644 --- a/code/hsec-tools/src/Security/Advisories/Filesystem.hs +++ b/code/hsec-tools/src/Security/Advisories/Filesystem.hs @@ -27,7 +27,7 @@ module Security.Advisories.Filesystem import Control.Applicative (liftA2) import Data.Bifunctor (bimap) import Data.Foldable (fold) -import Data.Functor ((<&>)) +import Data.Functor (($>)) import Data.Semigroup (Max(Max, getMax)) import Data.Traversable (for) @@ -41,7 +41,8 @@ import Validation (Validation, eitherToValidation) import Security.Advisories (Advisory, AttributeOverridePolicy (NoOverrides), OutOfBandAttributes (..), ParseAdvisoryError, emptyOutOfBandAttributes, parseAdvisory) import Security.Advisories.Core.HsecId (HsecId, parseHsecId, placeholder) -import Security.Advisories.Git(firstAppearanceCommitDate, getAdvisoryGitInfo, lastModificationCommitDate) +import Security.Advisories.Git(firstAppearanceCommitDate, getAdvisoryGitInfo, lastModificationCommitDate, explainGitError) +import System.IO (stderr, hPutStrLn) dirNameAdvisories :: FilePath @@ -129,10 +130,12 @@ listAdvisories root = then return $ pure [] else do oob <- - liftIO (getAdvisoryGitInfo advisoryPath) <&> \case - Left _ -> emptyOutOfBandAttributes + liftIO (getAdvisoryGitInfo advisoryPath) >>= \case + Left gitErr -> + liftIO (hPutStrLn stderr ("obtaining out of band attributes failed: \n" <> explainGitError gitErr)) + $> emptyOutOfBandAttributes Right gitInfo -> - emptyOutOfBandAttributes + pure emptyOutOfBandAttributes { oobPublished = Just (firstAppearanceCommitDate gitInfo), oobModified = Just (lastModificationCommitDate gitInfo) } diff --git a/code/hsec-tools/src/Security/Advisories/Parse.hs b/code/hsec-tools/src/Security/Advisories/Parse.hs index f6de248f..8302a34d 100644 --- a/code/hsec-tools/src/Security/Advisories/Parse.hs +++ b/code/hsec-tools/src/Security/Advisories/Parse.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE LambdaCase #-} module Security.Advisories.Parse ( parseAdvisory , OutOfBandAttributes(..) @@ -47,6 +48,8 @@ import Security.Advisories.Core.HsecId import Security.Advisories.Core.Advisory import Security.OSV (Reference(..), ReferenceType, referenceTypes) import qualified Security.CVSS as CVSS +import Control.Exception (Exception(displayException)) + -- | A source of attributes supplied out of band from the advisory -- content. Values provided out of band are treated according to -- the 'AttributeOverridePolicy'. @@ -80,6 +83,14 @@ data ParseAdvisoryError | AdvisoryError [Toml.MatchMessage Toml.Position] T.Text deriving stock (Eq, Show, Generic) +-- | @since 0.1.1.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 + -- | The main parsing function. 'OutOfBandAttributes' are handled -- according to the 'AttributeOverridePolicy'. -- From fe0ca8de0ebab2d83c9eb2cb9c8349fa42b820be Mon Sep 17 00:00:00 2001 From: mangoiv Date: Fri, 31 May 2024 18:44:44 +0200 Subject: [PATCH 2/6] [fix] also try parsing UTC with defaulted time zone from git --- code/hsec-tools/src/Security/Advisories/Git.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/code/hsec-tools/src/Security/Advisories/Git.hs b/code/hsec-tools/src/Security/Advisories/Git.hs index 8d9bd969..a6e9c908 100644 --- a/code/hsec-tools/src/Security/Advisories/Git.hs +++ b/code/hsec-tools/src/Security/Advisories/Git.hs @@ -18,11 +18,12 @@ module Security.Advisories.Git import Data.Char (isSpace) import Data.List (dropWhileEnd) -import Data.Time (ZonedTime) +import Data.Time (ZonedTime, utcToZonedTime, utc) import Data.Time.Format.ISO8601 (iso8601ParseM) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath (splitFileName) import System.Process (readProcessWithExitCode) +import Control.Applicative ((<|>)) data AdvisoryGitInfo = AdvisoryGitInfo { firstAppearanceCommitDate :: ZonedTime @@ -117,4 +118,7 @@ getAdvisoryGitInfo path = do -- the same as `ExitFailure` pure . Left $ GitProcessError status stdout stderr where - parseTime s = maybe (Left $ GitTimeParseError s) Right $ iso8601ParseM s + parseTime :: String -> Either GitError ZonedTime + parseTime s = maybe (Left $ GitTimeParseError s) Right $ + iso8601ParseM s + <|> utcToZonedTime utc <$> iso8601ParseM s From c1703e8cdb1b78a8692921a74a0584b66bef917e Mon Sep 17 00:00:00 2001 From: mangoiv Date: Fri, 31 May 2024 21:02:32 +0200 Subject: [PATCH 3/6] [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 From d8d8e4417736b3930a2308e28d8bbe0c7f562b6e Mon Sep 17 00:00:00 2001 From: mangoiv Date: Fri, 7 Jun 2024 17:25:04 +0200 Subject: [PATCH 4/6] [chore] add back dollars --- code/hsec-tools/app/Main.hs | 5 ++--- code/hsec-tools/src/Security/Advisories/Filesystem.hs | 3 +-- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/code/hsec-tools/app/Main.hs b/code/hsec-tools/app/Main.hs index 620454f3..09890b7f 100644 --- a/code/hsec-tools/app/Main.hs +++ b/code/hsec-tools/app/Main.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BlockArguments #-} module Main where @@ -155,9 +154,9 @@ withAdvisory :: (Maybe FilePath -> Advisory -> IO ()) -> Maybe FilePath -> IO () withAdvisory go file = do input <- maybe T.getContents T.readFile file - oob <- runExceptT case file of + oob <- runExceptT $ case file of Nothing -> throwE StdInHasNoOOB - Just path -> withExceptT GitHasNoOOB do + Just path -> withExceptT GitHasNoOOB $ do gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo path pure OutOfBandAttributes { oobPublished = firstAppearanceCommitDate gitInfo diff --git a/code/hsec-tools/src/Security/Advisories/Filesystem.hs b/code/hsec-tools/src/Security/Advisories/Filesystem.hs index d97e9b0a..17b84ae4 100644 --- a/code/hsec-tools/src/Security/Advisories/Filesystem.hs +++ b/code/hsec-tools/src/Security/Advisories/Filesystem.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-| Helpers for the /security-advisories/ file system. @@ -127,7 +126,7 @@ listAdvisories root = if isSym then return $ pure [] else do - oob <- runExceptT $ withExceptT GitHasNoOOB do + oob <- runExceptT $ withExceptT GitHasNoOOB $ do gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo advisoryPath pure OutOfBandAttributes { oobPublished = firstAppearanceCommitDate gitInfo From 75850bc988c8039d2ba9570bf385528feb1456f9 Mon Sep 17 00:00:00 2001 From: mangoiv Date: Sun, 9 Jun 2024 18:20:59 +0200 Subject: [PATCH 5/6] [chore] replace all uses of ZonedTime with UTCTime --- .../src/Security/Advisories/Core/Advisory.hs | 8 ++++---- code/hsec-tools/hsec-tools.cabal | 2 +- .../src/Security/Advisories/Convert/OSV.hs | 5 ++--- .../src/Security/Advisories/Generate/HTML.hs | 6 +++--- .../hsec-tools/src/Security/Advisories/Git.hs | 10 +++++----- .../src/Security/Advisories/Parse.hs | 18 ++++++++--------- code/hsec-tools/test/Spec.hs | 4 ++-- flake.lock | 20 +------------------ flake.nix | 8 ++------ 9 files changed, 29 insertions(+), 52 deletions(-) diff --git a/code/hsec-core/src/Security/Advisories/Core/Advisory.hs b/code/hsec-core/src/Security/Advisories/Core/Advisory.hs index c2a4d3c7..6fe18ea9 100644 --- a/code/hsec-core/src/Security/Advisories/Core/Advisory.hs +++ b/code/hsec-core/src/Security/Advisories/Core/Advisory.hs @@ -14,20 +14,20 @@ module Security.Advisories.Core.Advisory where import Data.Text (Text) -import Data.Time (ZonedTime) +import Data.Time (UTCTime) import Distribution.Types.Version (Version) import Distribution.Types.VersionRange (VersionRange) import Text.Pandoc.Definition (Pandoc) -import Security.Advisories.Core.HsecId +import Security.Advisories.Core.HsecId (HsecId) import qualified Security.CVSS as CVSS import Security.OSV (Reference) data Advisory = Advisory { advisoryId :: HsecId - , advisoryModified :: ZonedTime - , advisoryPublished :: ZonedTime + , advisoryModified :: UTCTime + , advisoryPublished :: UTCTime , advisoryCAPECs :: [CAPEC] , advisoryCWEs :: [CWE] , advisoryKeywords :: [Keyword] diff --git a/code/hsec-tools/hsec-tools.cabal b/code/hsec-tools/hsec-tools.cabal index 4097bb8c..f9085800 100644 --- a/code/hsec-tools/hsec-tools.cabal +++ b/code/hsec-tools/hsec-tools.cabal @@ -62,7 +62,7 @@ library , safe >=0.3 && < 0.4 , text >=1.2 && <3 , time >=1.9 && <1.14 - , toml-parser ^>=2.0.0.0 + , toml-parser ^>=2.0.1.0 , validation-selective >=0.1 && <1 hs-source-dirs: src diff --git a/code/hsec-tools/src/Security/Advisories/Convert/OSV.hs b/code/hsec-tools/src/Security/Advisories/Convert/OSV.hs index b1ed25a8..07cffcfa 100644 --- a/code/hsec-tools/src/Security/Advisories/Convert/OSV.hs +++ b/code/hsec-tools/src/Security/Advisories/Convert/OSV.hs @@ -6,7 +6,6 @@ module Security.Advisories.Convert.OSV where import qualified Data.Text as T -import Data.Time (zonedTimeToUTC) import Data.Void import Distribution.Pretty (prettyShow) @@ -17,9 +16,9 @@ convert :: Advisory -> OSV.Model Void Void Void Void convert adv = ( OSV.newModel' (T.pack . printHsecId $ advisoryId adv) - (zonedTimeToUTC $ advisoryModified adv) + (advisoryModified adv) ) - { OSV.modelPublished = Just $ zonedTimeToUTC (advisoryPublished adv) + { OSV.modelPublished = Just $ advisoryPublished adv , OSV.modelAliases = advisoryAliases adv , OSV.modelRelated = advisoryRelated adv , OSV.modelSummary = Just $ advisorySummary adv diff --git a/code/hsec-tools/src/Security/Advisories/Generate/HTML.hs b/code/hsec-tools/src/Security/Advisories/Generate/HTML.hs index 9a564414..7055ab08 100644 --- a/code/hsec-tools/src/Security/Advisories/Generate/HTML.hs +++ b/code/hsec-tools/src/Security/Advisories/Generate/HTML.hs @@ -16,7 +16,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL -import Data.Time (ZonedTime, zonedTimeToUTC) +import Data.Time (UTCTime) import Data.Time.Format.ISO8601 import System.Directory (createDirectoryIfMissing) import System.Exit (exitFailure) @@ -73,7 +73,7 @@ data AdvisoryR = AdvisoryR { advisoryId :: Advisories.HsecId, advisorySummary :: Text, advisoryAffected :: [AffectedPackageR], - advisoryModified :: ZonedTime + advisoryModified :: UTCTime } deriving stock (Show) @@ -233,7 +233,7 @@ feed advisories = ( Feed.nullFeed atomFeedUrl (Feed.TextString "Haskell Security Advisory DB") -- Title - (maybe "" (T.pack . iso8601Show) . maximumMay . fmap (zonedTimeToUTC . Advisories.advisoryModified) $ advisories) + (maybe "" (T.pack . iso8601Show) . maximumMay . fmap Advisories.advisoryModified $ advisories) ) { Feed.feedEntries = fmap toEntry advisories , Feed.feedLinks = [(Feed.nullLink atomFeedUrl) { Feed.linkRel = Just (Left "self") }] diff --git a/code/hsec-tools/src/Security/Advisories/Git.hs b/code/hsec-tools/src/Security/Advisories/Git.hs index 2ee937b5..274e0c6e 100644 --- a/code/hsec-tools/src/Security/Advisories/Git.hs +++ b/code/hsec-tools/src/Security/Advisories/Git.hs @@ -19,7 +19,7 @@ module Security.Advisories.Git import Data.Char (isSpace) import Data.List (dropWhileEnd) -import Data.Time (ZonedTime, utcToZonedTime, utc) +import Data.Time (UTCTime, zonedTimeToUTC) import Data.Time.Format.ISO8601 (iso8601ParseM) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath (splitFileName) @@ -27,8 +27,8 @@ import System.Process (readProcessWithExitCode) import Control.Applicative ((<|>)) data AdvisoryGitInfo = AdvisoryGitInfo - { firstAppearanceCommitDate :: ZonedTime - , lastModificationCommitDate :: ZonedTime + { firstAppearanceCommitDate :: UTCTime + , lastModificationCommitDate :: UTCTime } data GitError @@ -119,7 +119,7 @@ getAdvisoryGitInfo path = do -- the same as `ExitFailure` pure . Left $ GitProcessError status stdout stderr where - parseTime :: String -> Either GitError ZonedTime + parseTime :: String -> Either GitError UTCTime parseTime s = maybe (Left $ GitTimeParseError s) Right $ iso8601ParseM s - <|> utcToZonedTime utc <$> iso8601ParseM s + <|> zonedTimeToUTC <$> iso8601ParseM s diff --git a/code/hsec-tools/src/Security/Advisories/Parse.hs b/code/hsec-tools/src/Security/Advisories/Parse.hs index 8dc59d97..a740508a 100644 --- a/code/hsec-tools/src/Security/Advisories/Parse.hs +++ b/code/hsec-tools/src/Security/Advisories/Parse.hs @@ -29,7 +29,7 @@ import qualified Data.Map as Map import Data.Sequence (Seq((:<|))) import qualified Data.Text as T import qualified Data.Text.Lazy as T (toStrict) -import Data.Time (ZonedTime(..), LocalTime (LocalTime), midnight, utc) +import Data.Time (utc, UTCTime(..), zonedTimeToUTC, localTimeToUTC) import Distribution.Parsec (eitherParsec) import Distribution.Types.Version (Version) import Distribution.Types.VersionRange (VersionRange) @@ -67,8 +67,8 @@ type OOB = Either OOBError OutOfBandAttributes -- set particular fields. -- data OutOfBandAttributes = OutOfBandAttributes - { oobModified :: ZonedTime - , oobPublished :: ZonedTime + { oobModified :: UTCTime + , oobPublished :: UTCTime } deriving (Show) @@ -245,8 +245,8 @@ instance Toml.ToTable FrontMatter where -- TOML frontmatter in an advisory markdown file. data AdvisoryMetadata = AdvisoryMetadata { amdId :: HsecId - , amdModified :: Maybe ZonedTime - , amdPublished :: Maybe ZonedTime + , amdModified :: Maybe UTCTime + , amdPublished :: Maybe UTCTime , amdCAPECs :: [CAPEC] , amdCWEs :: [CWE] , amdKeywords :: [Keyword] @@ -369,10 +369,10 @@ instance Toml.ToValue Keyword where toValue (Keyword x) = Toml.toValue x -- | Get a datetime with the timezone defaulted to UTC and the time defaulted to midnight -getDefaultedZonedTime :: Toml.Value' l -> Toml.Matcher l ZonedTime -getDefaultedZonedTime (Toml.ZonedTime' _ x) = pure x -getDefaultedZonedTime (Toml.LocalTime' _ x) = pure (ZonedTime x utc) -getDefaultedZonedTime (Toml.Day' _ x) = pure (ZonedTime (LocalTime x midnight) utc) +getDefaultedZonedTime :: Toml.Value' l -> Toml.Matcher l UTCTime +getDefaultedZonedTime (Toml.ZonedTime' _ x) = pure (zonedTimeToUTC x) +getDefaultedZonedTime (Toml.LocalTime' _ x) = pure (localTimeToUTC utc x) +getDefaultedZonedTime (Toml.Day' _ x) = pure (UTCTime x 0) getDefaultedZonedTime v = Toml.failAt (Toml.valueAnn v) "expected a date with optional time and timezone" advisoryDoc :: Blocks -> Either T.Text (T.Text, [Block]) diff --git a/code/hsec-tools/test/Spec.hs b/code/hsec-tools/test/Spec.hs index b3631e25..6f9d2da3 100644 --- a/code/hsec-tools/test/Spec.hs +++ b/code/hsec-tools/test/Spec.hs @@ -7,8 +7,8 @@ import Data.List (isSuffixOf) import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Encoding as LText +import Data.Time (UTCTime(UTCTime)) import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) -import Data.Time.LocalTime import System.Directory (listDirectory) import Test.Tasty (defaultMain, testGroup, TestTree) import Test.Tasty.Golden (goldenVsString) @@ -41,7 +41,7 @@ doGoldenTest fp = goldenVsString fp (fp <> ".golden") (LText.encodeUtf8 <$> doCh doCheck :: IO LText.Text doCheck = do input <- T.readFile fp - let fakeDate = ZonedTime (LocalTime (fromOrdinalDate 1970 0) midnight) utc + let fakeDate = UTCTime (fromOrdinalDate 1970 0) 0 attr = OutOfBandAttributes { oobPublished = fakeDate , oobModified = fakeDate diff --git a/flake.lock b/flake.lock index 783f2afb..fc0942e3 100644 --- a/flake.lock +++ b/flake.lock @@ -37,8 +37,7 @@ "root": { "inputs": { "flake-utils": "flake-utils", - "nixpkgs": "nixpkgs", - "toml-parser": "toml-parser" + "nixpkgs": "nixpkgs" } }, "systems": { @@ -55,23 +54,6 @@ "repo": "default", "type": "github" } - }, - "toml-parser": { - "flake": false, - "locked": { - "lastModified": 1708792062, - "narHash": "sha256-RiRBBnDriQi9jH76JVr72ygYWtGF963iv/XoPBuMA3U=", - "owner": "glguy", - "repo": "toml-parser", - "rev": "4bcf07dc403a0882e9ce5a423473306cf1863f2f", - "type": "github" - }, - "original": { - "owner": "glguy", - "ref": "toml-parser-2.0.0.0", - "repo": "toml-parser", - "type": "github" - } } }, "root": "root", diff --git a/flake.nix b/flake.nix index 08036306..d163def9 100644 --- a/flake.nix +++ b/flake.nix @@ -4,13 +4,9 @@ inputs = { nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; flake-utils.url = "github:numtide/flake-utils"; - toml-parser = { - url = "github:glguy/toml-parser/toml-parser-2.0.0.0"; - flake = false; - }; }; - outputs = { self, nixpkgs, flake-utils, toml-parser }: + outputs = { self, nixpkgs, flake-utils }: flake-utils.lib.eachDefaultSystem (system: let overlays = [ ]; @@ -34,7 +30,7 @@ overrides = self: super: { inherit cvss hsec-core osv; Cabal-syntax = super.Cabal-syntax_3_8_1_0; - toml-parser = jailbreakUnbreak (super.callCabal2nix "toml-parser" toml-parser { }); + toml-parser = jailbreakUnbreak (super.callHackageDirect {pkg = "toml-parser"; ver = "2.0.1.0"; sha256 = "sha256-+2d8tflkqT3g7QJVjw/FTdluBASiHP3lDr7w5eNr4bY=";} {}); }; modifier = drv: From 949c3bd7d7408f38204289999a129ace64eda4dd Mon Sep 17 00:00:00 2001 From: mangoiv Date: Sun, 9 Jun 2024 20:25:18 +0200 Subject: [PATCH 6/6] [chore] major version bump for hsec-core --- code/hsec-core/hsec-core.cabal | 2 +- code/hsec-sync/hsec-sync.cabal | 2 +- code/hsec-tools/hsec-tools.cabal | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/code/hsec-core/hsec-core.cabal b/code/hsec-core/hsec-core.cabal index e9c18fc2..ac776367 100644 --- a/code/hsec-core/hsec-core.cabal +++ b/code/hsec-core/hsec-core.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hsec-core -version: 0.1.0.0 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: Core package representing Haskell advisories diff --git a/code/hsec-sync/hsec-sync.cabal b/code/hsec-sync/hsec-sync.cabal index 836a4473..727bfd50 100644 --- a/code/hsec-sync/hsec-sync.cabal +++ b/code/hsec-sync/hsec-sync.cabal @@ -35,7 +35,7 @@ library , extra >=1.7 && <1.8 , feed >=1.3 && <1.4 , filepath >=1.4 && <1.5 - , hsec-core >= 0.1 && < 0.2 + , hsec-core ^>= 0.2 , http-client >=0.7.0 && <0.8 , lens >=5.1 && <5.3 , process >=1.6 && <1.7 diff --git a/code/hsec-tools/hsec-tools.cabal b/code/hsec-tools/hsec-tools.cabal index f9085800..8a13d138 100644 --- a/code/hsec-tools/hsec-tools.cabal +++ b/code/hsec-tools/hsec-tools.cabal @@ -50,7 +50,7 @@ library , directory <2 , extra ^>=1.7.5 , filepath >=1.4 && <1.5 - , hsec-core >= 0.1 && < 0.2 + , hsec-core ^>= 0.2 , feed ==1.3.* , lucid >=2.9.0 && < 3 , mtl >=2.2 && <2.4 @@ -86,7 +86,7 @@ executable hsec-tools , bytestring >=0.10 && <0.13 , Cabal-syntax >=3.8.1.0 && <3.11 , filepath >=1.4 && <1.5 - , hsec-core >= 0.1 && < 0.2 + , hsec-core ^>= 0.2 , hsec-tools , optparse-applicative >=0.17 && <0.19 , text >=1.2 && <3