From 66440d115b762a0e05a13f114e4af22802e7f8fc Mon Sep 17 00:00:00 2001 From: Bas van Dijk Date: Thu, 12 Jan 2012 19:58:57 +0100 Subject: [PATCH] Fixed asynchronous exception bugs in readProcess and readProcessWithExitCode This patch fixes the following two bugs: 1) If an asynchronous exception was thrown to the thread executing readProcess somewhere after createProcess was executed, the stdin, stdout and stderr handles would not be closed anymore resulting in a "handle leak" so to speak. This is fixed by catching exceptions in the IO processing code and closing the standard handles when an exception occurs. Additionally, I also terminate the process and wait for its termination. 2) If an asynchronous exception was thrown to the stdout/stderr-read-thread it did not execute the putMVar anymore resulting in a dead-lock when takeMVar was executed. This is fixed by properly catching exception in the read-thread and propagating them to the parent thread which will then handle them as described above. --- System/Process.hs | 125 +++++++++++++++++++++++++++++------------------------ process.cabal | 3 +- 2 files changed, 71 insertions(+), 57 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index f3a8f9b..247a8a0 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -70,7 +70,9 @@ import Prelude hiding (mapM) #ifndef __HUGS__ import System.Process.Internals -import System.IO.Error +import Control.Exception (SomeException, mask, try, onException, throwIO) +import Control.DeepSeq (rnf) +import System.IO.Error (mkIOError, ioeSetErrorString) #if !defined(mingw32_HOST_OS) import System.Posix.Types #if MIN_VERSION_unix(2,5,0) @@ -371,35 +373,37 @@ readProcess -> [String] -- ^ any arguments -> String -- ^ standard input -> IO String -- ^ stdout -readProcess cmd args input = do - (Just inh, Just outh, _, pid) <- +readProcess cmd args input = + mask $ \restore -> do + (Just inh, Just outh, _, pid) <- createProcess (proc cmd args){ std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit } - - -- fork off a thread to start consuming the output - output <- hGetContents outh - outMVar <- newEmptyMVar - _ <- forkIO $ C.evaluate (length output) >> putMVar outMVar () - - -- now write and flush any input - when (not (null input)) $ do hPutStr inh input; hFlush inh - hClose inh -- done with stdin - - -- wait on the output - takeMVar outMVar - hClose outh - - -- wait on the process - ex <- waitForProcess pid - - case ex of - ExitSuccess -> return output - ExitFailure r -> - ioError (mkIOError OtherError ("readProcess: " ++ cmd ++ - ' ':unwords (map show args) ++ - " (exit " ++ show r ++ ")") - Nothing Nothing) + flip onException + (do hClose inh; hClose outh; + terminateProcess pid; waitForProcess pid) $ do + -- fork off a thread to start consuming the output + output <- hGetContents outh + waitOut <- forkWait $ C.evaluate $ rnf output + + -- now write and flush any input + when (not (null input)) $ do hPutStr inh input; hFlush inh + hClose inh -- done with stdin + + -- wait on the output + waitOut + hClose outh + + -- wait on the process + ex <- waitForProcess pid + + case ex of + ExitSuccess -> return output + ExitFailure r -> + ioError (mkIOError OtherError ("readProcess: " ++ cmd ++ + ' ':unwords (map show args) ++ + " (exit " ++ show r ++ ")") + Nothing Nothing) {- | readProcessWithExitCode creates an external process, reads its @@ -418,36 +422,45 @@ readProcessWithExitCode -> [String] -- ^ any arguments -> String -- ^ standard input -> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr -readProcessWithExitCode cmd args input = do - (Just inh, Just outh, Just errh, pid) <- - createProcess (proc cmd args){ std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe } - - outMVar <- newEmptyMVar - - -- fork off a thread to start consuming stdout - out <- hGetContents outh - _ <- forkIO $ C.evaluate (length out) >> putMVar outMVar () - - -- fork off a thread to start consuming stderr - err <- hGetContents errh - _ <- forkIO $ C.evaluate (length err) >> putMVar outMVar () - - -- now write and flush any input - when (not (null input)) $ do hPutStr inh input; hFlush inh - hClose inh -- done with stdin - - -- wait on the output - takeMVar outMVar - takeMVar outMVar - hClose outh - hClose errh - - -- wait on the process - ex <- waitForProcess pid +readProcessWithExitCode cmd args input = + mask $ \restore -> do + (Just inh, Just outh, Just errh, pid) <- createProcess (proc cmd args) + { std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe } + flip onException + (do hClose inh; hClose outh; hClose errh; + terminateProcess pid; waitForProcess pid) $ do + -- fork off a thread to start consuming stdout + out <- hGetContents outh + waitOut <- forkWait $ C.evaluate $ rnf out + + -- fork off a thread to start consuming stderr + err <- hGetContents errh + waitErr <- forkWait $ C.evaluate $ rnf err + + -- now write and flush any input + when (not (null input)) $ do hPutStr inh input; hFlush inh + hClose inh -- done with stdin + + -- wait on the output + waitOut + waitErr + + hClose outh + hClose errh + + -- wait on the process + ex <- waitForProcess pid + + return (ex, out, err) + +forkWait :: IO a -> IO (IO a) +forkWait a = do + res <- newEmptyMVar + _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res + return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return) - return (ex, out, err) #endif /* !__HUGS__ */ -- --------------------------------------------------------------------------- diff --git a/process.cabal b/process.cabal index aaf232b..53d3f06 100644 --- a/process.cabal +++ b/process.cabal @@ -58,7 +58,8 @@ Library { } build-depends: directory >= 1.0 && < 1.2, - filepath >= 1.1 && < 1.3 + filepath >= 1.1 && < 1.3, + deepseq >= 1.1 && < 1.3 extensions: CPP } -- 1.7.5.4