d2af6baaeb
The pipe's FDs got inherited by ssh and it did something that kept them open even once it exited. Probably involving passing them on to the ssh mux daemon. Set close on exec, and all is well. Kept Annex.Ssh not using processTranscript even though it no longer hangs when it does use it, just because processTranscript is overkill there. This commit was supported by the NSF-funded DataLad project.
83 lines
2.3 KiB
Haskell
83 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 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
|
|
p@(_, _, _, pid) <- createProcess $ cp
|
|
{ std_in = if isJust input then CreatePipe else Inherit
|
|
, std_out = UseHandle writeh
|
|
, std_err = UseHandle writeh
|
|
}
|
|
hClose writeh
|
|
|
|
get <- asyncreader readh
|
|
writeinput input p
|
|
transcript <- wait get
|
|
#else
|
|
{- This implementation for Windows puts stderr after stdout. -}
|
|
p@(_, _, _, pid) <- createProcess $ cp
|
|
{ std_in = if isJust input then CreatePipe else Inherit
|
|
, std_out = CreatePipe
|
|
, std_err = CreatePipe
|
|
}
|
|
|
|
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 ()
|