packages feed

feed-gipeda 0.3.0.0 → 0.3.0.1

raw patch · 2 files changed

+54/−29 lines, 2 files

Files

feed-gipeda.cabal view
@@ -1,5 +1,5 @@ name:                feed-gipeda-version:             0.3.0.0+version:             0.3.0.1 synopsis:            CI service around gipeda description:   A service for easy handling of multiple repositories with
src/FeedGipeda/GitShell.hs view
@@ -14,47 +14,74 @@   ) where  -import           Data.Char        (isSpace)+import           Control.Monad      (void)+import           Data.Char          (isSpace) import           Data.Functor-import           Data.Maybe       (listToMaybe)-import           Data.Set         (Set)-import qualified Data.Set         as Set-import           FeedGipeda.Repo  (Repo)-import qualified FeedGipeda.Repo  as Repo-import           System.Directory (createDirectoryIfMissing)-import           System.Exit      (ExitCode (..))-import           System.Process   (callProcess, readProcessWithExitCode)+import           Data.Maybe         (listToMaybe)+import           Data.Set           (Set)+import qualified Data.Set           as Set+import           FeedGipeda.Prelude+import           FeedGipeda.Repo    (Repo)+import qualified FeedGipeda.Repo    as Repo+import           System.Directory   (createDirectoryIfMissing)+import           System.Exit        (ExitCode (..))+import           System.Process     (readProcessWithExitCode,+                                     showCommandForUser)   type SHA   = String  +formatGitArgs :: Maybe FilePath -> String -> [String] -> [String]+formatGitArgs local command args =+  case local of+    Nothing -> command : args+    Just l -> ["-C", l, command] ++ args+++git :: Maybe FilePath -> String -> [String] -> IO (ExitCode, String, String)+git local command args =+  readProcessWithExitCode "git" (formatGitArgs local command args) ""+++gitLoggingErrors :: Maybe FilePath -> String -> [String] -> IO (Maybe String)+gitLoggingErrors repo command args = do+  (exitCode, stdout, stderr) <- git repo command args+  case exitCode of+    ExitSuccess -> return (Just stdout)+    ExitFailure code -> do+      logWarn (showCommandForUser "git" (formatGitArgs repo command args))+      logWarn "stdout:"+      logWarn stdout+      logWarn "stderr:"+      logWarn stderr+      return Nothing++ isRepositoryRoot :: FilePath -> IO Bool isRepositoryRoot path = do-  (_, stdout, _)  <- readProcessWithExitCode-    "git" ["-C", path, "rev-parse", "--git-dir"] ""+  (_, stdout, _)<- git (Just path) "rev-parse" ["--git-dir"]   -- testing for ".git" and "." (bare repo) should be good enough.   (return . maybe False (`elem` [".git", "."]) . listToMaybe . lines) stdout   mirror :: Repo -> FilePath -> IO ()-mirror repo path = do-  (_, _, _)  <- readProcessWithExitCode-    "git" ["clone", "--mirror", "--quiet", Repo.uri repo, path] ""-  return ()+mirror repo path =+  void (gitLoggingErrors Nothing "clone" ["--mirror", "--quiet", Repo.uri repo, path])   remoteRepo :: FilePath -> IO Repo remoteRepo path = do-  (_, stdout, _)  <- readProcessWithExitCode-    "git" ["-C", path, "ls-remote", "--get-url", "origin"] ""-  return (Repo.unsafeFromString (init stdout)) -- strip the \n with init+  ret <- gitLoggingErrors (Just path) "ls-remote" ["--get-url", "origin"]+  case ret of+    Nothing -> return (Repo.unsafeFromString "https://error.org/err") -- If this ever happens, all bets are off+    Just stdout -> return (Repo.unsafeFromString (init stdout)) -- strip the \n with init   fetch :: FilePath -> IO () fetch path =-  callProcess "git" ["-C", path, "fetch", "--quiet"]+  void (gitLoggingErrors (Just path) "fetch" ["--quiet"])   {-| @sync repo@ tries to fetch updates from the remote @repo@ or creates a@@ -82,18 +109,16 @@   showHead :: FilePath -> FilePath -> IO (Maybe String)-showHead path file = do-  let-    allArgs = ["-C", path, "show", "HEAD:" ++ file]-  (exitCode, stdout, stderr) <- readProcessWithExitCode "git" allArgs ""+showHead repo file = do+  (exitCode, stdout, stderr) <- git (Just repo) "show" ["HEAD:" ++ file]   case exitCode of     ExitSuccess -> return (Just stdout)     ExitFailure _ -> return Nothing   gitLogImpl :: FilePath -> [String] -> IO [SHA]-gitLogImpl path additionalArgs = do-  let-    allArgs = ["-C", path, "log", "--format=format:%H"] ++ additionalArgs-  (_, stdout, _) <- readProcessWithExitCode "git" allArgs ""-  return (filter (not . null) (lines stdout))+gitLogImpl path args = do+  ret <- gitLoggingErrors (Just path) "log" ("--format=format:%H" : args)+  case ret of+    Nothing -> return []+    Just stdout -> return (filter (not . null) (lines stdout))