hsec-sync 0.1.0.0 → 0.2.0.2

raw patch · 12 files changed

+467/−367 lines, 12 filesdep +eitherdep +tardep +zlibdep −feeddep −processdep ~aesondep ~basedep ~extranew-uploaderbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: either, tar, zlib

Dependencies removed: feed, process

Dependency ranges changed: aeson, base, extra, filepath, hsec-core, lens, tasty, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +29/−0
• app/Main.hs +46/−23
• hsec-sync.cabal +28/−25
• overview.png binary
• recommended-workflow.png binary
• src/Security/Advisories/Sync.hs +63/−46
• src/Security/Advisories/Sync/Atom.hs +0/−59
• src/Security/Advisories/Sync/Git.hs +0/−172
• src/Security/Advisories/Sync/Snapshot.hs +214/−0
• src/Security/Advisories/Sync/Url.hs +27/−0
• test/Spec/SyncSpec.hs +49/−42

@@ -0,0 +1,11 @@+## 0.2.0.2++* Update `tasty` dependency bounds++## 0.2.0.0++* Rewrite, using `hsec-tools` snapshots++## 0.1.0.0++* Introduction, `git`-based

@@ -0,0 +1,29 @@+# hsec-sync++Synchronize with the [Haskell advisories database](https://github.com/haskell/security-advisories).++## Building++We aim to support both regular cabal-based and nix-based builds.++## Design++[hsec-tools](../hsec-tools/) is the main entry point for dealing with [security advisories](https://github.com/haskell/security-advisories).++Libraries implementors and services providers will mainly be interested by+`Security.Advisories.Queries` and `hsec-tools query` which allows querying+against a directory containing the advisories.++There are two ways for maintaining this local directory up-to-date:++* Manually (based on `git` of fetching archive from GitHub)+* Relying on `hsec-sync` (either via `Security.Advisories.Sync.sync` or `hsec-sync sync`)++![overview](./overview.png)++The recommended workflow is:++1. Use `hsec-sync` to ensure having an up-to-date advisories directory (created or updated)+2. Use `hsec-tools` to perform queries against it++![recommended-workflow](./recommended-workflow.png)

@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}  module Main where@@ -7,6 +6,7 @@ import Options.Applicative import Security.Advisories.Sync import System.Exit (die)+import System.IO (hPutStrLn, stderr)  main :: IO () main =@@ -21,60 +21,83 @@     commandsParser :: Parser (IO ())     commandsParser =       hsubparser-        ( command "sync" (info commandSync (progDesc "Synchronize a local Haskell Security Advisory repository"))-        <>  command "status" (info commandStatus (progDesc "Check the status of a local Haskell Security Advisory repository"))+        ( command "sync" (info commandSync (progDesc "Synchronize a local Haskell Security Advisory repository snapshot"))+            <> command "status" (info commandStatus (progDesc "Check the status of a local Haskell Security Advisory repository snapshot"))         )  commandSync :: Parser (IO ()) commandSync = go <$> repositoryParser   where-    go repo = do-      result <- sync repo+    go snapshot = do+      result <- sync snapshot       case result of         Left e ->           die e         Right s -> do           putStrLn $-            "Repository at "-              <> show (repositoryRoot repo)+            "Snapshot at "+              <> show (snapshotRoot snapshot)               <> " from "-              <> show (repositoryUrl repo <> "@" <> repositoryBranch repo)+              <> show (getSnapshotUrl $ snapshotUrl snapshot)           putStrLn $             case s of-              Created -> "Repository just created"-              Updated -> "Repository updated"-              AlreadyUpToDate -> "Repository already up-to-date"+              Created -> "Snapshot just created"+              Updated -> "Snapshot updated"+              AlreadyUpToDate -> "Snapshot already up-to-date"  commandStatus :: Parser (IO ()) commandStatus = go <$> repositoryParser   where-    go repo = do-      result <- status repo-      putStrLn $+    go snapshot = do+      result <- status snapshot+      hPutStrLn stderr $         case result of           DirectoryMissing -> "Directory is missing"-          DirectoryEmpty -> "Directory is empty"+          DirectoryIncoherent -> "Directory is incoherent"           DirectoryUpToDate -> "Repository is up-to-date"           DirectoryOutDated -> "Repository is out-dated" -repositoryParser :: Parser Repository+repositoryParser :: Parser Snapshot repositoryParser =-  Repository+  mkSnapshotSnapshot     <$> strOption-      ( long "repository-root"+      ( long "snapshot-root"           <> short 'd'-          <> metavar "REPOSITORY-ROOT"-          <> value (repositoryRoot defaultRepository)+          <> metavar "SNAPSHOT-ROOT"+          <> value (snapshotRoot defaultSnapshot)       )-    <*> strOption+    <*> (fmap Left repositoryGithubParser <|> fmap Right repositoryUrlParser)+  where mkSnapshotSnapshot root params =+          case params of+            Left (repoUrl, repoBranch) ->+              githubSnapshot root repoUrl repoBranch+            Right snapshotUrl' ->+              Snapshot+                { snapshotRoot = root,+                  snapshotUrl = SnapshotUrl snapshotUrl'+                }+++repositoryGithubParser :: Parser (String, String)+repositoryGithubParser =+  (,)+    <$> strOption       ( long "repository-url"           <> short 'r'           <> metavar "REPOSITORY-URL"-          <> value (repositoryUrl defaultRepository)+          <> value "https://github.com/haskell/security-advisories"       )     <*> strOption       ( long "repository-branch"           <> short 'b'           <> metavar "REPOSITORY-BRANCH"-          <> value (repositoryBranch defaultRepository)+          <> value "generated/snapshot-export"       )++repositoryUrlParser :: Parser String+repositoryUrlParser =+  strOption+    ( long "archive-url"+        <> short 'u'+        <> metavar "ARCHIVE-URL"+    )

@@ -1,6 +1,6 @@ cabal-version:   2.4 name:            hsec-sync-version:         0.1.0.0+version:         0.2.0.2  -- A short (one-line) description of the package. synopsis:        Synchronize with the Haskell security advisory database@@ -19,30 +19,34 @@ -- A copyright notice. -- copyright: category:        Data-extra-doc-files: CHANGELOG.md+extra-doc-files: CHANGELOG.md, overview.png, recommended-workflow.png, README.md tested-with:-  GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.3 || ==9.8.1+  GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.3 || ==9.10.1 || ==9.12.1  library   exposed-modules:  Security.Advisories.Sync   other-modules:-    Security.Advisories.Sync.Atom-    Security.Advisories.Sync.Git+    Security.Advisories.Sync.Snapshot+    Security.Advisories.Sync.Url    build-depends:-    , base         >=4.14  && <4.20-    , directory    >=1.3   && <1.4-    , extra        >=1.7   && <1.8-    , feed         >=1.3   && <1.4-    , filepath     >=1.4   && <1.5-    , hsec-core    >= 1.0  && < 2.0-    , http-client  >=0.7.0 && <0.8-    , lens         >=5.1   && <5.3-    , process      >=1.6   && <1.7-    , text         >=1.2   && <3-    , time         >=1.9   && <1.14-    , transformers >=0.5   && <0.7-    , wreq         >=0.5   && <0.6+    , aeson         >=2.0   && <3+    , base          >=4.14  && <5+    , bytestring    >=0.10  && <0.13+    , directory     >=1.3   && <1.4+    , either        >=5.0   && <5.1+    , extra         >=1.7   && <1.9+    , filepath      >=1.4   && <1.6+    , hsec-core     ^>=0.2+    , http-client   >=0.7.0 && <0.8+    , lens          >=5.1   && <5.4+    , tar           >=0.5   && <0.7+    , temporary     >=1     && <2+    , text          >=1.2   && <3+    , time          >=1.9   && <1.15+    , transformers  >=0.5   && <0.7+    , wreq          >=0.5   && <0.6+    , zlib          >=0.6   && <0.8    hs-source-dirs:   src   default-language: Haskell2010@@ -60,9 +64,9 @@   -- other-extensions:   build-depends:     , aeson                 >=2.0.1.0 && <3-    , base                  >=4.14    && <4.20+    , base                  >=4.14    && <5     , bytestring            >=0.10    && <0.13-    , filepath              >=1.4     && <1.5+    , filepath              >=1.4     && <1.6     , hsec-sync     , optparse-applicative  >=0.17    && <0.19     , text                  >=1.2     && <3@@ -79,14 +83,13 @@   main-is:          Spec.hs   other-modules:    Spec.SyncSpec   build-depends:-    , base         <5+    , base     , directory-    , hsec-sync     , filepath-    , process-    , tasty        <1.5+    , hsec-sync+    , tasty        <2     , tasty-hunit  <0.11-    , temporary    ==1.*+    , temporary    >=1   && <2     , text     , time 

binary file changed (absent → 68298 bytes)

binary file changed (absent → 64005 bytes)

@@ -1,8 +1,11 @@ {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}  module Security.Advisories.Sync-  ( Repository (..),-    defaultRepository,+  ( Snapshot (..),+    SnapshotUrl (..),+    defaultSnapshot,+    githubSnapshot,     SyncStatus (..),     sync,     RepositoryStatus (..),@@ -10,67 +13,81 @@   ) where -import Data.Time (zonedTimeToUTC)-import Security.Advisories.Sync.Atom-import Security.Advisories.Sync.Git+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (runExceptT, withExceptT)+import Security.Advisories.Sync.Snapshot+import Security.Advisories.Sync.Url +data Snapshot = Snapshot+  { snapshotRoot :: FilePath,+    snapshotUrl :: SnapshotUrl+  }++defaultSnapshot :: Snapshot+defaultSnapshot =+  githubSnapshot+    "security-advisories"+    "https://github.com/haskell/security-advisories"+    "generated/snapshot-export"++githubSnapshot :: FilePath -> String -> String -> Snapshot+githubSnapshot root repoUrl repoBranch =+  Snapshot+    { snapshotRoot = root,+      snapshotUrl = SnapshotUrl $ ensureFile (mkUrl [repoUrl, "archive/refs/heads", repoBranch]) <> ".tar.gz"+    }+ data SyncStatus   = Created   | Updated   | AlreadyUpToDate   deriving stock (Eq, Show) -sync :: Repository -> IO (Either String SyncStatus)-sync repo = do-  gitStatus <- gitRepositoryStatus repo-  ensured <- ensureGitRepositoryWithRemote repo gitStatus-  let mkGitError = Left . explainGitError-  case ensured of-    Left e -> return $ mkGitError e-    Right s ->-      case s of-        GitRepositoryCreated ->-          return $ Right Created-        GitRepositoryExisting -> do-          repoStatus <- status' repo gitStatus-          if repoStatus == DirectoryOutDated-            then either mkGitError (const $ Right Updated) <$> updateGitRepository repo-            else return $ Right AlreadyUpToDate+sync :: Snapshot -> IO (Either String SyncStatus)+sync s =+  runExceptT $ do+    snapshotStatus <- liftIO $ snapshotRepositoryStatus $ snapshotRoot s+    ensuredStatus <- withExceptT explainSnapshotError $ ensureSnapshot (snapshotRoot s) (snapshotUrl s) snapshotStatus+    case ensuredStatus of+      SnapshotRepositoryCreated ->+        return Created+      SnapshotRepositoryExisting -> do+        repoStatus <- liftIO $ status' s snapshotStatus+        if repoStatus == DirectoryOutDated+          then do+            withExceptT explainSnapshotError $ overwriteSnapshot (snapshotRoot s) (snapshotUrl s)+            return Updated+          else return AlreadyUpToDate  data RepositoryStatus   = DirectoryMissing-  | DirectoryEmpty+  | -- | Used when expected files/directories are missing or not readable+    DirectoryIncoherent   | DirectoryUpToDate   | DirectoryOutDated   deriving stock (Eq, Show) -status :: Repository -> IO RepositoryStatus-status repo =-  status' repo =<< gitRepositoryStatus repo+status :: Snapshot -> IO RepositoryStatus+status s =+  status' s =<< snapshotRepositoryStatus (snapshotRoot s) -status' :: Repository -> GitRepositoryStatus -> IO RepositoryStatus-status' repo gitStatus = do-  case gitStatus of-    GitDirectoryMissing ->+status' :: Snapshot -> SnapshotRepositoryStatus -> IO RepositoryStatus+status' s =+  \case+    SnapshotDirectoryMissing ->       return DirectoryMissing-    GitDirectoryEmpty ->-      return DirectoryEmpty-    GitDirectoryInitialized -> do-      gitInfo <- getDirectoryGitInfo $ repositoryRoot repo-      case gitInfo of+    SnapshotDirectoryIncoherent ->+      return DirectoryIncoherent+    SnapshotDirectoryInitialized -> do+      snapshotInfo <- getDirectorySnapshotInfo $ snapshotRoot s+      case snapshotInfo of         Left _ ->           return DirectoryOutDated         Right info -> do-          update <- latestUpdate (repositoryUrl repo) (repositoryBranch repo)+          update <- runExceptT $ latestUpdate $ snapshotUrl s           return $-            if update == Right (zonedTimeToUTC $ lastModificationCommitDate info)-              then DirectoryUpToDate-              else DirectoryOutDated--defaultRepository :: Repository-defaultRepository =-  Repository-    { repositoryUrl = "https://github.com/haskell/security-advisories",-      repositoryRoot = "security-advisories",-      repositoryBranch = "main"-    }+            case update of+              Right latestETag | latestETag == etag info ->+                DirectoryUpToDate+              _ ->+                DirectoryOutDated

@@ -1,59 +0,0 @@-module Security.Advisories.Sync.Atom-  ( latestUpdate,-  )-where--import Control.Exception (try)-import Control.Lens-import Data.Either.Extra (maybeToEither)-import qualified Data.Text as T-import Data.Time (UTCTime, defaultTimeLocale, parseTimeM, rfc822DateFormat)-import Data.Time.Format.ISO8601 (iso8601ParseM)-import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..))-import Network.Wreq-import qualified Text.Atom.Feed as FeedAtom-import qualified Text.Feed.Import as FeedImport-import qualified Text.Feed.Types as FeedTypes-import qualified Text.RSS.Syntax as FeedRSS--latestUpdate :: String -> String -> IO (Either String UTCTime)-latestUpdate repoUrl branch = do-  resultE <- try $ get $ repoUrl </> "commits" </> branch </> "advisories.atom"-  return $-    case resultE of-      Left e ->-        Left $-          case e of-            InvalidUrlException url reason ->-              "Invalid URL " <> show url <> ": " <> show reason-            HttpExceptionRequest _ content ->-              case content of-                StatusCodeException response body ->-                  "Request failed with " <> show (response ^. responseStatus) <> ": " <> show body-                _ ->-                  "Request failed: " <> show content-      Right result ->-        case FeedImport.parseFeedSource $ result ^. responseBody of-          Just (FeedTypes.AtomFeed x) ->-            maybeToEither "Invalid feed date" $-              iso8601ParseM $-                T.unpack $-                  FeedAtom.feedUpdated x-          Just (FeedTypes.RSSFeed x) ->-            maybeToEither "Invalid feed date" $-              FeedRSS.rssLastUpdate (FeedRSS.rssChannel x)-                >>= parseTimeM True defaultTimeLocale rfc822DateFormat . T.unpack-          Just (FeedTypes.RSS1Feed _) -> Left "RSS1 feed are not supported"-          Just (FeedTypes.XMLFeed _) -> Left "XML feed are not supported"-          Nothing -> Left "No feed found"--infixr 5 </>--(</>) :: String -> String -> String-"/" </> ('/' : ys) = '/' : ys-"/" </> ys = '/' : ys-"" </> ('/' : ys) = '/' : ys-"" </> ys = '/' : ys-[x] </> ('/' : ys) = x : '/' : ys-[x] </> ys = x : '/' : ys-(x0 : x1 : xs) </> ys = x0 : ((x1 : xs) </> ys)

