convert to withCreateProcess for async exception safety

Not yet 100% done, so far I've grepped for waitForProcess and converted
everything that uses that to start the process with withCreateProcess.

Except for some things like P2P.IO and Assistant.TransferrerPool,
and Utility.CoProcess, that manage a pool of processes. See #2
in https://git-annex.branchable.com/todo/more_extensive_retries_to_mask_transient_failures/#comment-209f8a8c38e63fb3a704e1282cb269c7
for how those will need to be dealt with.

checkSuccessProcess, ignoreFailureProcess, and forceSuccessProcess calls waitForProcess, so
callers of them will also need to be dealt with, and have not been yet.

Annex/Init.hs

@@ -301,15 +301,14 @@ autoEnableSpecialRemotes = do
 	rp <- fromRawFilePath <$> fromRepo Git.repoPath
 	cmd <- liftIO programPath
 	liftIO $ withNullHandle $ \nullh -> do
-		let p = proc cmd 
+		let p = (proc cmd 
 			[ "init"
 			, "--autoenable"
-			]
-		(Nothing, Nothing, Nothing, pid) <- createProcess $ p
+			])
 			{ std_out = UseHandle nullh
 			, std_err = UseHandle nullh
 			, std_in = UseHandle nullh
 			, cwd = Just rp
 			}
-		void $ waitForProcess pid
+		withCreateProcess p $ \_ _ _ pid -> void $ waitForProcess pid
 	remotesChanged

Annex/Ssh.hs

@@ -258,19 +258,19 @@ prepSocket socketfile sshhost sshparams = do
 	-- (Except there's an unlikely false positive where a forced
 	-- ssh command exits 255.)
 	tryssh extraps = liftIO $ withNullHandle $ \nullh -> do
-		let p = proc "ssh" $ concat
+		let p = (proc "ssh" $ concat
 			[ extraps
 			, toCommand sshparams
 			, [fromSshHost sshhost, "true"]
-			]
-		(Nothing, Nothing, Nothing, pid) <- createProcess $ p
+			])
 			{ std_out = UseHandle nullh
 			, std_err = UseHandle nullh
 			}
