feature: add hsec-sync status

code/hsec-sync/app/Main.hs

@@ -22,6 +22,7 @@ cliOpts = info (commandsParser <**> helper) (fullDesc <> header "Haskell Advisor
     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 ())
@@ -44,6 +45,18 @@ commandSync = go <$> repositoryParser
               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

code/hsec-sync/src/Security/Advisories/Sync.hs

@@ -5,6 +5,8 @@ module Security.Advisories.Sync
     defaultRepository,
     SyncStatus (..),
     sync,
+    RepositoryStatus (..),
+    status,
   )
 where
 
@@ -20,7 +22,8 @@ data SyncStatus
 
 sync :: Repository -> IO (Either String SyncStatus)
 sync repo = do
-  ensured <- ensureGitRepositoryWithRemote repo
+  gitStatus <- gitRepositoryStatus repo
+  ensured <- ensureGitRepositoryWithRemote repo gitStatus
   let mkGitError = Left . explainGitError
   case ensured of
     Left e -> return $ mkGitError e
@@ -29,14 +32,40 @@ sync repo = do
         GitRepositoryCreated ->
           return $ Right Created
         GitRepositoryExisting -> do
-          gitInfo <- getDirectoryGitInfo $ repositoryRoot repo
-          case gitInfo of
-            Left e -> return $ mkGitError e
-            Right info -> do
-              update <- latestUpdate (repositoryUrl repo) (repositoryBranch repo)
-              if update == Right (zonedTimeToUTC $ lastModificationCommitDate info)
-                then return $ Right AlreadyUpToDate
-                else either mkGitError (const $ Right Updated) <$> updateGitRepository repo
+          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 =

code/hsec-sync/src/Security/Advisories/Sync/Git.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase #-}
 
 -- |
 --
@@ -9,10 +10,12 @@ module Security.Advisories.Sync.Git
     GitErrorCase (..),
     explainGitError,
     Repository (..),
-    GitRepositoryStatus (..),
+    GitRepositoryEnsuredStatus (..),
     ensureGitRepositoryWithRemote,
     getDirectoryGitInfo,
     updateGitRepository,
+    GitRepositoryStatus (..),
+    gitRepositoryStatus,
   )
 where
 
@@ -65,18 +68,12 @@ data Repository = Repository
   }
 
 data GitRepositoryStatus
-  = GitRepositoryCreated
-  | GitRepositoryExisting
+  = GitDirectoryMissing
+  | GitDirectoryEmpty
+  | GitDirectoryInitialized
 
-ensureGitRepositoryWithRemote :: Repository -> IO (Either GitError GitRepositoryStatus)
-ensureGitRepositoryWithRemote repo = do
-  let 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
+gitRepositoryStatus :: Repository -> IO GitRepositoryStatus
+gitRepositoryStatus repo = do
   exists <- D.doesDirectoryExist $ repositoryRoot repo
   if exists
     then D.withCurrentDirectory (repositoryRoot repo) $ do
@@ -85,37 +82,64 @@ ensureGitRepositoryWithRemote repo = do
       let out = filter (not . null) $ lines checkStdout
       case checkStatus of
         ExitSuccess
-          | not (null out) && head out == "true" -> do
-              _ <- runGit ["remote", "add", "origin", repositoryUrl repo] -- can fail if it exists
-              (setUrlCmd, setUrlStatus, setUrlStdout, setUrlStderr) <-
-                runGit ["remote", "set-url", "origin", repositoryUrl repo]
-              return $
-                if setUrlStatus /= ExitSuccess
-                  then Left $ GitError setUrlCmd $ GitProcessError setUrlStatus setUrlStdout setUrlStderr
-                  else Right GitRepositoryExisting
+          | not (null out) && head out == "true" ->
+              return GitDirectoryInitialized
         _ ->
-          clone
-    else clone
+          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) $ do
-    (fetchAllCmd, fetchAllStatus, fetchAllStdout, fetchAllStderr) <-
-      runGit ["fetch", "--all"]
-    if fetchAllStatus /= ExitSuccess
-      then return $ Left $ GitError fetchAllCmd $ GitProcessError fetchAllStatus fetchAllStdout fetchAllStderr
+    _ <- runGit ["remote", "add", "origin", repositoryUrl repo] -- can fail if it exists
+    (setUrlCmd, setUrlStatus, setUrlStdout, setUrlStderr) <-
+      runGit ["remote", "set-url", "origin", repositoryUrl repo]
+    if setUrlStatus /= ExitSuccess
+      then return $ Left $ GitError setUrlCmd $ GitProcessError setUrlStatus setUrlStdout setUrlStderr
       else do
