add back debug logging

Make Utility.Process wrap the parts of System.Process that I use,
and add debug logging to them.

Also wrote some higher-level code that allows running an action
with handles to a processes stdin or stdout (or both), and checking
its exit status, all in a single function call.

As a bonus, the debug logging now indicates whether the process
is being run to read from it, feed it data, chat with it (writing and
reading), or just call it for its side effect.

4 files changed, 22 insertions, 32 deletions

diff --git a/Git/Command.hs b/Git/Command.hs
index 038824f26..d7c983064 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -7,7 +7,6 @@
 
 module Git.Command where
 
-import System.Process
 import System.Posix.Process (getAnyProcessStatus)
 
 import Common
@@ -41,12 +40,12 @@ run subcommand params repo = assertLocal repo $
  - result unless reap is called.
  -}
 pipeRead :: [CommandParam] -> Repo -> IO String
-pipeRead params repo = assertLocal repo $ do
-	(_, Just h, _, _) <- createProcess
-		(proc "git" $ toCommand $ gitCommandLine params repo)
-			{ std_out = CreatePipe }
-	fileEncoding h
-	hGetContents h
+pipeRead params repo = assertLocal repo $
+	withHandle StdoutHandle createBackgroundProcess p $ \h -> do
+		fileEncoding h
+		hGetContents h
+	where
+		p  = proc "git" $ toCommand $ gitCommandLine 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
diff --git a/Git/Config.hs b/Git/Config.hs
index 234750113..c82d6bb1b 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -9,7 +9,7 @@ module Git.Config where
 
 import qualified Data.Map as M
 import Data.Char
-import System.Process
+import System.Process (cwd)
 
 import Common
 import Git
@@ -48,14 +48,11 @@ read' repo = go repo
 		go Repo { location = Local { gitdir = d } } = git_config d
 		go Repo { location = LocalUnknown d } = git_config d
 		go _ = assertLocal repo $ error "internal"
-		git_config d = do
-			(_, Just h, _, pid)
-				<- createProcess (proc "git" params)
-					{ std_out = CreatePipe, cwd = Just d }
-			repo' <- hRead repo h
-			forceSuccessProcess pid "git" params
-			return repo'
-		params = ["config", "--null", "--list"]
+		git_config d = withHandle StdoutHandle createProcessSuccess p $
+			hRead repo
+			where
+				params = ["config", "--null", "--list"]
+				p = (proc "git" params) { cwd = Just d }
 
 {- Reads git config from a handle and populates a repo with it. -}
 hRead :: Repo -> Handle -> IO Repo
diff --git a/Git/Queue.hs b/Git/Queue.hs
index 4e6f05c2e..f515ad104 100644
--- a/Git/Queue.hs
+++ b/Git/Queue.hs
@@ -19,7 +19,6 @@ module Git.Queue (
 
 import qualified Data.Map as M
 import System.IO
-import System.Process
 import Data.String.Utils
 
 import Utility.SafeCommand
@@ -148,13 +147,11 @@ runAction :: Repo -> Action -> IO ()
 runAction repo (UpdateIndexAction streamers) =
 	-- list is stored in reverse order
 	Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
-runAction repo action@(CommandAction {}) = do
-	(Just h, _, _, pid) <- createProcess (proc "xargs" params)
-		{ std_in = CreatePipe }
-	fileEncoding h
-	hPutStr h $ join "\0" $ getFiles action
-	hClose h
-	forceSuccessProcess pid "xargs" params
+runAction repo action@(CommandAction {}) =
+	withHandle StdinHandle createProcessSuccess (proc "xargs" params) $ \h -> do
+		fileEncoding h
+		hPutStr h $ join "\0" $ getFiles action
+		hClose h
 	where
 		params = "-0":"git":baseparams
 		baseparams = toCommand $ gitCommandLine
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index 6de0c3ada..929448729 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -17,8 +17,6 @@ module Git.UpdateIndex (
 	stageSymlink
 ) where
 
-import System.Process
-
 import Common
 import Git
 import Git.Types
@@ -36,12 +34,11 @@ pureStreamer !s = \streamer -> streamer s
 
 {- Streams content into update-index from a list of Streamers. -}
 streamUpdateIndex :: Repo -> [Streamer] -> IO ()
-streamUpdateIndex repo as = do
-	(Just h, _, _, p) <- createProcess (proc "git" ps) { std_in = CreatePipe }
-	fileEncoding h
-	forM_ as (stream h)
-	hClose h
-	forceSuccessProcess p "git" ps
+streamUpdateIndex repo as =
+	withHandle StdinHandle createProcessSuccess (proc "git" ps) $ \h -> do
+		fileEncoding h
+		forM_ as (stream h)
+		hClose h
 	where
 		ps = toCommand $ gitCommandLine params repo
 		params = map Param ["update-index", "-z", "--index-info"]