convert to withCreateProcess for async exception safety

This handles all sites where checkSuccessProcess/ignoreFailureProcess
is used, except for one: Git.Command.pipeReadLazy
That one will be significantly more work to convert to bracketing.

(Also skipped Command.Assistant.autoStart, but it does not need to
shut down the processes it started on exception because they are
git-annex assistant daemons..)

forceSuccessProcess is done, except for createProcessSuccess.
All call sites of createProcessSuccess will need to be converted
to bracketing.

(process pools still todo also)

Git/CatFile.hs

@@ -180,14 +180,16 @@ querySingle o r repo reader = assertLocal repo $
 			, std_in = Inherit
 			, std_out = CreatePipe
 			}
-		pid <- createProcess p'
-		let h = stdoutHandle pid
-		output <- reader h
-		hClose h
-		ifM (checkSuccessProcess (processHandle pid))
+		withCreateProcess p' go
+  where
+	go _ (Just outh) _ pid = do
+		output <- reader outh
+		hClose outh
+		ifM (checkSuccessProcess pid)
 			( return (Just output)
 			, return Nothing
 			)
+	go _ _ _ _ = error "internal"
 
 querySize :: Ref -> Repo -> IO (Maybe FileSize)
 querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n'))

Git/Command.hs

@@ -1,6 +1,6 @@
 {- running git commands
  -
- - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -70,13 +70,17 @@ pipeReadStrict = pipeReadStrict' S.hGetContents
 
 {- The reader action must be strict. -}
 pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a
-pipeReadStrict' reader params repo = assertLocal repo $
-	withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do
-		output <- reader h
-		hClose h
-		return output
+pipeReadStrict' reader params repo = assertLocal repo $ withCreateProcess p go
   where
-	p  = gitCreateProcess params repo
+	p  = (gitCreateProcess params repo)
+		{ std_out = CreatePipe }
+
+	go _ (Just outh) _ pid = do
+		output <- reader outh
+		hClose outh
+		void $ waitForProcess pid
+		return output
+	go _ _ _ _ = error "internal"
 
 {- Runs a git command, feeding it an input, and returning its output,
  - which is expected to be fairly small, since it's all read into memory

Git/Fsck.hs

@@ -77,27 +77,31 @@ findBroken batchmode r = do
 		then toBatchCommand (command, params)
 		else return (command, params)
 	
-	p@(_, _, _, pid) <- createProcess $
-		(proc command' (toCommand params'))
-			{ std_out = CreatePipe
-			, std_err = CreatePipe
-			}
-	(o1, o2) <- concurrently
-		(parseFsckOutput maxobjs r (stdoutHandle p))
-		(parseFsckOutput maxobjs r (stderrHandle p))
-	fsckok <- checkSuccessProcess pid
-	case mappend o1 o2 of
-		FsckOutput badobjs truncated
-			| S.null badobjs && not fsckok -> return FsckFailed
-			| otherwise -> return $ FsckFoundMissing badobjs truncated
-		NoFsckOutput
-			| not fsckok -> return FsckFailed
-			| otherwise -> return noproblem
-		-- If all fsck output was duplicateEntries warnings,
-		-- the repository is not broken, it just has some unusual
-		-- tree objects in it. So ignore nonzero exit status.
-		AllDuplicateEntriesWarning -> return noproblem
+	let p = (proc command' (toCommand params'))
+		{ std_out = CreatePipe
+		, std_err = CreatePipe
+		}
+	withCreateProcess p go
   where
+	go _ (Just outh) (Just errh) pid = do
+		(o1, o2) <- concurrently
+			(parseFsckOutput maxobjs r outh)
+			(parseFsckOutput maxobjs r errh)
+		fsckok <- checkSuccessProcess pid
+		case mappend o1 o2 of
+			FsckOutput badobjs truncated
+				| S.null badobjs && not fsckok -> return FsckFailed
+				| otherwise -> return $ FsckFoundMissing badobjs truncated
+			NoFsckOutput
+				| not fsckok -> return FsckFailed
+				| otherwise -> return noproblem
+			-- If all fsck output was duplicateEntries warnings,
+			-- the repository is not broken, it just has some
+			-- unusual tree objects in it. So ignore nonzero
+			-- exit status.
+			AllDuplicateEntriesWarning -> return noproblem
+	go _ _ _ _ = error "internal"
+	
 	maxobjs = 10000
 	noproblem = FsckFoundMissing S.empty False
 

Git/UpdateIndex.hs

@@ -136,15 +136,7 @@ indexPath = toInternalGitPath . getTopFilePath
 
 {- Refreshes the index, by checking file stat information.  -}
 refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool
-refreshIndex repo feeder = do
-	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
-		{ std_in = CreatePipe }
-	feeder $ \f -> do
-		hPutStr h f
-		hPutStr h "\0"
-	hFlush h
-	hClose h
-	checkSuccessProcess p
+refreshIndex repo feeder = withCreateProcess p go
   where
 	params = 
 		[ Param "update-index"
@@ -153,3 +145,15 @@ refreshIndex repo feeder = do
 		, Param "-z"
 		, Param "--stdin"
 		]
+	
+	p = (gitCreateProcess params repo)
+		{ std_in = CreatePipe }
+
+	go (Just h) _ _ pid = do
+		feeder $ \f -> do
+			hPutStr h f
+			hPutStr h "\0"
+		hFlush h
+		hClose h
+		checkSuccessProcess pid
+	go _ _ _ _ = error "internal"