-		exitcode <- waitForProcess pid
-		return $ case exitcode of
-			ExitFailure 255 -> False
-			_ -> True
+		withCreateProcess p $ \_ _ _ pid -> do
+			exitcode <- waitForProcess pid
+			return $ case exitcode of
+				ExitFailure 255 -> False
+				_ -> True
 
 {- Find ssh socket files.
  -
@@ -458,7 +458,8 @@ runSshOptions :: [String] -> String -> IO ()
 runSshOptions args s = do
 	let args' = toCommand (fromSshOptionsEnv s) ++ args
 	let p = proc "ssh" args'
-	exitWith =<< waitForProcess . processHandle =<< createProcess p
+	exitcode <- withCreateProcess p $ \_ _ _ pid -> waitForProcess pid
+	exitWith exitcode
 
 {- When this env var is set, git-annex is being used as a ssh-askpass
  - program, and should read the password from the specified location,

Command/WebApp.hs

@@ -220,14 +220,15 @@ openBrowser' mcmd htmlshim realurl outh errh =
 		hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url
 		hFlush stdout
 		environ <- cleanEnvironment
-		(_, _, _, pid) <- createProcess p
+		let p' = p
 			{ env = environ
 			, std_out = maybe Inherit UseHandle outh
 			, std_err = maybe Inherit UseHandle errh
 			}
-		exitcode <- waitForProcess pid
-		unless (exitcode == ExitSuccess) $
-			hPutStrLn (fromMaybe stderr errh) "failed to start web browser"
+		withCreateProcess p' $ \_ _ _ pid -> do
+			exitcode <- waitForProcess pid
+			unless (exitcode == ExitSuccess) $
+				hPutStrLn (fromMaybe stderr errh) "failed to start web browser"
 
 {- web.browser is a generic git config setting for a web browser program -}
 webBrowser :: Git.Repo -> Maybe FilePath

Git/GCrypt.hs

@@ -66,12 +66,12 @@ probeRepo loc baserepo = do
 		, Param "--check"
 		, Param loc
 		] baserepo
-	(_, _, _, pid) <- createProcess p
-	code <- waitForProcess pid
-	return $ case code of
-		ExitSuccess -> Decryptable
-		ExitFailure 1 -> NotDecryptable
-		ExitFailure _ -> NotEncrypted
+	withCreateProcess p $ \_ _ _ pid -> do
+		code <- waitForProcess pid
+		return $ case code of
+			ExitSuccess -> Decryptable
+			ExitFailure 1 -> NotDecryptable
+			ExitFailure _ -> NotEncrypted
 
 type GCryptId = String
 

Git/History.hs

@@ -50,19 +50,22 @@ data HistoryCommit = HistoryCommit
 {- Gets a History starting with the provided commit, and down to the
  - requested depth. -}
 getHistoryToDepth :: Integer -> Ref -> Repo -> IO (Maybe (History HistoryCommit))
-getHistoryToDepth n commit r = do
-	(_, Just inh, _, pid) <- createProcess (gitCreateProcess params r)
-		{ std_out = CreatePipe }
-	!h <- fmap (truncateHistoryToDepth n) 
-		. build Nothing 
-		. map parsehistorycommit
-		. map L.toStrict
-		. L8.lines
-		<$> L.hGetContents inh
-	hClose inh
-	void $ waitForProcess pid
-	return h
+getHistoryToDepth n commit r = withCreateProcess p go
   where
+	p = (gitCreateProcess params r)
+		{ std_out = CreatePipe }
+	go _ (Just inh) _ pid = do
+		!h <- fmap (truncateHistoryToDepth n) 
+			. build Nothing 
+			. map parsehistorycommit
+			. map L.toStrict
+			. L8.lines
+			<$> L.hGetContents inh
+		hClose inh
+		void $ waitForProcess pid
+		return h
+	go _ _ _ _ = error "internal"
+
 	build h [] = fmap (mapHistory fst) h
 	build _ (Nothing:_) = Nothing
 	build Nothing (Just v:rest) =

RemoteDaemon/Transport/Ssh.hs

@@ -37,14 +37,15 @@ transportUsingCmd cmd params rr@(RemoteRepo r gc) url h@(TransportHandle (LocalR
 
 transportUsingCmd' :: FilePath -> [CommandParam] -> Transport
 transportUsingCmd' cmd params (RemoteRepo r gc) url transporthandle ichan ochan =
-	robustConnection 1 $ do
-		(Just toh, Just fromh, Just errh, pid) <-
-			createProcess (proc cmd (toCommand params))
-			{ std_in = CreatePipe
-			, std_out = CreatePipe
-			, std_err = CreatePipe
-			}
-		
+	robustConnection 1 $ withCreateProcess p go
+  where
+	p = (proc cmd (toCommand params))
+		{ std_in = CreatePipe
+		, std_out = CreatePipe
+		, std_err = CreatePipe
+		}
+
+	go (Just toh) (Just fromh) (Just errh) pid = do
 		-- Run all threads until one finishes and get the status
 		-- of the first to finish. Cancel the rest.
 		status <- catchDefaultIO (Right ConnectionClosed) $
@@ -58,7 +59,8 @@ transportUsingCmd' cmd params (RemoteRepo r gc) url transporthandle ichan ochan
 		void $ waitForProcess pid
 
 		return $ either (either id id) id status
-  where
+	go _ _ _ _ = error "internal"
+
 	send msg = atomically $ writeTChan ochan msg
 
 	fetch = do

Test.hs

@@ -135,8 +135,8 @@ runner opts
 		pp <- Annex.Path.programPath
 		Utility.Env.Set.setEnv subenv "1" True
 		ps <- getArgs
-		(Nothing, Nothing, Nothing, pid) <- createProcess (proc pp ps)
-		exitcode <- waitForProcess pid
+		exitcode <- withCreateProcess (proc pp ps) $
+			\_ _ _ pid -> waitForProcess pid
 		unless (keepFailuresOption opts) finalCleanup
 		exitWith exitcode
 	runsubprocesstests (Just _) = isolateGitConfig $ do

Test/Framework.hs

@@ -458,9 +458,9 @@ setTestMode testmode = do
 		]
 runFakeSsh :: [String] -> IO ()
 runFakeSsh ("-n":ps) = runFakeSsh ps
-runFakeSsh (_host:cmd:[]) = do
-	(_, _, _, pid) <- createProcess (shell cmd)
-	exitWith =<< waitForProcess pid
+runFakeSsh (_host:cmd:[]) =
+	withCreateProcess (shell cmd) $
+		\_ _ _ pid -> exitWith =<< waitForProcess pid
 runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps
 
 getTestMode :: IO TestMode

Utility/Process/Transcript.hs

@@ -50,31 +50,28 @@ processTranscript'' cp input = do
 	System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True
 	readh <- System.Posix.IO.fdToHandle readf
 	writeh <- System.Posix.IO.fdToHandle writef
-	p@(_, _, _, pid) <- createProcess $ cp
-		{ std_in = if isJust input then CreatePipe else Inherit
-		, std_out = UseHandle writeh
-		, std_err = UseHandle writeh
-		}
-	hClose writeh
+	withCreateProcess cp $ \hin hout herr pid -> do
+		hClose writeh
 
-	get <- asyncreader readh
-	writeinput input p
-	transcript <- wait get
+		get <- asyncreader readh
+		writeinput input (hin, hout, herr, pid)
+		transcript <- wait get
 #else
 {- This implementation for Windows puts stderr after stdout. -}
-	p@(_, _, _, pid) <- createProcess $ cp
+	let cp' = cp 
 		{ std_in = if isJust input then CreatePipe else Inherit
 		, std_out = CreatePipe
 		, std_err = CreatePipe
 		}
-
-	getout <- asyncreader (stdoutHandle p)
-	geterr <- asyncreader (stderrHandle p)
-	writeinput input p
-	transcript <- (++) <$> wait getout <*> wait geterr
+	withCreateProcess cp' \hin hout herr pid -> do
+		let p = (hin, hout, herr, pid)
+		getout <- asyncreader (stdoutHandle p)
+		geterr <- asyncreader (stderrHandle p)
+		writeinput input p
+		transcript <- (++) <$> wait getout <*> wait geterr
 #endif
-	code <- waitForProcess pid
-	return (transcript, code)
+		code <- waitForProcess pid
+		return (transcript, code)
   where
 	asyncreader = async . hGetContentsStrict