simplify with async
This is much clearer to follow. I've tested this, and it still has the problem described in doc/bugs/occasional_hang_with_p2pstdio.mdwn Which I think indicates that problem is not with my code, but something else. ghc runtime? Something crazy ssh does in this situation? Unsure..
This commit is contained in:
parent
ac6f58d642
commit
d6700721c0
1 changed files with 8 additions and 20 deletions
|
@ -11,11 +11,11 @@
|
|||
module Utility.Process.Transcript where
|
||||
|
||||
import Utility.Process
|
||||
import Utility.Misc
|
||||
|
||||
import System.IO
|
||||
import System.Exit
|
||||
import Control.Concurrent
|
||||
import qualified Control.Exception as E
|
||||
import Control.Concurrent.Async
|
||||
import Control.Monad
|
||||
#ifndef mingw32_HOST_OS
|
||||
import qualified System.Posix.IO
|
||||
|
@ -51,9 +51,9 @@ processTranscript'' cp input = do
|
|||
}
|
||||
hClose writeh
|
||||
|
||||
get <- mkreader readh
|
||||
get <- asyncreader readh
|
||||
writeinput input p
|
||||
transcript <- get
|
||||
transcript <- wait get
|
||||
#else
|
||||
{- This implementation for Windows puts stderr after stdout. -}
|
||||
p@(_, _, _, pid) <- createProcess $ cp
|
||||
|
@ -62,27 +62,15 @@ processTranscript'' cp input = do
|
|||
, std_err = CreatePipe
|
||||
}
|
||||
|
||||
getout <- mkreader (stdoutHandle p)
|
||||
geterr <- mkreader (stderrHandle p)
|
||||
getout <- asyncreader (stdoutHandle p)
|
||||
geterr <- asyncreader (stderrHandle p)
|
||||
writeinput input p
|
||||
transcript <- (++) <$> getout <*> geterr
|
||||
transcript <- (++) <$> wait getout <*> wait geterr
|
||||
#endif
|
||||
code <- waitForProcess pid
|
||||
return (transcript, code)
|
||||
where
|
||||
mkreader h = do
|
||||
-- Start consuming the output immediately, because the
|
||||
-- process may block on reading input until some
|
||||
-- of its output is consumed.
|
||||
s <- hGetContents h
|
||||
v <- newEmptyMVar
|
||||
void $ forkIO $ do
|
||||
-- Wait for output to be fully consumed.
|
||||
void $ E.evaluate (length s)
|
||||
putMVar v ()
|
||||
return $ do
|
||||
takeMVar v
|
||||
return s
|
||||
asyncreader = async . hGetContentsStrict
|
||||
|
||||
writeinput (Just s) p = do
|
||||
let inh = stdinHandle p
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue