diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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" + ) diff --git a/hsec-sync.cabal b/hsec-sync.cabal --- a/hsec-sync.cabal +++ b/hsec-sync.cabal @@ -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 diff --git a/overview.png b/overview.png new file mode 100644 Binary files /dev/null and b/overview.png differ diff --git a/recommended-workflow.png b/recommended-workflow.png new file mode 100644 Binary files /dev/null and b/recommended-workflow.png differ diff --git a/src/Security/Advisories/Sync.hs b/src/Security/Advisories/Sync.hs --- a/src/Security/Advisories/Sync.hs +++ b/src/Security/Advisories/Sync.hs @@ -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 diff --git a/src/Security/Advisories/Sync/Atom.hs b/src/Security/Advisories/Sync/Atom.hs deleted file mode 100644 --- a/src/Security/Advisories/Sync/Atom.hs +++ /dev/null @@ -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) diff --git a/src/Security/Advisories/Sync/Git.hs b/src/Security/Advisories/Sync/Git.hs deleted file mode 100644 --- a/src/Security/Advisories/Sync/Git.hs +++ /dev/null @@ -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 diff --git a/src/Security/Advisories/Sync/Snapshot.hs b/src/Security/Advisories/Sync/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/Security/Advisories/Sync/Snapshot.hs @@ -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 diff --git a/src/Security/Advisories/Sync/Url.hs b/src/Security/Advisories/Sync/Url.hs new file mode 100644 --- /dev/null +++ b/src/Security/Advisories/Sync/Url.hs @@ -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 diff --git a/test/Spec/SyncSpec.hs b/test/Spec/SyncSpec.hs --- a/test/Spec/SyncSpec.hs +++ b/test/Spec/SyncSpec.hs @@ -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 ("" :: String)) result @?= Left "" - 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}