@@ -1,172 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}---- |------ Helpers for deriving advisory metadata from a Git repo.-module Security.Advisories.Sync.Git-  ( GitDirectoryInfo (..),-    GitError (..),-    GitErrorCase (..),-    explainGitError,-    Repository (..),-    GitRepositoryEnsuredStatus (..),-    ensureGitRepositoryWithRemote,-    getDirectoryGitInfo,-    updateGitRepository,-    GitRepositoryStatus (..),-    gitRepositoryStatus,-  )-where--import Control.Monad (when)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Except (runExceptT, throwE)-import Data.Time (ZonedTime)-import Data.Time.Format.ISO8601 (iso8601ParseM)-import qualified System.Directory as D-import System.Exit (ExitCode (ExitSuccess))-import System.Process (readProcessWithExitCode)--type Cmd = (FilePath, [String])--data GitError = GitError-  { gitCmd :: Cmd,-    gitError :: GitErrorCase-  }--runGit :: [String] -> IO (Cmd, ExitCode, String, String)-runGit args =-  (\(status, stdout, stderr) -> (("git", args), status, stdout, stderr))-    <$> readProcessWithExitCode "git" args ""--data GitErrorCase-  = -- | exit code, stdout and stderr-    GitProcessError ExitCode String String-  | -- | unable to parse this input as a datetime-    GitTimeParseError String-  deriving (Show)--explainGitError :: GitError -> String-explainGitError e =-  unlines-    [ "Called " <> show (fst $ gitCmd e) <> " with " <> show (snd $ gitCmd e),-      case gitError e of-        GitProcessError status stdout stderr ->-          unlines-            [ "git exited with status " <> show status,-              ">>> standard output:",-              stdout,-              ">>> standard error:",-              stderr-            ]-        GitTimeParseError s ->-          "failed to parse time: " <> s-    ]--data Repository = Repository-  { repositoryRoot :: FilePath,-    repositoryUrl :: String,-    repositoryBranch :: String-  }--data GitRepositoryStatus-  = GitDirectoryMissing-  | GitDirectoryEmpty-  | GitDirectoryInitialized--gitRepositoryStatus :: Repository -> IO GitRepositoryStatus-gitRepositoryStatus repo = do-  exists <- D.doesDirectoryExist $ repositoryRoot repo-  if exists-    then D.withCurrentDirectory (repositoryRoot repo) $ do-      (_, checkStatus, checkStdout, _) <--        runGit ["rev-parse", "--is-inside-work-tree"]-      let out = filter (not . null) $ lines checkStdout-      case checkStatus of-        ExitSuccess-          | not (null out) && head out == "true" ->-              return GitDirectoryInitialized-        _ ->-          return GitDirectoryEmpty-    else return GitDirectoryMissing--data GitRepositoryEnsuredStatus-  = GitRepositoryCreated-  | GitRepositoryExisting--ensureGitRepositoryWithRemote ::-  Repository ->-  GitRepositoryStatus ->-  IO (Either GitError GitRepositoryEnsuredStatus)-ensureGitRepositoryWithRemote repo =-  \case-    GitDirectoryMissing ->-      clone-    GitDirectoryEmpty ->-      clone-    GitDirectoryInitialized ->-      return $ Right GitRepositoryExisting-  where-    clone = do-      (cmd, status, stdout, stderr) <--        runGit ["clone", "-b", repositoryBranch repo, repositoryUrl repo, repositoryRoot repo]-      return $-        if status /= ExitSuccess-          then Left $ GitError cmd $ GitProcessError status stdout stderr-          else Right GitRepositoryCreated--updateGitRepository :: Repository -> IO (Either GitError ())-updateGitRepository repo =-  D.withCurrentDirectory (repositoryRoot repo) $-    runExceptT $ do-      _ <- liftIO $ runGit ["remote", "add", "origin", repositoryUrl repo] -- can fail if it exists-      (setUrlCmd, setUrlStatus, setUrlStdout, setUrlStderr) <--        liftIO $ runGit ["remote", "set-url", "origin", repositoryUrl repo]-      when (setUrlStatus /= ExitSuccess) $-        throwE $-          GitError setUrlCmd $-            GitProcessError setUrlStatus setUrlStdout setUrlStderr--      (fetchAllCmd, fetchAllStatus, fetchAllStdout, fetchAllStderr) <--        liftIO $ runGit ["fetch", "--all"]-      when (fetchAllStatus /= ExitSuccess) $-        throwE $-          GitError fetchAllCmd $-            GitProcessError fetchAllStatus fetchAllStdout fetchAllStderr--      (checkoutBranchCmd, checkoutBranchStatus, checkoutBranchStdout, checkoutBranchStderr) <--        liftIO $ runGit ["checkout", repositoryBranch repo]-      when (checkoutBranchStatus /= ExitSuccess) $-        throwE $-          GitError checkoutBranchCmd $-            GitProcessError checkoutBranchStatus checkoutBranchStdout checkoutBranchStderr--      (resetCmd, resetStatus, resetStdout, resetStderr) <--        liftIO $ runGit ["reset", "--hard", "origin/" <> repositoryBranch repo]--      when (resetStatus /= ExitSuccess) $-        throwE $-          GitError resetCmd $-            GitProcessError resetStatus resetStdout resetStderr--newtype GitDirectoryInfo = GitDirectoryInfo-  { lastModificationCommitDate :: ZonedTime-  }--getDirectoryGitInfo :: FilePath -> IO (Either GitError GitDirectoryInfo)-getDirectoryGitInfo path = do-  (cmd, status, stdout, stderr) <--    runGit ["-C", path, "log", "--pretty=format:%cI", "--find-renames", "advisories"]-  let timestamps = filter (not . null) $ lines stdout-      onError = Left . GitError cmd-  case status of-    ExitSuccess-      | not (null timestamps) ->-          return $-            GitDirectoryInfo-              <$> parseTime onError (head timestamps)-    _ ->-      return $ onError $ GitProcessError status stdout stderr-  where-    parseTime onError s = maybe (onError $ GitTimeParseError s) Right $ iso8601ParseM s

@@ -0,0 +1,214 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+--+-- Helpers for deriving advisory metadata from a Snapshot s.+module Security.Advisories.Sync.Snapshot+  ( SnapshotDirectoryInfo (..),+    ETag (..),+    SnapshotError (..),+    explainSnapshotError,+    SnapshotUrl (..),+    SnapshotRepositoryEnsuredStatus (..),+    ensureSnapshot,+    getDirectorySnapshotInfo,+    overwriteSnapshot,+    SnapshotRepositoryStatus (..),+    snapshotRepositoryStatus,+    latestUpdate,+  )+where++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Compression.GZip as GZip+import Control.Exception (Exception (displayException), IOException, try)+import Control.Lens+import Control.Monad.Extra (unlessM, whenM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE, withExceptT)+import qualified Data.ByteString.Lazy as BL+import Data.Either.Combinators (whenLeft, fromRight)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..))+import Network.Wreq+import qualified System.Directory as D+import System.FilePath ((</>), hasTrailingPathSeparator, joinPath, splitPath)+import System.IO.Temp (withSystemTempDirectory)++data SnapshotError+  = SnapshotDirectoryMissingE+  | SnapshotIncoherent String+  | SnapshotProcessError SnapshotProcessError++data SnapshotProcessError+  = FetchSnapshotArchive String+  | DirectorySetupSnapshotArchive IOException+  | ExtractSnapshotArchive IOException++explainSnapshotError :: SnapshotError -> String+explainSnapshotError =+  \case+    SnapshotDirectoryMissingE -> "Snapshot directory is missing"+    SnapshotIncoherent e -> "Snapshot directory is incoherent: " <> e+    SnapshotProcessError e ->+      unlines+        [ "An exception occurred during snapshot processing:",+          case e of+            FetchSnapshotArchive x -> "Fetching failed with: " <> show x+            DirectorySetupSnapshotArchive x -> "Directory setup got an exception: " <> show x+            ExtractSnapshotArchive x -> "Extraction got an exception: " <> displayException x+        ]++newtype SnapshotUrl = SnapshotUrl {getSnapshotUrl :: String}++data SnapshotRepositoryStatus+  = SnapshotDirectoryMissing+  | SnapshotDirectoryInitialized+  | SnapshotDirectoryIncoherent++snapshotRepositoryStatus :: FilePath -> IO SnapshotRepositoryStatus+snapshotRepositoryStatus root = do+  dirExists <- D.doesDirectoryExist root+  if dirExists+    then do+      dirAdvisoriesExists <- D.doesDirectoryExist $ root </> "advisories"+      etagMetadataExists <- D.doesFileExist $ root </> "snapshot-etag"+      return $+        if dirAdvisoriesExists && etagMetadataExists+          then SnapshotDirectoryInitialized+          else SnapshotDirectoryIncoherent+    else return SnapshotDirectoryMissing++data SnapshotRepositoryEnsuredStatus+  = SnapshotRepositoryCreated+  | SnapshotRepositoryExisting++ensureSnapshot ::+  FilePath ->+  SnapshotUrl ->+  SnapshotRepositoryStatus ->+  ExceptT SnapshotError IO SnapshotRepositoryEnsuredStatus+ensureSnapshot root url =+  \case+    SnapshotDirectoryMissing -> do+      overwriteSnapshot root url+      return SnapshotRepositoryCreated+    SnapshotDirectoryIncoherent -> do+      overwriteSnapshot root url+      return SnapshotRepositoryCreated+    SnapshotDirectoryInitialized ->+      return SnapshotRepositoryExisting++overwriteSnapshot :: FilePath -> SnapshotUrl -> ExceptT SnapshotError IO ()+overwriteSnapshot root url =+  withExceptT SnapshotProcessError $ do+    ensuringPerformed <- liftIO $ try $ ensureEmptyRoot root+    whenLeft ensuringPerformed $+      throwE . DirectorySetupSnapshotArchive++    resultE <- liftIO $ try $ get $ getSnapshotUrl url+    case resultE of+      Left e ->+        throwE $+          FetchSnapshotArchive $+            case e of+              InvalidUrlException url' reason ->+                "Invalid URL " <> show url' <> ": " <> show reason+              HttpExceptionRequest _ content ->+                case content of+                  StatusCodeException response body ->+                    "Request (GET " <> getSnapshotUrl url <> ") failed with " <> show (response ^. responseStatus) <> ": " <> show body+                  _ ->+                    "Request (GET " <> getSnapshotUrl url <> ") failed: " <> show content+      Right result -> do+        performed <-+          liftIO $+            try $+              withSystemTempDirectory "security-advisories" $ \tempDir -> do+                let archivePath = tempDir <> "/snapshot-export.tar.gz"+                BL.writeFile archivePath $ result ^. responseBody+                contents <- BL.readFile archivePath+                let fixEntry e = e { Tar.entryTarPath = fixEntryPath $ Tar.entryTarPath e }+                    fixEntryPath :: Tar.TarPath -> Tar.TarPath+                    fixEntryPath p =+                      fromRight p $+                        maybe+                          (Right p)+                          (Tar.toTarPath (hasTrailingPathSeparator $ Tar.fromTarPath p) . joinPath) $+                        stripRootPath $+                        splitPath $+                        Tar.fromTarPath p+                    stripRootPath =+                      \case+                        ("/":_:p:ps) -> Just (p:ps)+                        (_:p:ps) -> Just (p:ps)+                        [p] | hasTrailingPathSeparator p -> Nothing+                        ps -> Just ps+                Tar.unpack root $ Tar.mapEntriesNoFail fixEntry $ Tar.read $ GZip.decompress contents+        whenLeft performed $+          throwE . ExtractSnapshotArchive++        etagWritten <-+          liftIO $+            try $+              T.writeFile (root </> "snapshot-etag") $+                T.decodeUtf8 $+                  result ^. responseHeader "etag"+        whenLeft etagWritten $+          throwE . ExtractSnapshotArchive++ensureEmptyRoot :: FilePath -> IO ()+ensureEmptyRoot root = do+  D.createDirectoryIfMissing False root++  whenM (D.doesDirectoryExist $ root </> "advisories") $+    D.removeDirectoryRecursive $+      root </> "advisories"++  whenM (D.doesFileExist $ root </> "snapshot-etag") $+    D.removeFile $+      root </> "snapshot-etag"++newtype SnapshotDirectoryInfo = SnapshotDirectoryInfo+  { etag :: ETag+  }+  deriving stock (Eq, Show)++newtype ETag = ETag T.Text+  deriving stock (Eq, Show)++getDirectorySnapshotInfo :: FilePath -> IO (Either SnapshotError SnapshotDirectoryInfo)+getDirectorySnapshotInfo root =+  runExceptT $ do+    let metadataPath = root </> "snapshot-etag"+    unlessM (liftIO $ D.doesFileExist metadataPath) $+      throwE SnapshotDirectoryMissingE++    SnapshotDirectoryInfo . ETag <$> liftIO (T.readFile metadataPath)++latestUpdate :: SnapshotUrl -> ExceptT SnapshotError IO ETag+latestUpdate url =+  withExceptT SnapshotProcessError $ do+    resultE <- liftIO $ try $ headWith (defaults & redirects .~ 3) $ getSnapshotUrl url+    case resultE of+      Left e ->+        throwE $+          FetchSnapshotArchive $+            case e of+              InvalidUrlException url' reason ->+                "Invalid URL " <> show url' <> ": " <> show reason+              HttpExceptionRequest _ content ->+                case content of+                  StatusCodeException response body ->+                    "Request (HEAD " <> getSnapshotUrl url <> ") failed with " <> show (response ^. responseStatus) <> ": " <> show body+                  _ ->+                    "Request (HEAD " <> getSnapshotUrl url <> ") failed: " <> show content+      Right result ->+        case result ^? responseHeader "etag" of+          Nothing -> throwE $ FetchSnapshotArchive "Missing ETag header"+          Just rawETag -> return $ ETag $ T.decodeUtf8 rawETag

