Commits

basvandijk committed ab5d1ef

Fixed asynchronous exception bugs

This patch is similar to the patch in:
http://hackage.haskell.org/trac/ghc/ticket/5766

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 standard 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.

Comments (0)

Files changed (5)

process-extras.cabal

     System.Process.ByteString.Lazy
     System.Process.Text
 
+  Other-modules:
+    Utils
+
   Build-depends:
     base >= 4 && < 5,
     process,

src/System/Process/ByteString.hs

 module System.Process.ByteString where
 
-import Control.Concurrent
+import Control.Exception
 import Control.Monad
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import System.Process
 import System.Exit (ExitCode)
 import System.IO
+import Utils (forkWait)
 
 -- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString'
 readProcessWithExitCode
     -> [String]                 -- ^ any arguments
     -> ByteString               -- ^ standard input
     -> IO (ExitCode, ByteString, ByteString) -- ^ exitcode, stdout, stderr
-readProcessWithExitCode cmd args input = do
+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 }
-    outMVar <- newEmptyMVar
-    outM <- newEmptyMVar
-    errM <- newEmptyMVar
+    flip onException
+      (do hClose inh; hClose outh; hClose errh;
+          terminateProcess pid; waitForProcess pid) $ restore $ do
 
-    -- fork off a thread to start consuming stdout
-    _ <- forkIO $ do
-        out <- B.hGetContents outh
-        putMVar outM out
-        putMVar outMVar ()
+        -- fork off a thread to start consuming stdout
+      waitOut <- forkWait $ B.hGetContents outh
 
-    -- fork off a thread to start consuming stderr
-    _ <- forkIO $ do
-        err  <- B.hGetContents errh
-        putMVar errM err
-        putMVar outMVar ()
+        -- fork off a thread to start consuming stderr
+      waitErr <- forkWait $ B.hGetContents errh
 
-    -- now write and flush any input
-    when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh
-    hClose inh -- done with stdin
+      -- now write and flush any input
+      unless (B.null input) $ do B.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 output
+      out <- waitOut
+      err <- waitErr
 
-    -- wait on the process
-    ex <- waitForProcess pid
-    out <- readMVar outM
-    err <- readMVar errM
+      hClose outh
+      hClose errh
 
-    return (ex, out, err)
+      -- wait on the process
+      ex <- waitForProcess pid
+
+      return (ex, out, err)

src/System/Process/ByteString/Lazy.hs

 module System.Process.ByteString.Lazy where
 
-import Control.Concurrent
-import qualified Control.Exception as C
+import Control.Exception
+import qualified Control.Exception as C (evaluate)
 import Control.Monad
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy as B
 import System.Process
 import System.Exit (ExitCode)
 import System.IO
+import Utils (forkWait)
 
 -- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString'
 readProcessWithExitCode
     -> [String]                 -- ^ any arguments
     -> ByteString               -- ^ standard input
     -> IO (ExitCode, ByteString, ByteString) -- ^ exitcode, stdout, stderr
-readProcessWithExitCode cmd args input = do
+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 }
-    outMVar <- newEmptyMVar
+    flip onException
+      (do hClose inh; hClose outh; hClose errh;
+            terminateProcess pid; waitForProcess pid) $ restore $ do
 
-    -- fork off a thread to start consuming stdout
-    out  <- B.hGetContents outh
-    _ <- forkIO $ C.evaluate (B.length out) >> putMVar outMVar ()
+      -- fork off a thread to start consuming stdout
+      out <- B.hGetContents outh
+      waitOut <- forkWait $ void $ C.evaluate $ B.length out
 
-    -- fork off a thread to start consuming stderr
-    err  <- B.hGetContents errh
-    _ <- forkIO $ C.evaluate (B.length err) >> putMVar outMVar ()
+      -- fork off a thread to start consuming stderr
+      err <- B.hGetContents errh
+      waitErr <- forkWait $ void $ C.evaluate $ B.length err
 
-    -- now write and flush any input
-    when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh
-    hClose inh -- done with stdin
+      -- now write and flush any input
+      unless (B.null input) $ do B.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 output
+      waitOut
+      waitErr
 
-    -- wait on the process
-    ex <- waitForProcess pid
+      hClose outh
+      hClose errh
 
-    return (ex, out, err)
+      -- wait on the process
+      ex <- waitForProcess pid
+
+      return (ex, out, err)

src/System/Process/Text.hs

 module System.Process.Text where
 
-import Control.Concurrent
+import Control.Exception
 import Control.Monad
 import Data.Text (Text)
 import qualified Data.Text as T
 import System.Process
 import System.Exit (ExitCode)
 import System.IO
+import Utils (forkWait)
 
 -- | Like 'System.Process.readProcessWithExitCode', but using 'Text'
 readProcessWithExitCode
     -> [String]                 -- ^ any arguments
     -> Text                     -- ^ standard input
     -> IO (ExitCode, Text, Text) -- ^ exitcode, stdout, stderr
-readProcessWithExitCode cmd args input = do
+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 }
-    outMVar <- newEmptyMVar
-    outM <- newEmptyMVar
-    errM <- newEmptyMVar
+    flip onException
+      (do hClose inh; hClose outh; hClose errh;
+          terminateProcess pid; waitForProcess pid) $ restore $ do
 
-    -- fork off a thread to start consuming stdout
-    _ <- forkIO $ do
-        out <- T.hGetContents outh
-        putMVar outM out
-        putMVar outMVar ()
+        -- fork off a thread to start consuming stdout
+      waitOut <- forkWait $ T.hGetContents outh
 
-    -- fork off a thread to start consuming stderr
-    _ <- forkIO $ do
-        err  <- T.hGetContents errh
-        putMVar errM err
-        putMVar outMVar ()
+        -- fork off a thread to start consuming stderr
+      waitErr <- forkWait $ T.hGetContents errh
 
-    -- now write and flush any input
-    when (not (T.null input)) $ do T.hPutStr inh input; hFlush inh
-    hClose inh -- done with stdin
+      -- now write and flush any input
+      unless (T.null input) $ do T.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 output
+      out <- waitOut
+      err <- waitErr
 
-    -- wait on the process
-    ex <- waitForProcess pid
-    out <- readMVar outM
-    err <- readMVar errM
+      hClose outh
+      hClose errh
 
-    return (ex, out, err)
+      -- wait on the process
+      ex <- waitForProcess pid
+
+      return (ex, out, err)
+module Utils where
+
+import Control.Concurrent
+import Control.Exception
+
+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)