[commit: packages/process] master: Be even more careful with the threads that consume output (#2233) (d95a670)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/process

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/d95a67012ea30b02144d193254d947cdf5400a9d/process

>---------------------------------------------------------------

commit d95a67012ea30b02144d193254d947cdf5400a9d
Author: Duncan Coutts <duncan at community.haskell.org>
Date:   Tue Nov 26 00:04:41 2013 +0000

    Be even more careful with the threads that consume output (#2233)
    
    There is a potential deadlock with withCreateProcess in the case that
    there's an exception: cleanupProcess will try to hClose the various
    handles, but if another thread holds the Handle lock then that hClose
    will block.
    
    Takano Akio fixed the main case of this (in patch
    32223a9ab174c22e939c81e24b6f48223c7cb020) by terminating the process
    (before closing the handles) This works because terminating the process
    will eventually cause those other threads to finish and release the
    Handle lock, so we can hClose.
    
    However on Unix terminateProcess is not guaranteed to terminate the
    process since it uses SIGTERM, which can be handled or ignored. So we
    have to separately guarantee that the handles can be hClosed, and the
    simplest way to do this is to ensure that the thread reading from the
    handles get killed in the case there's an exception.
    
    So we change forkWait to withForkWait that will kill off the thread if
    the body gets an exception.
    
    Authored-by: Duncan Coutts <duncan at well-typed.com>
    Signed-off-by: Herbert Valerio Riedel <hvr at gnu.org>


>---------------------------------------------------------------

d95a67012ea30b02144d193254d947cdf5400a9d
 System/Process.hs |   66 ++++++++++++++++++++++++++++++-----------------------
 1 file changed, 37 insertions(+), 29 deletions(-)

diff --git a/System/Process.hs b/System/Process.hs
index 5f4e7d1..581ef71 100644
--- a/System/Process.hs
+++ b/System/Process.hs
@@ -423,17 +423,17 @@ readProcess cmd args input = do
 
         -- fork off a thread to start consuming the output
         output  <- hGetContents outh
-        waitOut <- forkWait $ C.evaluate $ rnf output
+        withForkWait (C.evaluate $ rnf output) $ \waitOut -> do
 
-        -- now write and flush any input
-        unless (null input) $ do
-          ignoreSigPipe $ hPutStr inh input
-          hFlush inh
-        hClose inh -- done with stdin
+          -- now write and flush any input
+          unless (null input) $ do
+            ignoreSigPipe $ hPutStr inh input
+            hFlush inh
+          hClose inh -- done with stdin
 
-        -- wait on the output
-        waitOut
-        hClose outh
+          -- wait on the output
+          waitOut
+          hClose outh
 
         -- wait on the process
         ex <- waitForProcess ph
@@ -477,37 +477,45 @@ readProcessWithExitCode cmd args input = do
     withCreateProcess_ "readProcessWithExitCode" cp_opts $
       \(Just inh) (Just outh) (Just errh) ph -> 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
-        unless (null input) $ do
-          ignoreSigPipe $ hPutStr inh input
-          hFlush inh
-        hClose inh
+        -- fork off threads to start consuming stdout & stderr
+        withForkWait  (C.evaluate $ rnf out) $ \waitOut ->
+         withForkWait (C.evaluate $ rnf err) $ \waitErr -> do
+
+          -- now write and flush any input
+          unless (null input) $ do
+            ignoreSigPipe $ hPutStr inh input
+            hFlush inh
+          hClose inh
 
-        -- wait on the output
-        waitOut
-        waitErr
+          -- wait on the output
+          waitOut
+          waitErr
 
-        hClose outh
-        hClose errh
+          hClose outh
+          hClose errh
 
         -- wait on the process
         ex <- waitForProcess ph
 
         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)
+-- | Fork a thread while doing something else, but kill it if there's an
+-- exception.
+--
+-- This is important in the cases above because we want to kill the thread
+-- that is holding the Handle lock, because when we clean up the process we
+-- try to close that handle, which could otherwise deadlock.
+--
+withForkWait :: IO () -> (IO () ->  IO a) -> IO a
+withForkWait async body = do
+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
+  mask $ \restore -> do
+    tid <- forkIO $ try (restore async) >>= putMVar waitVar
+    let wait = takeMVar waitVar >>= either throwIO return
+    restore (body wait) `C.onException` killThread tid
 
 ignoreSigPipe :: IO () -> IO ()
 #if defined(__GLASGOW_HASKELL__)