92f775eba0
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.
84 lines
2.3 KiB
Haskell
84 lines
2.3 KiB
Haskell
{- Process transcript
|
|
-
|
|
- Copyright 2012-2018 Joey Hess <id@joeyh.name>
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
{-# OPTIONS_GHC -fno-warn-tabs #-}
|
|
|
|
module Utility.Process.Transcript (
|
|
processTranscript,
|
|
processTranscript',
|
|
processTranscript'',
|
|
) where
|
|
|
|
import Utility.Process
|
|
import Utility.Misc
|
|
|
|
import System.IO
|
|
import System.Exit
|
|
import Control.Concurrent.Async
|
|
import Control.Monad
|
|
#ifndef mingw32_HOST_OS
|
|
import qualified System.Posix.IO
|
|
#else
|
|
import Control.Applicative
|
|
#endif
|
|
import Data.Maybe
|
|
import Prelude
|
|
|
|
-- | 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. -}
|
|
(readf, writef) <- System.Posix.IO.createPipe
|
|
System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True
|
|
System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True
|
|
readh <- System.Posix.IO.fdToHandle readf
|
|
writeh <- System.Posix.IO.fdToHandle writef
|
|
withCreateProcess cp $ \hin hout herr pid -> do
|
|
hClose writeh
|
|
|
|
get <- asyncreader readh
|
|
writeinput input (hin, hout, herr, pid)
|
|
transcript <- wait get
|
|
#else
|
|
{- This implementation for Windows puts stderr after stdout. -}
|
|
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
|
|
transcript <- (++) <$> wait getout <*> wait geterr
|
|
#endif
|
|
code <- waitForProcess pid
|
|
return (transcript, code)
|
|
where
|
|
asyncreader = async . hGetContentsStrict
|
|
|
|
writeinput (Just s) p = do
|
|
let inh = stdinHandle p
|
|
unless (null s) $ do
|
|
hPutStr inh s
|
|
hFlush inh
|
|
hClose inh
|
|
writeinput Nothing _ = return ()
|