From ce2a8be94e9fd5193a1461ccfa5737ce12076813 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 7 Mar 2018 17:25:42 -0400 Subject: Better ssh connection warmup when using -J for concurrency. Avoids ugly messages when forced ssh command is not git-annex-shell. This commit was sponsored by Ole-Morten Duesund on Patreon. --- Utility/Process/Transcript.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) (limited to 'Utility') diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs index 0dbe428f7..0dbbd443a 100644 --- a/Utility/Process/Transcript.hs +++ b/Utility/Process/Transcript.hs @@ -1,6 +1,6 @@ {- Process transcript - - - Copyright 2012-2015 Joey Hess + - Copyright 2012-2018 Joey Hess - - License: BSD-2-clause -} @@ -13,6 +13,7 @@ module Utility.Process.Transcript where import Utility.Process import System.IO +import System.Exit import Control.Concurrent import qualified Control.Exception as E import Control.Monad @@ -24,14 +25,19 @@ import Control.Applicative import Data.Maybe import Prelude --- | Runs a process, optionally feeding it some input, and --- returns a transcript combining its stdout and stderr, and --- whether it succeeded or failed. +-- | Runs a process and returns a transcript combining its stdout and +-- stderr, and whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) processTranscript cmd opts = processTranscript' (proc cmd opts) +-- | Also feeds the process some input. processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) processTranscript' cp input = do + (t, c) <- processTranscript'' cp input + return (t, c == ExitSuccess) + +processTranscript'' :: CreateProcess -> Maybe String -> IO (String, ExitCode) +processTranscript'' cp input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} @@ -48,9 +54,6 @@ processTranscript' cp input = do get <- mkreader readh writeinput input p transcript <- get - - ok <- checkSuccessProcess pid - return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} p@(_, _, _, pid) <- createProcess $ cp @@ -63,10 +66,9 @@ processTranscript' cp input = do geterr <- mkreader (stderrHandle p) writeinput input p transcript <- (++) <$> getout <*> geterr - - ok <- checkSuccessProcess pid - return (transcript, ok) #endif + code <- waitForProcess pid + return (transcript, code) where mkreader h = do s <- hGetContents h -- cgit v1.2.3