hsec-sync (empty) → 0.1.0.0
raw patch · 8 files changed
+583/−0 lines, 8 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, directory, extra, feed, filepath, hsec-core, hsec-sync, http-client, lens, optparse-applicative, process, tasty, tasty-hunit, temporary, text, time, transformers, wreq
Files
- CHANGELOG.md +0/−0
- app/Main.hs +80/−0
- hsec-sync.cabal +96/−0
- src/Security/Advisories/Sync.hs +76/−0
- src/Security/Advisories/Sync/Atom.hs +59/−0
- src/Security/Advisories/Sync/Git.hs +172/−0
- test/Spec.hs +14/−0
- test/Spec/SyncSpec.hs +86/−0
+ CHANGELOG.md view
+ app/Main.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad (join)+import Options.Applicative+import Security.Advisories.Sync+import System.Exit (die)++main :: IO ()+main =+ join $+ customExecParser+ (prefs showHelpOnEmpty)+ cliOpts++cliOpts :: ParserInfo (IO ())+cliOpts = info (commandsParser <**> helper) (fullDesc <> header "Haskell Advisories tools")+ where+ 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"))+ )++commandSync :: Parser (IO ())+commandSync = go <$> repositoryParser+ where+ go repo = do+ result <- sync repo+ case result of+ Left e ->+ die e+ Right s -> do+ putStrLn $+ "Repository at "+ <> show (repositoryRoot repo)+ <> " from "+ <> show (repositoryUrl repo <> "@" <> repositoryBranch repo)+ putStrLn $+ case s of+ Created -> "Repository just created"+ Updated -> "Repository updated"+ AlreadyUpToDate -> "Repository already up-to-date"++commandStatus :: Parser (IO ())+commandStatus = go <$> repositoryParser+ where+ go repo = do+ result <- status repo+ putStrLn $+ case result of+ DirectoryMissing -> "Directory is missing"+ DirectoryEmpty -> "Directory is empty"+ DirectoryUpToDate -> "Repository is up-to-date"+ DirectoryOutDated -> "Repository is out-dated"++repositoryParser :: Parser Repository+repositoryParser =+ Repository+ <$> strOption+ ( long "repository-root"+ <> short 'd'+ <> metavar "REPOSITORY-ROOT"+ <> value (repositoryRoot defaultRepository)+ )+ <*> strOption+ ( long "repository-url"+ <> short 'r'+ <> metavar "REPOSITORY-URL"+ <> value (repositoryUrl defaultRepository)+ )+ <*> strOption+ ( long "repository-branch"+ <> short 'b'+ <> metavar "REPOSITORY-BRANCH"+ <> value (repositoryBranch defaultRepository)+ )
+ hsec-sync.cabal view
@@ -0,0 +1,96 @@+cabal-version: 2.4+name: hsec-sync+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Synchronize with the Haskell security advisory database++-- A longer description of the package.+description: Synchronize with the Haskell security advisory database.++-- A URL where users can report bugs.+-- bug-reports:++-- The license under which the package is released.+license: BSD-3-Clause+author: Gautier DI FOLCO+maintainer: gautier.difolco@gmail.com++-- A copyright notice.+-- copyright:+category: Data+extra-doc-files: CHANGELOG.md+tested-with:+ GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.3 || ==9.8.1++library+ exposed-modules: Security.Advisories.Sync+ other-modules:+ Security.Advisories.Sync.Atom+ Security.Advisories.Sync.Git++ 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++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++executable hsec-sync+ main-is: Main.hs++ -- Modules included in this executable, other than Main.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ build-depends:+ , aeson >=2.0.1.0 && <3+ , base >=4.14 && <4.20+ , bytestring >=0.10 && <0.13+ , filepath >=1.4 && <1.5+ , hsec-sync+ , optparse-applicative >=0.17 && <0.19+ , text >=1.2 && <3++ hs-source-dirs: app+ default-language: Haskell2010+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Spec.SyncSpec+ build-depends:+ , base <5+ , directory+ , hsec-sync+ , filepath+ , process+ , tasty <1.5+ , tasty-hunit <0.11+ , temporary ==1.*+ , text+ , time++ default-language: Haskell2010+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints
+ src/Security/Advisories/Sync.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DerivingStrategies #-}++module Security.Advisories.Sync+ ( Repository (..),+ defaultRepository,+ SyncStatus (..),+ sync,+ RepositoryStatus (..),+ status,+ )+where++import Data.Time (zonedTimeToUTC)+import Security.Advisories.Sync.Atom+import Security.Advisories.Sync.Git++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++data RepositoryStatus+ = DirectoryMissing+ | DirectoryEmpty+ | DirectoryUpToDate+ | DirectoryOutDated+ deriving stock (Eq, Show)++status :: Repository -> IO RepositoryStatus+status repo =+ status' repo =<< gitRepositoryStatus repo++status' :: Repository -> GitRepositoryStatus -> IO RepositoryStatus+status' repo gitStatus = do+ case gitStatus of+ GitDirectoryMissing ->+ return DirectoryMissing+ GitDirectoryEmpty ->+ return DirectoryEmpty+ GitDirectoryInitialized -> do+ gitInfo <- getDirectoryGitInfo $ repositoryRoot repo+ case gitInfo of+ Left _ ->+ return DirectoryOutDated+ Right info -> do+ update <- latestUpdate (repositoryUrl repo) (repositoryBranch repo)+ 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"+ }
+ src/Security/Advisories/Sync/Atom.hs view
@@ -0,0 +1,59 @@+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)
+ src/Security/Advisories/Sync/Git.hs view
@@ -0,0 +1,172 @@+{-# 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
+ test/Spec.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Test.Tasty++import qualified Spec.SyncSpec as SyncSpec++main :: IO ()+main = do+ defaultMain $+ testGroup "Tests"+ [ SyncSpec.spec+ ]
+ test/Spec/SyncSpec.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Spec.SyncSpec (spec) where++import Control.Monad (unless)+import Data.Bifunctor (first)+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 =+ testGroup+ "Sync"+ [ testGroup+ "sync"+ [ testCase "Invalid root should fail" $ do+ let repo = withRepositoryAt "/dev/advisories"+ status repo >>= (@?= DirectoryMissing)+ isGitHubActionRunner <- lookupEnv "GITHUB_ACTIONS"+ unless (isGitHubActionRunner == Just "true") $ do+ -- GitHub Action runners let you write anywhere+ result <- sync repo+ first (const ("<Redacted error>" :: String)) result @?= Left "<Redacted error>"+ status repo >>= (@?= DirectoryMissing),+ testCase "Subdirectory creation should work" $+ withSystemTempDirectory "hsec-sync" $ \p -> do+ let repo = withRepositoryAt $ p </> "repo"+ status repo >>= (@?= DirectoryMissing)+ result <- sync repo+ result @?= Right Created+ status repo >>= (@?= 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+ 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+ resultCreate @?= Right Created+ resultResync <- sync repo+ resultResync @?= Right AlreadyUpToDate,+ testCase "Sync behind should update" $+ withSystemTempDirectory "hsec-sync" $ \p -> do+ let repo = withRepositoryAt p+ resultCreate <- sync repo+ resultCreate @?= Right Created+ D.withCurrentDirectory p $ do+ (statusReset, _, _) <-+ readProcessWithExitCode "git" ["reset", "--hard", "HEAD~50"] ""+ statusReset @?= ExitSuccess+ status repo >>= (@?= DirectoryOutDated)+ resultResync <- sync repo+ resultResync @?= Right Updated+ status repo >>= (@?= DirectoryUpToDate),+ testCase "Sync behind and changed remote should update" $+ withSystemTempDirectory "hsec-sync" $ \p -> do+ let repo = withRepositoryAt p+ resultCreate <- sync repo+ 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+ resultResync @?= Right Updated+ ]+ ]++withRepositoryAt :: FilePath -> Repository+withRepositoryAt root =+ defaultRepository {repositoryRoot = root}