async exception safety
Convert to withCreateProcess (missed this one a couple commits ago) and also make sure that the child thread gets canceled on exception.
This commit is contained in:
parent
bd3074643b
commit
e4993b4456
1 changed files with 15 additions and 21 deletions
|
@ -43,12 +43,13 @@ import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProc
|
|||
import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess)
|
||||
import Utility.Misc
|
||||
import Utility.Exception
|
||||
import Utility.Monad
|
||||
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.Log.Logger
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
import qualified Control.Exception as E
|
||||
import qualified Data.ByteString as S
|
||||
|
||||
|
@ -84,26 +85,7 @@ writeReadProcessEnv
|
|||
-> Maybe [(String, String)]
|
||||
-> (Maybe (Handle -> IO ()))
|
||||
-> IO S.ByteString
|
||||
writeReadProcessEnv cmd args environ writestdin = do
|
||||
(Just inh, Just outh, _, pid) <- createProcess p
|
||||
|
||||
-- fork off a thread to start consuming the output
|
||||
outMVar <- newEmptyMVar
|
||||
_ <- forkIO $ putMVar outMVar =<< S.hGetContents outh
|
||||
|
||||
-- now write and flush any input
|
||||
maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
|
||||
hClose inh -- done with stdin
|
||||
|
||||
-- wait on the output
|
||||
output <- takeMVar outMVar
|
||||
hClose outh
|
||||
|
||||
-- wait on the process
|
||||
forceSuccessProcess p pid
|
||||
|
||||
return output
|
||||
|
||||
writeReadProcessEnv cmd args environ writestdin = withCreateProcess p go
|
||||
where
|
||||
p = (proc cmd args)
|
||||
{ std_in = CreatePipe
|
||||
|
@ -111,6 +93,18 @@ writeReadProcessEnv cmd args environ writestdin = do
|
|||
, std_err = Inherit
|
||||
, env = environ
|
||||
}
|
||||
|
||||
go (Just inh) (Just outh) _ pid = do
|
||||
let reader = hClose outh `after` S.hGetContents outh
|
||||
let writer = do
|
||||
maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
|
||||
hClose inh
|
||||
(output, ()) <- concurrently reader writer
|
||||
|
||||
forceSuccessProcess p pid
|
||||
|
||||
return output
|
||||
go _ _ _ _ = error "internal"
|
||||
|
||||
-- | Waits for a ProcessHandle, and throws an IOError if the process
|
||||
-- did not exit successfully.
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue