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.

Remote/Bup.hs

@@ -152,14 +152,26 @@ bupSplitParams r buprepo k src =
 
 store :: Remote -> BupRepo -> Storer
 store r buprepo = byteStorer $ \k b p -> do
-	let params = bupSplitParams r buprepo k []
 	showOutput -- make way for bup output
-	let cmd = proc "bup" (toCommand params)
 	quiet <- commandProgressDisabled
-	let feeder = \h -> meteredWrite p h b
-	liftIO $ if quiet
-		then feedWithQuietOutput createProcessSuccess cmd feeder
-		else withHandle StdinHandle createProcessSuccess cmd feeder
+	liftIO $ withNullHandle $ \nullh ->
+		let params = bupSplitParams r buprepo k []
+		    cmd = (proc "bup" (toCommand params))
+			{ std_in = CreatePipe }
+		    cmd' = if quiet
+			then cmd 
+				{ std_out = UseHandle nullh
+				, std_err = UseHandle nullh
+				}
+			else cmd
+		    feeder = \h -> meteredWrite p h b
+		in withCreateProcess cmd' (go feeder cmd')
+  where
+	go feeder p (Just hin) _ _ pid =
+		forceSuccessProcess p pid
+			`after`
+		feeder hin
+	go _ _ _ _ _ _ = error "internal"
 
 retrieve :: BupRepo -> Retriever
 retrieve buprepo = byteRetriever $ \k sink -> do

Remote/Ddar.hs

@@ -1,11 +1,13 @@
 {- Using ddar as a remote. Based on bup and rsync remotes.
  -
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
  - Copyright 2014 Robie Basak <robie@justgohome.co.uk>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE BangPatterns #-}
+
 module Remote.Ddar (remote) where
 
 import qualified Data.Map as M
@@ -201,12 +203,18 @@ ddarDirectoryExists ddarrepo
 inDdarManifest :: DdarRepo -> Key -> Annex (Either String Bool)
 inDdarManifest ddarrepo k = do
 	(cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 't' []
-	let p = proc cmd $ toCommand params
-	liftIO $ catchMsgIO $ withHandle StdoutHandle createProcessSuccess p $ \h -> do
-		contents <- hGetContents h
-		return $ elem k' $ lines contents
+	let p = (proc cmd $ toCommand params)
+		{ std_out = CreatePipe }
+	liftIO $ catchMsgIO $ withCreateProcess p (go p)
   where
 	k' = serializeKey k
+	
+	go p _ (Just hout) _ pid = do
+		contents <- hGetContents hout
+		let !r = elem k' (lines contents)
+		forceSuccessProcess p pid
+		return r
+	go _ _ _ _ _ = error "internal"
 
 checkKey :: DdarRepo -> CheckPresent
 checkKey ddarrepo key = do

Remote/Git.hs

@@ -834,7 +834,7 @@ commitOnCleanup repo r st a = go `after` a
 		| not $ Git.repoIsUrl repo = onLocalFast st $
 			doQuietSideAction $
 				Annex.Branch.commit =<< Annex.Branch.commitMessage
-		| otherwise = void $ do
+		| otherwise = do
 			Just (shellcmd, shellparams) <-
 				Ssh.git_annex_shell NoConsumeStdin
 					repo "commit" [] []
@@ -842,10 +842,13 @@ commitOnCleanup repo r st a = go `after` a
 			-- Throw away stderr, since the remote may not
 			-- have a new enough git-annex shell to
 			-- support committing.
-			liftIO $ catchMaybeIO $
-				withQuietOutput createProcessSuccess $
-					proc shellcmd $
-						toCommand shellparams
+			liftIO $ void $ catchMaybeIO $ withNullHandle $ \nullh ->
+				let p = (proc shellcmd (toCommand shellparams))
+					{ std_out = UseHandle nullh
+					, std_err = UseHandle nullh
+					}
+				in withCreateProcess p $ \_ _ _ ->
+					forceSuccessProcess p
 
 wantHardLink :: Annex Bool
 wantHardLink = (annexHardLink <$> Annex.getGitConfig)

Remote/Glacier.hs

@@ -162,10 +162,15 @@ store' r k b p = go =<< glacierEnv c gc u
 		, Param "-"
 		]
 	go Nothing = giveup "Glacier not usable."
-	go (Just e) = liftIO $ do
+	go (Just e) =
 		let cmd = (proc "glacier" (toCommand params)) { env = Just e }
-		withHandle StdinHandle createProcessSuccess cmd $ \h ->
-			meteredWrite p h b
+			{ std_in = CreatePipe }
+		in liftIO $ withCreateProcess cmd (go' cmd)
+	go' cmd (Just hin) _ _ pid =
+		forceSuccessProcess cmd pid
+			`after`
+		meteredWrite p hin b
+	go' _ _ _ _ _ = error "internal"
 
 retrieve :: Remote -> Retriever
 retrieve = byteRetriever . retrieve'
@@ -353,5 +358,10 @@ checkSaneGlacierCommand =
 		giveup wrongcmd
   where
 	test = proc "glacier" ["--compatibility-test-git-annex"]
-	shouldfail = withQuietOutput createProcessSuccess test
+	shouldfail = withNullHandle $ \nullh ->
+		let p = test
+			{ std_out = UseHandle nullh
+			, std_err = UseHandle nullh
+			}
+		in withCreateProcess p $ \_ _ _ -> forceSuccessProcess p
 	wrongcmd = "The glacier program in PATH seems to be from boto, not glacier-cli. Cannot use this program."

Remote/Rsync.hs

@@ -288,10 +288,12 @@ checkPresentGeneric o rsyncurls = do
 	-- note: Does not currently differentiate between rsync failing
 	-- to connect, and the file not being present.
 	untilTrue rsyncurls $ \u -> 
-		liftIO $ catchBoolIO $ do
-			withQuietOutput createProcessSuccess $
-				proc "rsync" $ toCommand $ opts ++ [Param u]
-			return True
+		liftIO $ catchBoolIO $ withNullHandle $ \nullh ->
+			let p = (proc "rsync" $ toCommand $ opts ++ [Param u])
+				{ std_out = UseHandle nullh
+				, std_err = UseHandle nullh
+				}
+			in withCreateProcess p $ \_ _ _ -> checkSuccessProcess
 
 storeExportM :: RsyncOpts -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
 storeExportM o src _k loc meterupdate =