convert to withCreateProcess for async exception safety

This handles all createProcessSuccess callers, and aside from process
pools, the complete conversion of all process running to async exception
safety should be complete now.

Also, was able to remove from Utility.Process the old API that I now
know was not a good idea. And proof it was bad: The code size went *down*,
despite there being a fair bit of boilerplate for some future API to
reduce.

Git/Command.hs

@@ -43,9 +43,13 @@ run params repo = assertLocal repo $
 
 {- Runs git and forces it to be quiet, throwing an error if it fails. -}
 runQuiet :: [CommandParam] -> Repo -> IO ()
-runQuiet params repo = withQuietOutput createProcessSuccess $
-	(proc "git" $ toCommand $ gitCommandLine (params) repo)
-		{ env = gitEnv repo }
+runQuiet params repo = withNullHandle $ \nullh ->
+	let p = (proc "git" $ toCommand $ gitCommandLine (params) repo)
+		{ env = gitEnv repo
+		, std_out = UseHandle nullh
+		, std_err = UseHandle nullh
+		}
+	in withCreateProcess p $ \_ _ _ -> forceSuccessProcess p
 
 {- Runs a git command and returns its output, lazily.
  -
@@ -99,9 +103,16 @@ pipeWriteRead params writer repo = assertLocal repo $
 
 {- Runs a git command, feeding it input on a handle with an action. -}
 pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()
-pipeWrite params repo = assertLocal repo $ 
-	withHandle StdinHandle createProcessSuccess $
-		gitCreateProcess params repo
+pipeWrite params repo a = assertLocal repo $
+	let p = (gitCreateProcess params repo)
+		{ std_in = CreatePipe }
+	in withCreateProcess p (go p)
+  where
+	go p (Just hin) _ _ pid = 
+		forceSuccessProcess p pid
+			`after`
+		a hin
+	go _ _ _ _ _ = error "internal"
 
 {- Reads null terminated output of a git command (as enabled by the -z 
  - parameter), and splits it. -}

Git/Config.hs

@@ -58,29 +58,37 @@ 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 = withHandle StdoutHandle createProcessSuccess p $
-		hRead repo ConfigNullList
+	git_config d = withCreateProcess p (git_config' p)
 	  where
 		params = ["config", "--null", "--list"]
 		p = (proc "git" params)
 			{ cwd = Just (fromRawFilePath d)
 			, env = gitEnv repo
+			, std_out = CreatePipe 
 			}
+	git_config' p _ (Just hout) _ pid = 
+		forceSuccessProcess p pid
+			`after`
+		hRead repo ConfigNullList hout
+	git_config' _ _ _ _ _ = error "internal"
 
 {- Gets the global git config, returning a dummy Repo containing it. -}
 global :: IO (Maybe Repo)
 global = do
 	home <- myHomeDir
 	ifM (doesFileExist $ home </> ".gitconfig")
-		( do
-			repo <- withHandle StdoutHandle createProcessSuccess p $
-				hRead (Git.Construct.fromUnknown) ConfigNullList
-			return $ Just repo
+		( Just <$> withCreateProcess p go
 		, return Nothing
 		)
   where
 	params = ["config", "--null", "--list", "--global"]
 	p = (proc "git" params)
+		{ std_out = CreatePipe }
+	go _ (Just hout) _ pid = 
+		forceSuccessProcess p pid
+			`after`
+		hRead (Git.Construct.fromUnknown) ConfigNullList hout
+	go _ _ _ _ = error "internal"
 
 {- Reads git config from a handle and populates a repo with it. -}
 hRead :: Repo -> ConfigStyle -> Handle -> IO Repo
@@ -200,16 +208,20 @@ coreBare = "core.bare"
  - and returns a repo populated with the configuration, as well as the raw
  - output and any standard output of the command. -}
 fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString))
-fromPipe r cmd params st = try $
-	withOEHandles createProcessSuccess p $ \(hout, herr) -> do
-		geterr <- async $ S.hGetContents herr
-		getval <- async $ S.hGetContents hout
-		val <- wait getval
-		err <- wait geterr
+fromPipe r cmd params st = try $ withCreateProcess p go
+  where
+	p = (proc cmd $ toCommand params)
+		{ std_out = CreatePipe
+		, std_err = CreatePipe
+		}
+	go _ (Just hout) (Just herr) pid = do
+		(val, err) <- concurrently 
+			(S.hGetContents hout)
+			(S.hGetContents herr)
+		forceSuccessProcess p pid
 		r' <- store val st r
 		return (r', val, err)
-  where
-	p = proc cmd $ toCommand params
+	go _ _ _ _ = error "internal"
 
 {- Reads git config from a specified file and returns the repo populated
  - with the configuration. -}

Git/Queue.hs

@@ -191,10 +191,11 @@ runAction repo (UpdateIndexAction streamers) =
 	liftIO $ Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
 runAction repo action@(CommandAction {}) = liftIO $ do
 #ifndef mingw32_HOST_OS
-	let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo }
-	withHandle StdinHandle createProcessSuccess p $ \h -> do
-		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action
-		hClose h
+	let p = (proc "xargs" $ "-0":"git":toCommand gitparams)
+		{ env = gitEnv repo
+		, std_in = CreatePipe
+		}
+	withCreateProcess p (go p)
 #else
 	-- Using xargs on Windows is problematic, so just run the command
 	-- once per file (not as efficient.)
@@ -206,6 +207,11 @@ runAction repo action@(CommandAction {}) = liftIO $ do
   where
 	gitparams = gitCommandLine
 		(Param (getSubcommand action):getParams action) repo
+	go p _ (Just h) _ pid = do
+		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action
+		hClose h
+		forceSuccessProcess p pid
+	go _ _ _ _ _ = error "internal"
 runAction repo action@(InternalAction {}) =
 	let InternalActionRunner _ runner = getRunner action
 	in runner repo (getInternalFiles action)