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,15 +258,15 @@ 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
 			}
+		withCreateProcess p $ \_ _ _ pid -> do
 			exitcode <- waitForProcess pid
 			return $ case exitcode of
 				ExitFailure 255 -> False
@@ -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,11 +220,12 @@ 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
 			}
+		withCreateProcess p' $ \_ _ _ pid -> do
 			exitcode <- waitForProcess pid
 			unless (exitcode == ExitSuccess) $
 				hPutStrLn (fromMaybe stderr errh) "failed to start web browser"

Git/GCrypt.hs

@@ -66,7 +66,7 @@ probeRepo loc baserepo = do
 		, Param "--check"
 		, Param loc
 		] baserepo
-	(_, _, _, pid) <- createProcess p
+	withCreateProcess p $ \_ _ _ pid -> do
 		code <- waitForProcess pid
 		return $ case code of
 			ExitSuccess -> Decryptable

Git/History.hs

@@ -50,9 +50,11 @@ 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
+getHistoryToDepth n commit r = withCreateProcess p go
-	(_, Just inh, _, pid) <- createProcess (gitCreateProcess params r)
+  where
+	p = (gitCreateProcess params r)
 		{ std_out = CreatePipe }
+	go _ (Just inh) _ pid = do
 		!h <- fmap (truncateHistoryToDepth n) 
 			. build Nothing 
 			. map parsehistorycommit
@@ -62,7 +64,8 @@ getHistoryToDepth n commit r = do
 		hClose inh
 		void $ waitForProcess pid
 		return h
-  where
+	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
+	robustConnection 1 $ withCreateProcess p go
-		(Just toh, Just fromh, Just errh, pid) <-
+  where
-			createProcess (proc cmd (toCommand params))
+	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 <- withCreateProcess (proc pp ps) $
-		exitcode <- waitForProcess pid
+			\_ _ _ 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
+runFakeSsh (_host:cmd:[]) =
-	(_, _, _, pid) <- createProcess (shell cmd)
+	withCreateProcess (shell cmd) $
-	exitWith =<< waitForProcess pid
+		\_ _ _ pid -> exitWith =<< waitForProcess pid
 runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps
 
 getTestMode :: IO TestMode

Utility/Process/Transcript.hs

@@ -50,24 +50,21 @@ 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
+	withCreateProcess cp $ \hin hout herr pid -> do
-		{ std_in = if isJust input then CreatePipe else Inherit
-		, std_out = UseHandle writeh
-		, std_err = UseHandle writeh
-		}
 		hClose writeh
 
 		get <- asyncreader readh
-	writeinput input p
+		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
 		}
-
+	withCreateProcess cp' \hin hout herr pid -> do
+		let p = (hin, hout, herr, pid)
 		getout <- asyncreader (stdoutHandle p)
 		geterr <- asyncreader (stderrHandle p)
 		writeinput input p