From 2670890b1774142a9b0f43e1ca289e5186f03f60 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 4 Jun 2020 15:36:34 -0400 Subject: [PATCH] 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 | 21 +-- Assistant/Monad.hs | 3 + COPYRIGHT | 2 +- Command/Map.hs | 12 +- Git/Command.hs | 23 ++- Git/Config.hs | 40 ++++-- Git/Queue.hs | 14 +- Remote/Bup.hs | 24 +++- Remote/Ddar.hs | 18 ++- Remote/Git.hs | 13 +- Remote/Glacier.hs | 18 ++- Remote/Rsync.hs | 10 +- Utility/CopyFile.hs | 11 +- Utility/Gpg.hs | 31 ++++- Utility/Process.hs | 131 ++---------------- ..._6e5fb676ae08026abeb500d01ab86414._comment | 16 +++ 16 files changed, 196 insertions(+), 191 deletions(-) create mode 100644 doc/todo/more_extensive_retries_to_mask_transient_failures/comment_13_6e5fb676ae08026abeb500d01ab86414._comment diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 657c369631..f202add142 100644 --- a/Annex/Ssh.hs +++ b/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 - -- "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"]) - { cwd = Just dir } + let p = (proc "ssh" $ toCommand $ + [ Param "-O", Param "stop" ] ++ + sshConnectionCachingParams base ++ + [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 diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 5afeaeba88..fc45bd7991 100644 --- a/Assistant/Monad.hs +++ b/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 diff --git a/COPYRIGHT b/COPYRIGHT index 2ae19d34bb..462a84e9ac 100644 --- a/COPYRIGHT +++ b/COPYRIGHT @@ -15,7 +15,7 @@ Copyright: © 2013 Joey Hess License: GPL-3+ Files: Remote/Ddar.hs -Copyright: © 2011 Joey Hess +Copyright: © 2011-2020 Joey Hess © 2014 Robie Basak License: GPL-3+ diff --git a/Command/Map.hs b/Command/Map.hs index ce82982ab8..fd0e000a07 100644 --- a/Command/Map.hs +++ b/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 $ - Git.Config.hRead r st + withCreateProcess p (pipedconfig' st p) 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" [] [] diff --git a/Git/Command.hs b/Git/Command.hs index 27688e2ca1..76360584a2 100644 --- a/Git/Command.hs +++ b/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 $ - (proc "git" $ toCommand $ gitCommandLine (params) repo) - { env = gitEnv repo } +runQuiet params repo = withNullHandle $ \nullh -> + let p = (proc "git" $ toCommand $ gitCommandLine (params) 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 $ - withHandle StdinHandle createProcessSuccess $ - gitCreateProcess params repo +pipeWrite params repo a = assertLocal repo $ + let p = (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. -} diff --git a/Git/Config.hs b/Git/Config.hs index f50d5eb534..eb7157bada 100644 --- a/Git/Config.hs +++ b/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 $ - hRead repo ConfigNullList + git_config d = withCreateProcess p (git_config' p) 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 - repo <- withHandle StdoutHandle createProcessSuccess p $ - hRead (Git.Construct.fromUnknown) ConfigNullList - return $ Just repo + ( Just <$> withCreateProcess p go , 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 $ - withOEHandles createProcessSuccess p $ \(hout, herr) -> do - geterr <- async $ S.hGetContents herr - getval <- async $ S.hGetContents hout - val <- wait getval - err <- wait geterr +fromPipe r cmd params st = try $ withCreateProcess p go + where + p = (proc cmd $ toCommand params) + { std_out = CreatePipe + , std_err = CreatePipe + } + 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 - p = proc cmd $ toCommand params + go _ _ _ _ = error "internal" {- Reads git config from a specified file and returns the repo populated - with the configuration. -} diff --git a/Git/Queue.hs b/Git/Queue.hs index eb4bbb0694..7ce0f0b788 100644 --- a/Git/Queue.hs +++ b/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 } - withHandle StdinHandle createProcessSuccess p $ \h -> do - hPutStr h $ intercalate "\0" $ toCommand $ getFiles action - hClose h + let p = (proc "xargs" $ "-0":"git":toCommand gitparams) + { env = gitEnv repo + , std_in = CreatePipe + } + 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) diff --git a/Remote/Bup.hs b/Remote/Bup.hs index f51e9e6708..58e301d126 100644 --- a/Remote/Bup.hs +++ b/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 diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index de9fe1870a..514b978474 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -1,11 +1,13 @@ {- Using ddar as a remote. Based on bup and rsync remotes. - - - Copyright 2011 Joey Hess + - Copyright 2011-2020 Joey Hess - Copyright 2014 Robie Basak - - 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 diff --git a/Remote/Git.hs b/Remote/Git.hs index 6c48682815..18726dce89 100644 --- a/Remote/Git.hs +++ b/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) diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index a996170a3e..bb8f8c9f95 100644 --- a/Remote/Glacier.hs +++ b/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." diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index d8a9c37a49..0713d51b9e 100644 --- a/Remote/Rsync.hs +++ b/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 = diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index e3cdc46b58..f851326b90 100644 --- a/Utility/CopyFile.hs +++ b/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 - withQuietOutput createProcessSuccess $ - proc "cp" $ toCommand $ - params ++ [File src, File dest] - return True + ok <- catchBoolIO $ withNullHandle $ \nullh -> + let p = (proc "cp" $ toCommand $ params ++ [File src, File dest]) + { std_out = UseHandle nullh + , std_err = UseHandle nullh + } + in withCreateProcess p $ \_ _ _ -> checkSuccessProcess -- When CoW is not supported, cp creates the destination -- file but leaves it empty. unless ok $ diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 404fcf362e..f9053b29e0 100644 --- a/Utility/Gpg.hs +++ b/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 - hSetBinaryMode h True - hGetContentsStrict h + let p = (proc cmd params') + { std_out = CreatePipe } + 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 diff --git a/Utility/Process.hs b/Utility/Process.hs index 1c894e1381..101bec19e3 100644 --- a/Utility/Process.hs +++ b/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 - where - p = (proc cmd args) - { std_out = CreatePipe - , env = environ - } +readProcessEnv cmd args environ = + readProcess' $ (proc cmd args) { env = environ } readProcess' :: CreateProcess -> IO String -readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do - output <- hGetContentsStrict h - hClose h - return output +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 diff --git a/doc/todo/more_extensive_retries_to_mask_transient_failures/comment_13_6e5fb676ae08026abeb500d01ab86414._comment b/doc/todo/more_extensive_retries_to_mask_transient_failures/comment_13_6e5fb676ae08026abeb500d01ab86414._comment new file mode 100644 index 0000000000..e13739927f --- /dev/null +++ b/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. +"""]]