switch from System.Cmd.Utils to System.Process

Test suite now passes with -threaded!

I traced back all the hangs with -threaded to System.Cmd.Utils. It seems
it's just crappy/unsafe/outdated, and should not be used. System.Process
seems to be the cool new thing, so converted all the code to use it
instead.

In the process, --debug stopped printing commands it runs. I may try to
bring that back later.

Note that even SafeSystem was switched to use System.Process. Since that
was a modified version of code from System.Cmd.Utils, it needed to be
converted too. I also got rid of nearly all calls to forkProcess,
and all calls to executeFile, which I'm also doubtful about working
well with -threaded.

8 files changed, 33 insertions, 57 deletions

diff --git a/Git/Branch.hs b/Git/Branch.hs
index 6f3d25186..4d239d8fc 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -76,9 +76,7 @@ commit message branch parentrefs repo = do
 	sha <- getSha "commit-tree" $ pipeWriteRead
 		(map Param $ ["commit-tree", show tree] ++ ps)
 		message repo
-	print ("got", sha)
 	run "update-ref" [Param $ show branch, Param $ show sha] repo
-	print ("update-ref done", sha)
 	return sha
 	where
 		ps = concatMap (\r -> ["-p", show r]) parentrefs
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index e8f362685..e667b2087 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -50,16 +50,11 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha))
 catObjectDetails h object = CoProcess.query h send receive
 	where
 		send to = do
-			putStrLn "catObjectDetails send start"
 			fileEncoding to
 			hPutStrLn to $ show object
-			putStrLn $ "catObjectDetails send done " ++ show object
 		receive from = do
-			putStrLn "catObjectDetails read header start"
 			fileEncoding from
-			putStrLn "catObjectDetails read header start2"
 			header <- hGetLine from
-			putStrLn "catObjectDetails read header done"
 			case words header of
 				[sha, objtype, size]
 					| length sha == shaSize &&
@@ -72,14 +67,9 @@ catObjectDetails h object = CoProcess.query h send receive
 					| header == show object ++ " missing" -> dne
 					| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
 		readcontent bytes from sha = do
-			putStrLn "readcontent start"
 			content <- S.hGet from bytes
-			putStrLn "readcontent end"
 			c <- hGetChar from
-			putStrLn "readcontent newline read"
 			when (c /= '\n') $
 				error "missing newline from git cat-file"
 			return $ Just (L.fromChunks [content], Ref sha)
-		dne = do
-			putStrLn "dne"
-			return Nothing
+		dne = return Nothing
diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs
index 7636ea641..6b321f8b8 100644
--- a/Git/CheckAttr.hs
+++ b/Git/CheckAttr.hs
@@ -44,15 +44,11 @@ checkAttr (h, attrs, cwd) want file = do
 		_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
 	where
 		send to = do
-			putStrLn "checkAttr send start"
 			fileEncoding to
 			hPutStr to $ file' ++ "\0"
-			putStrLn "checkAttr send end"
 		receive from = forM attrs $ \attr -> do
-			putStrLn "checkAttr receive start"
 			fileEncoding from
 			l <- hGetLine from
-			putStrLn "checkAttr receive end"
 			return (attr, attrvalue attr l)
 		{- Before git 1.7.7, git check-attr worked best with
 		 - absolute filenames; using them worked around some bugs
diff --git a/Git/Command.hs b/Git/Command.hs
index 9a09300e2..038824f26 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -7,10 +7,8 @@
 
 module Git.Command where
 
-import qualified Data.Text.Lazy as L
-import qualified Data.Text.Lazy.IO as L
-import Control.Concurrent
-import Control.Exception (finally)
+import System.Process
+import System.Posix.Process (getAnyProcessStatus)
 
 import Common
 import Git
@@ -44,31 +42,18 @@ run subcommand params repo = assertLocal repo $
  -}
 pipeRead :: [CommandParam] -> Repo -> IO String
 pipeRead params repo = assertLocal repo $ do
