[commit: packages/process] master: Fix deadlocks in readProcess{, WithExitCode} (32223a9)

[git at git.haskell.org]

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

On branch  : master
Link       : http://git.haskell.org/packages/process.git/commitdiff/32223a9ab174c22e939c81e24b6f48223c7cb020

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

commit 32223a9ab174c22e939c81e24b6f48223c7cb020
Author: Takano Akio <aljee at hyper.cx>
Date:   Wed Sep 25 19:37:00 2013 +0900

    Fix deadlocks in readProcess{,WithExitCode}
    
    The problem is in the exception handler in readProcess. When it receives
    an asynchronous exception, it tries to clean up by closing the pipes.
    However the attempt to close outh blocks because the reader thread
    (reading with hGetContents) is blocking on the handle.
    
    This fixes #8483.
    
    Signed-off-by: Austin Seipp <austin at well-typed.com>


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

32223a9ab174c22e939c81e24b6f48223c7cb020
 System/Process.hs  |    8 ++++----
 tests/T8343.hs     |    8 ++++++++
 tests/T8343.stdout |    2 ++
 tests/all.T        |    2 ++
 4 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/System/Process.hs b/System/Process.hs
index 42d2fac..2808339 100644
--- a/System/Process.hs
+++ b/System/Process.hs
@@ -400,8 +400,8 @@ readProcess cmd args input =
                                        std_out = CreatePipe,
                                        std_err = Inherit }
       flip onException
-        (do hClose inh; hClose outh;
-            terminateProcess pid; waitForProcess pid) $ restore $ do
+        (do terminateProcess pid; hClose inh; hClose outh;
+            waitForProcess pid) $ restore $ do
         -- fork off a thread to start consuming the output
         output  <- hGetContents outh
         waitOut <- forkWait $ C.evaluate $ rnf output
@@ -457,8 +457,8 @@ readProcessWithExitCode cmd args input =
                                                      std_out = CreatePipe,
                                                      std_err = CreatePipe }
       flip onException
-        (do hClose inh; hClose outh; hClose errh;
-            terminateProcess pid; waitForProcess pid) $ restore $ do
+        (do terminateProcess pid; hClose inh; hClose outh; hClose errh;
+            waitForProcess pid) $ restore $ do
         -- fork off a thread to start consuming stdout
         out <- hGetContents outh
         waitOut <- forkWait $ C.evaluate $ rnf out
diff --git a/tests/T8343.hs b/tests/T8343.hs
new file mode 100644
index 0000000..23363a5
--- /dev/null
+++ b/tests/T8343.hs
@@ -0,0 +1,8 @@
+import System.Process
+import System.Timeout
+
+main = timeout 1000000 $ do -- The outer timeout shouldn't trigger
+  timeout 10000 $ print =<< readProcess "sleep" ["7200"] ""
+  putStrLn "Good!"
+  timeout 10000 $ print =<< readProcessWithExitCode "sleep" ["7200"] ""
+  putStrLn "Good!"
diff --git a/tests/T8343.stdout b/tests/T8343.stdout
new file mode 100644
index 0000000..75c573d
--- /dev/null
+++ b/tests/T8343.stdout
@@ -0,0 +1,2 @@
+Good!
+Good!
diff --git a/tests/all.T b/tests/all.T
index 3a19367..f77fe8e 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -32,3 +32,5 @@ test('T4889', normal, compile_and_run, [''])
 
 test('process009', when(opsys('mingw32'), skip), compile_and_run, [''])
 test('process010', normal, compile_and_run, [''])
+
+test('T8343', normal, compile_and_run, [''])