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.

Annex/Ssh.hs

@@ -319,16 +319,19 @@ forceSshCleanup :: Annex ()
 forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
 
 forceStopSsh :: FilePath -> Annex ()
-forceStopSsh socketfile = do
+forceStopSsh socketfile = withNullHandle $ \nullh -> do
 	let (dir, base) = splitFileName socketfile
-	let params = sshConnectionCachingParams base
+	let p = (proc "ssh" $ toCommand $
-	-- "ssh -O stop" is noisy on stderr even with -q
-	void $ liftIO $ catchMaybeIO $
-		withQuietOutput createProcessSuccess $
-			(proc "ssh" $ toCommand $
 		[ Param "-O", Param "stop" ] ++ 
-				params ++ [Param "localhost"])
+		sshConnectionCachingParams base ++ 
-				{ cwd = Just dir }
+		[Param "localhost"])
+		{ cwd = Just dir
+		-- "ssh -O stop" is noisy on stderr even with -q
+		, std_out = UseHandle nullh
+		, std_err = UseHandle nullh
+		}
+	void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid ->
+		forceSuccessProcess p pid
 	liftIO $ nukeFile socketfile
 
 {- This needs to be as short as possible, due to limitations on the length

Assistant/Monad.hs

@@ -50,6 +50,9 @@ newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
 		Monad,
 		MonadIO,
 		MonadReader AssistantData,
+		MonadCatch,
+		MonadThrow,
+		MonadMask,
 		Fail.MonadFail,
 		Functor,
 		Applicative

COPYRIGHT

@@ -15,7 +15,7 @@ Copyright: © 2013 Joey Hess <id@joeyh.name>
 License: GPL-3+
 
 Files: Remote/Ddar.hs
-Copyright: © 2011 Joey Hess <id@joeyh.name>
+Copyright: © 2011-2020 Joey Hess <id@joeyh.name>
            © 2014 Robie Basak <robie@justgohome.co.uk>
 License: GPL-3+
 

Command/Map.hs

@@ -223,10 +223,16 @@ tryScan r
 	| otherwise = liftIO $ safely $ Git.Config.read r
   where
 	pipedconfig st pcmd params = liftIO $ safely $
-		withHandle StdoutHandle createProcessSuccess p $
+		withCreateProcess p (pipedconfig' st p)
-			Git.Config.hRead r st
 	  where
-		p = proc pcmd $ toCommand params
+		p = (proc pcmd $ toCommand params)
+			{ std_out = CreatePipe }
+
+	pipedconfig' st p _ (Just h) _ pid = 
+		forceSuccessProcess p pid
+			`after`
+		Git.Config.hRead r st h
+	pipedconfig' _ _ _ _ _ _ = error "internal"
 
 	configlist = Ssh.onRemote NoConsumeStdin r
 		(pipedconfig Git.Config.ConfigList, return Nothing) "configlist" [] []

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 $
+runQuiet params repo = withNullHandle $ \nullh ->
-	(proc "git" $ toCommand $ gitCommandLine (params) repo)
+	let p = (proc "git" $ toCommand $ gitCommandLine (params) repo)
-		{ env = gitEnv 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 $ 
+pipeWrite params repo a = assertLocal repo $
-	withHandle StdinHandle createProcessSuccess $
+	let p = (gitCreateProcess params repo)
-		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 $
+	git_config d = withCreateProcess p (git_config' p)
-		hRead repo ConfigNullList
 	  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
+		( Just <$> withCreateProcess p go
-			repo <- withHandle StdoutHandle createProcessSuccess p $
-				hRead (Git.Construct.fromUnknown) ConfigNullList
-			return $ Just repo
 		, 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 $
+fromPipe r cmd params st = try $ withCreateProcess p go
-	withOEHandles createProcessSuccess p $ \(hout, herr) -> do
+  where
-		geterr <- async $ S.hGetContents herr
+	p = (proc cmd $ toCommand params)
-		getval <- async $ S.hGetContents hout
+		{ std_out = CreatePipe
-		val <- wait getval
+		, std_err = CreatePipe
-		err <- wait geterr
+		}
+	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
+	go _ _ _ _ = error "internal"
-	p = proc cmd $ toCommand params
 
 {- 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 }
+	let p = (proc "xargs" $ "-0":"git":toCommand gitparams)
-	withHandle StdinHandle createProcessSuccess p $ \h -> do
+		{ env = gitEnv repo
-		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action
+		, std_in = CreatePipe
-		hClose h
+		}
+	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)

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 $ withNullHandle $ \nullh ->
-	liftIO $ if quiet
+		let params = bupSplitParams r buprepo k []
-		then feedWithQuietOutput createProcessSuccess cmd feeder
+		    cmd = (proc "bup" (toCommand params))
-		else withHandle StdinHandle createProcessSuccess cmd feeder
+			{ 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,13 +203,19 @@ 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
+	let p = (proc cmd $ toCommand params)
-	liftIO $ catchMsgIO $ withHandle StdoutHandle createProcessSuccess p $ \h -> do
+		{ std_out = CreatePipe }
-		contents <- hGetContents h
+	liftIO $ catchMsgIO $ withCreateProcess p (go p)
-		return $ elem k' $ lines contents
   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
 	directoryExists <- ddarDirectoryExists ddarrepo

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 $
+			liftIO $ void $ catchMaybeIO $ withNullHandle $ \nullh ->
-				withQuietOutput createProcessSuccess $
+				let p = (proc shellcmd (toCommand shellparams))
-					proc shellcmd $
+					{ std_out = UseHandle nullh
-						toCommand shellparams
+					, 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 ->
+			{ std_in = CreatePipe }
-			meteredWrite p h b
+		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
+		liftIO $ catchBoolIO $ withNullHandle $ \nullh ->
-			withQuietOutput createProcessSuccess $
+			let p = (proc "rsync" $ toCommand $ opts ++ [Param u])
-				proc "rsync" $ toCommand $ opts ++ [Param u]
+				{ std_out = UseHandle nullh
-			return True
+				, std_err = UseHandle nullh
+				}
+			in withCreateProcess p $ \_ _ _ -> checkSuccessProcess
 
 storeExportM :: RsyncOpts -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
 storeExportM o src _k loc meterupdate =

Utility/CopyFile.hs

@@ -57,11 +57,12 @@ copyCoW meta src dest
 		void $ tryIO $ removeFile dest
 		-- When CoW is not supported, cp will complain to stderr,
 		-- so have to discard its stderr.
-		ok <- catchBoolIO $ do
+		ok <- catchBoolIO $ withNullHandle $ \nullh ->
-			withQuietOutput createProcessSuccess $
+			let p = (proc "cp" $ toCommand $ params ++ [File src, File dest])
-				proc "cp" $ toCommand $
+				{ std_out = UseHandle nullh
-					params ++ [File src, File dest]
+				, std_err = UseHandle nullh
-			return True
+				}
+			in withCreateProcess p $ \_ _ _ -> checkSuccessProcess
 		-- When CoW is not supported, cp creates the destination
 		-- file but leaves it empty.
 		unless ok $

Utility/Gpg.hs

@@ -112,21 +112,33 @@ stdEncryptionParams symmetric = enc symmetric ++
 readStrict :: GpgCmd -> [CommandParam] -> IO String
 readStrict (GpgCmd cmd) params = do
 	params' <- stdParams params
-	withHandle StdoutHandle createProcessSuccess (proc cmd params') $ \h -> do
+	let p = (proc cmd params')
-		hSetBinaryMode h True
+		{ std_out = CreatePipe }
-		hGetContentsStrict h
+	withCreateProcess p (go p)
+  where
+	go p _ (Just hout) _ pid = do
+		hSetBinaryMode hout True
+		forceSuccessProcess p pid `after` hGetContentsStrict hout
+	go _ _ _ _ _ = error "internal"
 
 {- Runs gpg, piping an input value to it, and returning its stdout,
  - strictly. -}
 pipeStrict :: GpgCmd -> [CommandParam] -> String -> IO String
 pipeStrict (GpgCmd cmd) params input = do
 	params' <- stdParams params
-	withIOHandles createProcessSuccess (proc cmd params') $ \(to, from) -> do
+	let p = (proc cmd params')
+		{ std_in = CreatePipe
+		, std_out = CreatePipe
+		}
+	withCreateProcess p (go p)
+  where
+	go p (Just to) (Just from) _ pid = do
 		hSetBinaryMode to True
 		hSetBinaryMode from True
 		hPutStr to input
 		hClose to
-		hGetContentsStrict from
+		forceSuccessProcess p pid `after` hGetContentsStrict from
+	go _ _ _ _ _ = error "internal"
 
 {- Runs gpg with some parameters. First sends it a passphrase (unless it
  - is empty) via '--passphrase-fd'. Then runs a feeder action that is
@@ -244,10 +256,13 @@ maxRecommendedKeySize = 4096
  -}
 genSecretKey :: GpgCmd -> KeyType -> Passphrase -> UserId -> Size -> IO ()
 genSecretKey (GpgCmd cmd) keytype passphrase userid keysize =
-	withHandle StdinHandle createProcessSuccess (proc cmd params) feeder
+	let p = (proc cmd params)
+		{ std_in = CreatePipe }
+	in withCreateProcess p (go p)
   where
 	params = ["--batch", "--gen-key"]
-	feeder h = do
+
+	go p (Just h) _ _ pid = do
 		hPutStr h $ unlines $ catMaybes
 			[ Just $  "Key-Type: " ++ 
 				case keytype of
@@ -262,6 +277,8 @@ genSecretKey (GpgCmd cmd) keytype passphrase userid keysize =
 				else Just $ "Passphrase: " ++ passphrase
 			]
 		hClose h
+		forceSuccessProcess p pid
+	go _ _ _ _ _ = error "internal"
 
 {- Creates a block of high-quality random data suitable to use as a cipher.
  - It is armored, to avoid newlines, since gpg only reads ciphers up to the

Utility/Process.hs

@@ -20,20 +20,13 @@ module Utility.Process (
 	forceSuccessProcess,
 	forceSuccessProcess',
 	checkSuccessProcess,
-	createProcessSuccess,
-	withHandle,
-	withIOHandles,
-	withOEHandles,
 	withNullHandle,
-	withQuietOutput,
-	feedWithQuietOutput,
 	createProcess,
 	waitForProcess,
 	startInteractiveProcess,
 	stdinHandle,
 	stdoutHandle,
 	stderrHandle,
-	ioHandles,
 	processHandle,
 	devNull,
 ) where
@@ -50,32 +43,30 @@ import System.IO
 import System.Log.Logger
 import Control.Monad.IO.Class
 import Control.Concurrent.Async
-import qualified Control.Exception as E
 import qualified Data.ByteString as S
 
-type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
-
 data StdHandle = StdinHandle | StdoutHandle | StderrHandle
 	deriving (Eq)
 
 -- | Normally, when reading from a process, it does not need to be fed any
 -- standard input.
 readProcess :: FilePath	-> [String] -> IO String
-readProcess cmd args = readProcessEnv cmd args Nothing
+readProcess cmd args = readProcess' (proc cmd args)
 
 readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
-readProcessEnv cmd args environ = readProcess' p
+readProcessEnv cmd args environ = 
-  where
+	readProcess' $ (proc cmd args) { env = environ }
-	p = (proc cmd args)
-		{ std_out = CreatePipe
-		, env = environ
-		}
 
 readProcess' :: CreateProcess -> IO String
-readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do
+readProcess' p = withCreateProcess p' go
+  where
+	p' = p { std_out = CreatePipe }
+	go _ (Just h) _ pid = do
 		output  <- hGetContentsStrict h
 		hClose h
+		forceSuccessProcess p' pid
 		return output
+	go _ _ _ _ = error "internal"
 
 -- | Runs an action to write to a process on its stdin, 
 -- returns its output, and also allows specifying the environment.
@@ -122,102 +113,11 @@ checkSuccessProcess pid = do
 	code <- waitForProcess pid
 	return $ code == ExitSuccess
 
--- | Runs createProcess, then an action on its handles, and then
--- forceSuccessProcess.
-createProcessSuccess :: CreateProcessRunner
-createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
-
--- | Runs createProcess, then an action on its handles, and then
--- a checker action on its exit code, which must wait for the process.
-createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
-createProcessChecked checker p a = do
-	t@(_, _, _, pid) <- createProcess p
-	r <- tryNonAsync $ a t
-	_ <- checker pid
-	either E.throw return r
-
--- | Runs a CreateProcessRunner, on a CreateProcess structure, that
--- is adjusted to pipe only from/to a single StdHandle, and passes
--- the resulting Handle to an action.
-withHandle
-	:: StdHandle
-	-> CreateProcessRunner
-	-> CreateProcess
-	-> (Handle -> IO a)
-	-> IO a
-withHandle h creator p a = creator p' $ a . select
-  where
-	base = p
-		{ std_in = Inherit
-		, std_out = Inherit
-		, std_err = Inherit
-		}
-	(select, p') = case h of
-		StdinHandle -> (stdinHandle, base { std_in = CreatePipe })
-		StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe })
-		StderrHandle -> (stderrHandle, base { std_err = CreatePipe })
-
--- | Like withHandle, but passes (stdin, stdout) handles to the action.
-withIOHandles
-	:: CreateProcessRunner
-	-> CreateProcess
-	-> ((Handle, Handle) -> IO a)
-	-> IO a
-withIOHandles creator p a = creator p' $ a . ioHandles
-  where
-	p' = p
-		{ std_in = CreatePipe
-		, std_out = CreatePipe
-		, std_err = Inherit
-		}
-
--- | Like withHandle, but passes (stdout, stderr) handles to the action.
-withOEHandles
-	:: CreateProcessRunner
-	-> CreateProcess
-	-> ((Handle, Handle) -> IO a)
-	-> IO a
-withOEHandles creator p a = creator p' $ a . oeHandles
-  where
-	p' = p
-		{ std_in = Inherit
-		, std_out = CreatePipe
-		, std_err = CreatePipe
-		}
-
 withNullHandle :: (MonadIO m, MonadMask m) => (Handle -> m a) -> m a
 withNullHandle = bracket
 	(liftIO $ openFile devNull WriteMode)
 	(liftIO . hClose)
 
--- | Forces the CreateProcessRunner to run quietly;
--- both stdout and stderr are discarded.
-withQuietOutput
-	:: CreateProcessRunner
-	-> CreateProcess
-	-> IO ()
-withQuietOutput creator p = withNullHandle $ \nullh -> do
-	let p' = p
-		{ std_out = UseHandle nullh
-		, std_err = UseHandle nullh
-		}
-	creator p' $ const $ return ()
-
--- | Stdout and stderr are discarded, while the process is fed stdin
--- from the handle.
-feedWithQuietOutput
-	:: CreateProcessRunner
-	-> CreateProcess
-	-> (Handle -> IO a)
-	-> IO a
-feedWithQuietOutput creator p a = withNullHandle $ \nullh -> do
-	let p' = p
-		{ std_in = CreatePipe
-		, std_out = UseHandle nullh
-		, std_err = UseHandle nullh
-		}
-	creator p' $ a . stdinHandle
-
 devNull :: FilePath
 #ifndef mingw32_HOST_OS
 devNull = "/dev/null"
@@ -232,6 +132,7 @@ devNull = "\\\\.\\NUL"
 -- Get it wrong and the runtime crash will always happen, so should be
 -- easily noticed.
 type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
+
 stdinHandle :: HandleExtractor
 stdinHandle (Just h, _, _, _) = h
 stdinHandle _ = error "expected stdinHandle"
@@ -241,12 +142,6 @@ stdoutHandle _ = error "expected stdoutHandle"
 stderrHandle :: HandleExtractor
 stderrHandle (_, _, Just h, _) = h
 stderrHandle _ = error "expected stderrHandle"
-ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
-ioHandles (Just hin, Just hout, _, _) = (hin, hout)
-ioHandles _ = error "expected ioHandles"
-oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
-oeHandles (_, Just hout, Just herr, _) = (hout, herr)
-oeHandles _ = error "expected oeHandles"
 
 processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
 processHandle (_, _, _, pid) = pid

doc/todo/more_extensive_retries_to_mask_transient_failures/comment_13_6e5fb676ae08026abeb500d01ab86414._comment

@@ -0,0 +1,16 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 13"""
+ date="2020-06-04T19:39:23Z"
+ content="""
+I've converted everything to withCreateProcess, except for process pools
+(P2P.IO, Assistant.TransferrerPool, Utility.CoProcess, and Remote.External),
+which need to be handled as discussed in comment 8.
+
+During this conversion, I did not watch out for interactive processes that
+might block on a password, so any timeout would also affect them. Really,
+I don't see a good way to avoid that. Any ssh may or may not need a
+password. I guess timeouts will need to affect things stuck on passwords
+too, which argues for no default timeout, but otherwise is probably ok
+as long as timeouts can be configured on a per-remote basis.
+"""]]