summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Command/Uninit.hs2
-rw-r--r--Command/Unused.hs2
-rw-r--r--Git/Branch.hs8
-rw-r--r--Git/Command.hs32
-rw-r--r--Git/Ref.hs4
-rw-r--r--Utility/Process.hs6
6 files changed, 36 insertions, 18 deletions
diff --git a/Command/Uninit.hs b/Command/Uninit.hs
index 46a2480e6..6ac3e1216 100644
--- a/Command/Uninit.hs
+++ b/Command/Uninit.hs
@@ -32,7 +32,7 @@ check = do
error "can only run uninit from the top of the git repository"
where
current_branch = Git.Ref . Prelude.head . lines <$> revhead
- revhead = inRepo $ Git.Command.pipeRead
+ revhead = inRepo $ Git.Command.pipeReadStrict
[Params "rev-parse --abbrev-ref HEAD"]
seek :: [CommandSeek]
diff --git a/Command/Unused.hs b/Command/Unused.hs
index 91b21afa5..6fb8f36c6 100644
--- a/Command/Unused.hs
+++ b/Command/Unused.hs
@@ -251,7 +251,7 @@ withKeysReferencedInGit a = do
rs <- relevantrefs <$> showref
forM_ rs (withKeysReferencedInGitRef a)
where
- showref = inRepo $ Git.Command.pipeRead [Param "show-ref"]
+ showref = inRepo $ Git.Command.pipeReadStrict [Param "show-ref"]
relevantrefs = map (Git.Ref . snd) .
nubBy uniqref .
filter ourbranches .
diff --git a/Git/Branch.hs b/Git/Branch.hs
index f73ae5e2a..3407845d1 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -27,7 +27,7 @@ current r = do
case v of
Nothing -> return Nothing
Just branch ->
- ifM (null <$> pipeRead [Param "show-ref", Param $ show branch] r)
+ ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show branch] r)
( return Nothing
, return v
)
@@ -35,7 +35,7 @@ current r = do
{- The current branch, which may not really exist yet. -}
currentUnsafe :: Repo -> IO (Maybe Git.Ref)
currentUnsafe r = parse . firstLine
- <$> pipeRead [Param "symbolic-ref", Param "HEAD"] r
+ <$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r
where
parse l
| null l = Nothing
@@ -48,7 +48,7 @@ changed origbranch newbranch repo
| origbranch == newbranch = return False
| otherwise = not . null <$> diffs
where
- diffs = pipeRead
+ diffs = pipeReadStrict
[ Param "log"
, Param (show origbranch ++ ".." ++ show newbranch)
, Params "--oneline -n1"
@@ -93,7 +93,7 @@ fastForward branch (first:rest) repo =
commit :: String -> Branch -> [Ref] -> Repo -> IO Sha
commit message branch parentrefs repo = do
tree <- getSha "write-tree" $
- pipeRead [Param "write-tree"] repo
+ pipeReadStrict [Param "write-tree"] repo
sha <- getSha "commit-tree" $ pipeWriteRead
(map Param $ ["commit-tree", show tree] ++ ps)
message repo
diff --git a/Git/Command.hs b/Git/Command.hs
index 687f6802c..71579808b 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -43,14 +43,27 @@ run subcommand params repo = assertLocal repo $
- Note that this leaves the git process running, and so zombies will
- result unless reap is called.
-}
-pipeRead :: [CommandParam] -> Repo -> IO String
-pipeRead params repo = assertLocal repo $
+pipeReadLazy :: [CommandParam] -> Repo -> IO String
+pipeReadLazy params repo = assertLocal repo $
withHandle StdoutHandle createBackgroundProcess p $ \h -> do
fileEncoding h
hGetContents h
where
- p = (proc "git" $ toCommand $ gitCommandLine params repo)
- { env = gitEnv repo }
+ p = gitCreateProcess params repo
+
+{- Runs a git subcommand, and returns its output, strictly.
+ -
+ - Nonzero exit status is ignored.
+ -}
+pipeReadStrict :: [CommandParam] -> Repo -> IO String
+pipeReadStrict params repo = assertLocal repo $
+ withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do
+ fileEncoding h
+ output <- hGetContentsStrict h
+ hClose h
+ return output
+ where
+ p = gitCreateProcess params repo
{- Runs a git subcommand, feeding it input, and returning its output,
- which is expected to be fairly small, since it's all read into memory
@@ -62,16 +75,19 @@ pipeWriteRead params s repo = assertLocal repo $
{- Runs a git subcommand, feeding it input on a handle with an action. -}
pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()
-pipeWrite params repo = withHandle StdinHandle createProcessSuccess p
- where
- p = (proc "git" $ toCommand $ gitCommandLine params repo)
+pipeWrite params repo = withHandle StdinHandle createProcessSuccess $
+ gitCreateProcess params repo
+
+gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess
+gitCreateProcess params repo =
+ (proc "git" $ toCommand $ gitCommandLine params repo)
{ env = gitEnv repo }
{- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it. -}
pipeNullSplit :: [CommandParam] -> Repo -> IO [String]
pipeNullSplit params repo =
- filter (not . null) . split sep <$> pipeRead params repo
+ filter (not . null) . split sep <$> pipeReadLazy params repo
where
sep = "\0"
diff --git a/Git/Ref.hs b/Git/Ref.hs
index cfaafacef..6fec46c22 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -41,7 +41,7 @@ exists ref = runBool "show-ref"
sha :: Branch -> Repo -> IO (Maybe Sha)
sha branch repo = process <$> showref repo
where
- showref = pipeRead [Param "show-ref",
+ showref = pipeReadStrict [Param "show-ref",
Param "--hash", -- get the hash
Param $ show branch]
process [] = Nothing
@@ -50,7 +50,7 @@ sha branch repo = process <$> showref repo
{- List of (refs, branches) matching a given ref spec. -}
matching :: Ref -> Repo -> IO [(Ref, Branch)]
matching ref repo = map gen . lines <$>
- pipeRead [Param "show-ref", Param $ show ref] repo
+ pipeReadStrict [Param "show-ref", Param $ show ref] repo
where
gen l = let (r, b) = separate (== ' ') l in
(Ref r, Ref b)
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 839cc4078..b47807921 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -116,8 +116,10 @@ checkSuccessProcess pid = do
code <- waitForProcess pid
return $ code == ExitSuccess
-ignoreFailureProcess :: ProcessHandle -> IO ()
-ignoreFailureProcess = void . waitForProcess
+ignoreFailureProcess :: ProcessHandle -> IO Bool
+ignoreFailureProcess pid = do
+ void $ waitForProcess pid
+ return True
{- Runs createProcess, then an action on its handles, and then
- forceSuccessProcess. -}