-	(_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo
+	(_, Just h, _, _) <- createProcess
+		(proc "git" $ toCommand $ gitCommandLine params repo)
+			{ std_out = CreatePipe }
 	fileEncoding h
 	hGetContents h
 
-{- Runs a git subcommand, feeding it input.
- - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
-pipeWrite :: [CommandParam] -> L.Text -> Repo -> IO PipeHandle
-pipeWrite params s repo = assertLocal repo $ do
-	(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)
-	L.hPutStr h s
-	hClose h
-	return p
-
 {- 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
  - strictly. -}
 pipeWriteRead :: [CommandParam] -> String -> Repo -> IO String
-pipeWriteRead params s repo = assertLocal repo $ do
-	(p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo)
-	fileEncoding to
-	fileEncoding from
-	_ <- forkIO $ finally (hPutStr to s) (hClose to)
-	c <- hGetContentsStrict from
-	forceSuccess p
-	return c
+pipeWriteRead params s repo = assertLocal repo $
+	readProcess "git" (toCommand $ gitCommandLine params repo) s
 
 {- Reads null terminated output of a git command (as enabled by the -z 
  - parameter), and splits it. -}
diff --git a/Git/Config.hs b/Git/Config.hs
index c9e4f9a2d..234750113 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -9,6 +9,7 @@ module Git.Config where
 
 import qualified Data.Map as M
 import Data.Char
+import System.Process
 
 import Common
 import Git
@@ -39,7 +40,7 @@ reRead :: Repo -> IO Repo
 reRead = read'
 
 {- Cannot use pipeRead because it relies on the config having been already
- - read. Instead, chdir to the repo.
+ - read. Instead, chdir to the repo and run git config.
  -}
 read' :: Repo -> IO Repo
 read' repo = go repo
@@ -47,9 +48,14 @@ 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 = bracketCd d $
-			pOpen ReadFromPipe "git" ["config", "--null", "--list"] $
-				hRead repo
+		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"]
 
 {- 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 ddcf13519..4e6f05c2e 100644
--- a/Git/Queue.hs
+++ b/Git/Queue.hs
@@ -19,7 +19,7 @@ module Git.Queue (
 
 import qualified Data.Map as M
 import System.IO
-import System.Cmd.Utils
+import System.Process
 import Data.String.Utils
 
 import Utility.SafeCommand
@@ -148,11 +148,14 @@ runAction :: Repo -> Action -> IO ()
 runAction repo (UpdateIndexAction streamers) =
 	-- list is stored in reverse order
 	Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
-runAction repo action@(CommandAction {}) =
-	pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
+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
 	where
-		params = toCommand $ gitCommandLine
+		params = "-0":"git":baseparams
+		baseparams = toCommand $ gitCommandLine
 			(Param (getSubcommand action):getParams action) repo
-		feedxargs h = do
-			fileEncoding h
-			hPutStr h $ join "\0" $ getFiles action
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 3052d0a6e..ee2f02187 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -40,10 +40,7 @@ exists ref = runBool "show-ref"
 
 {- Get the sha of a fully qualified git ref, if it exists. -}
 sha :: Branch -> Repo -> IO (Maybe Sha)
-sha branch repo = do
-	r <- process <$> showref repo
-	print r
-	return r
+sha branch repo = process <$> showref repo
 	where
 		showref = pipeRead [Param "show-ref",
 			Param "--hash", -- get the hash
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index abdc4bcbe..6de0c3ada 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -17,7 +17,7 @@ module Git.UpdateIndex (
 	stageSymlink
 ) where
 
-import System.Cmd.Utils
+import System.Process
 
 import Common
 import Git
@@ -37,12 +37,13 @@ pureStreamer !s = \streamer -> streamer s
 {- Streams content into update-index from a list of Streamers. -}
 streamUpdateIndex :: Repo -> [Streamer] -> IO ()
 streamUpdateIndex repo as = do
-	(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)
+	(Just h, _, _, p) <- createProcess (proc "git" ps) { std_in = CreatePipe }
 	fileEncoding h
 	forM_ as (stream h)
 	hClose h
-	forceSuccess p
+	forceSuccessProcess p "git" ps
 	where
+		ps = toCommand $ gitCommandLine params repo
 		params = map Param ["update-index", "-z", "--index-info"]
 		stream h a = a (streamer h)
 		streamer h s = do