-        (checkoutBranchCmd, checkoutBranchStatus, checkoutBranchStdout, checkoutBranchStderr) <-
-          runGit ["checkout", repositoryBranch repo]
-        if checkoutBranchStatus /= ExitSuccess
-          then return $ Left $ GitError checkoutBranchCmd $ GitProcessError checkoutBranchStatus checkoutBranchStdout checkoutBranchStderr
+        (fetchAllCmd, fetchAllStatus, fetchAllStdout, fetchAllStderr) <-
+          runGit ["fetch", "--all"]
+        if fetchAllStatus /= ExitSuccess
+          then
+            return $ Left $ GitError fetchAllCmd $ GitProcessError fetchAllStatus fetchAllStdout fetchAllStderr
           else do
-            (resetCmd, resetStatus, resetStdout, resetStderr) <-
-              runGit ["reset", "--hard", "origin/" <> repositoryBranch repo]
-            return $
-              if resetStatus /= ExitSuccess
-                then Left $ GitError resetCmd $ GitProcessError resetStatus resetStdout resetStderr
-                else Right ()
+            (checkoutBranchCmd, checkoutBranchStatus, checkoutBranchStdout, checkoutBranchStderr) <-
+              runGit ["checkout", repositoryBranch repo]
+            if checkoutBranchStatus /= ExitSuccess
+              then
+                return $ Left $ GitError checkoutBranchCmd $ GitProcessError checkoutBranchStatus checkoutBranchStdout checkoutBranchStderr
+              else do
+                (resetCmd, resetStatus, resetStdout, resetStderr) <-
+                  runGit ["reset", "--hard", "origin/" <> repositoryBranch repo]
+                return $
+                  if resetStatus /= ExitSuccess
+                    then Left $ GitError resetCmd $ GitProcessError resetStatus resetStdout resetStderr
+                    else Right ()
 
 newtype GitDirectoryInfo = GitDirectoryInfo
   { lastModificationCommitDate :: ZonedTime

code/hsec-sync/test/Spec/SyncSpec.hs

@@ -20,36 +20,49 @@ spec =
     [ testGroup
         "sync"
         [ testCase "Invalid root should fail" $ do
-            result <- sync $ withRepositoryAt "/x/y/z"
-            first (const ("<Redacted error>" :: String)) result @?= Left "<Redacted error>",
+            let repo = withRepositoryAt "/dev/advisories"
+            status repo >>= (@?= DirectoryMissing)
+            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
-              result <- sync $ withRepositoryAt $ p </> "repo"
-              result @?= Right Created,
+              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"
-              result <- sync $ withRepositoryAt $ 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
-              resultCreate <- sync $ withRepositoryAt p
+              let repo = withRepositoryAt p
+              status repo >>= (@?= DirectoryEmpty)
+              resultCreate <- sync repo
               resultCreate @?= Right Created
-              resultResync <- sync $ withRepositoryAt p
+              resultResync <- sync repo
               resultResync @?= Right AlreadyUpToDate,
           testCase "Sync behind should update" $
             withSystemTempDirectory "hsec-sync" $ \p -> do
-              resultCreate <- sync $ withRepositoryAt p
+              let repo = withRepositoryAt p
+              resultCreate <- sync repo
               resultCreate @?= Right Created
               D.withCurrentDirectory p $ do
-                (status, _, _) <-
+                (statusReset, _, _) <-
                   readProcessWithExitCode "git" ["reset", "--hard", "HEAD~50"] ""
-                status @?= ExitSuccess
-              resultResync <- sync $ withRepositoryAt p
-              resultResync @?= Right Updated,
+                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
-              resultCreate <- sync $ withRepositoryAt p
+              let repo = withRepositoryAt p
+              resultCreate <- sync repo
               resultCreate @?= Right Created
               D.withCurrentDirectory p $ do
                 (statusReset, _, _) <-
@@ -58,7 +71,7 @@ spec =
                 (statusRemote, _, _) <-
                   readProcessWithExitCode "git" ["remote", "rename", "origin", "old"] ""
                 statusRemote @?= ExitSuccess
-              resultResync <- sync $ withRepositoryAt p
+              resultResync <- sync repo
               resultResync @?= Right Updated
         ]
     ]