@@ -0,0 +1,27 @@+{-# LANGUAGE LambdaCase #-}+module Security.Advisories.Sync.Url+  ( mkUrl+  , ensureFile+  )+where++mkUrl :: [String] -> String+mkUrl = foldl1 (</>)++infixr 5 </>++(</>) :: String -> String -> String+"/" </> ('/' : ys) = '/' : ys+"/" </> ys = '/' : ys+"" </> ('/' : ys) = '/' : ys+"" </> ys = '/' : ys+[x] </> ('/' : ys) = x : '/' : ys+[x] </> ys = x : '/' : ys+(x0 : x1 : xs) </> ys = x0 : ((x1 : xs) </> ys)++ensureFile :: String -> String+ensureFile =+  \case+    "" -> ""+    "/" -> ""+    (x:xs) -> x : ensureFile xs

@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}  module Spec.SyncSpec (spec) where@@ -8,79 +7,87 @@ import Security.Advisories.Sync import qualified System.Directory as D import System.Environment (lookupEnv)-import System.Exit (ExitCode (ExitSuccess)) import System.FilePath ((</>)) import System.IO.Temp (withSystemTempDirectory)-import System.Process (readProcessWithExitCode) import Test.Tasty import Test.Tasty.HUnit  spec :: TestTree-spec =+spec = testGroup "Sync" []++_spec :: TestTree+_spec =   testGroup     "Sync"     [ testGroup         "sync"         [ testCase "Invalid root should fail" $ do-            let repo = withRepositoryAt "/dev/advisories"-            status repo >>= (@?= DirectoryMissing)+            let snapshot = snapshotAt "/dev/advisories"+            status snapshot >>= (@?= DirectoryMissing)             isGitHubActionRunner <- lookupEnv "GITHUB_ACTIONS"             unless (isGitHubActionRunner == Just "true") $ do               -- GitHub Action runners let you write anywhere-              result <- sync repo+              result <- sync snapshot               first (const ("<Redacted error>" :: String)) result @?= Left "<Redacted error>"-            status repo >>= (@?= DirectoryMissing),+            status snapshot >>= (@?= DirectoryMissing),           testCase "Subdirectory creation should work" $             withSystemTempDirectory "hsec-sync" $ \p -> do-              let repo = withRepositoryAt $ p </> "repo"-              status repo >>= (@?= DirectoryMissing)-              result <- sync repo+              let snapshot = snapshotAt $ p </> "snapshot"+              status snapshot >>= (@?= DirectoryMissing)+              result <- sync snapshot               result @?= Right Created-              status repo >>= (@?= DirectoryUpToDate),+              status snapshot >>= (@?= DirectoryUpToDate),           testCase "With existing subdirectory creation should work" $             withSystemTempDirectory "hsec-sync" $ \p -> do-              D.createDirectory $ p </> "repo"-              let repo = withRepositoryAt $ p </> "repo"-              result <- sync repo+              D.createDirectory $ p </> "snapshot"+              let snapshot = snapshotAt $ p </> "snapshot"+              result <- sync snapshot               result @?= Right Created,           testCase "Sync twice should be a no-op" $             withSystemTempDirectory "hsec-sync" $ \p -> do-              let repo = withRepositoryAt p-              status repo >>= (@?= DirectoryEmpty)-              resultCreate <- sync repo+              let snapshot = snapshotAt p+              status snapshot >>= (@?= DirectoryIncoherent)+              resultCreate <- sync snapshot               resultCreate @?= Right Created-              resultResync <- sync repo+              resultResync <- sync snapshot               resultResync @?= Right AlreadyUpToDate,           testCase "Sync behind should update" $             withSystemTempDirectory "hsec-sync" $ \p -> do-              let repo = withRepositoryAt p-              resultCreate <- sync repo+              let snapshot = snapshotAt p+              resultCreate <- sync snapshot               resultCreate @?= Right Created-              D.withCurrentDirectory p $ do-                (statusReset, _, _) <--                  readProcessWithExitCode "git" ["reset", "--hard", "HEAD~50"] ""-                statusReset @?= ExitSuccess-              status repo >>= (@?= DirectoryOutDated)-              resultResync <- sync repo+              writeFile+                (p </> "snapshot.json")+                "{\"latestUpdate\":\"2020-03-11T12:26:51Z\",\"snapshotVersion\":\"0.1.0.0\"}"+              status snapshot >>= (@?= DirectoryOutDated)+              resultResync <- sync snapshot               resultResync @?= Right Updated-              status repo >>= (@?= DirectoryUpToDate),-          testCase "Sync behind and changed remote should update" $+              status snapshot >>= (@?= DirectoryUpToDate),+          testCase "Sync a broken snapshot.json" $             withSystemTempDirectory "hsec-sync" $ \p -> do-              let repo = withRepositoryAt p-              resultCreate <- sync repo+              let snapshot = snapshotAt p+              resultCreate <- sync snapshot               resultCreate @?= Right Created-              D.withCurrentDirectory p $ do-                (statusReset, _, _) <--                  readProcessWithExitCode "git" ["reset", "--hard", "HEAD~50"] ""-                statusReset @?= ExitSuccess-                (statusRemote, _, _) <--                  readProcessWithExitCode "git" ["remote", "rename", "origin", "old"] ""-                statusRemote @?= ExitSuccess-              resultResync <- sync repo+              writeFile+                (p </> "snapshot.json")+                "{\"latestpdate\":\"2020-03-11T12:26:51Z\",\"snapshotVersion\":\"0.1.0.0\"}"+              status snapshot >>= (@?= DirectoryIncoherent)+              resultResync <- sync snapshot               resultResync @?= Right Updated+              status snapshot >>= (@?= DirectoryUpToDate),+          testCase "Sync a deleted snapshot.json" $+            withSystemTempDirectory "hsec-sync" $ \p -> do+              let snapshot = snapshotAt p+              resultCreate <- sync snapshot+              resultCreate @?= Right Created+              D.removeFile (p </> "snapshot.json")+              status snapshot >>= (@?= DirectoryOutDated)+              resultResync <- sync snapshot+              resultResync @?= Right Updated+              status snapshot >>= (@?= DirectoryIncoherent)         ]     ] -withRepositoryAt :: FilePath -> Repository-withRepositoryAt root =-  defaultRepository {repositoryRoot = root}+snapshotAt :: FilePath -> Snapshot+snapshotAt root =+  defaultSnapshot {snapshotRoot = root}