[commit: packages/Cabal] ghc-head: Exception-safety fixes for 'syncProcess'. (e3e3702)

[git at git.haskell.org]

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

On branch  : ghc-head
Link       : http://git.haskell.org/packages/Cabal.git/commitdiff/e3e3702a6997f9a431ca562156cf667c93bd0e5e

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

commit e3e3702a6997f9a431ca562156cf667c93bd0e5e
Author: Mikhail Glushenkov <mikhail.glushenkov at gmail.com>
Date:   Tue Oct 15 23:48:50 2013 +0200

    Exception-safety fixes for 'syncProcess'.
    
    (cherry picked from commit 4b38475f205730f96ca0e328dec95bb4d651c6a1)


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

e3e3702a6997f9a431ca562156cf667c93bd0e5e
 Cabal/Distribution/Simple/Utils.hs |   20 +++++++++++++-------
 1 file changed, 13 insertions(+), 7 deletions(-)

diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs
index 45890ee..9a5fe3d 100644
--- a/Cabal/Distribution/Simple/Utils.hs
+++ b/Cabal/Distribution/Simple/Utils.hs
@@ -408,14 +408,20 @@ syncProcess fun c = do
   -- in the child (using SIG_DFL isn't really correct, it should be the
   -- original signal handler, but the GHC RTS will have already set up
   -- its own handler and we don't want to use that).
-  old_int  <- installHandler sigINT  Ignore Nothing
-  old_quit <- installHandler sigQUIT Ignore Nothing
-  (_,_,_,p) <- runGenProcess_ fun c
-                (Just defaultSignal) (Just defaultSignal)
+  (_,_,_,p) <- Exception.bracket (installHandlers) (restoreHandlers) $
+               (\_ -> runGenProcess_ fun c
+                      (Just defaultSignal) (Just defaultSignal))
   r <- waitForProcess p
-  _ <- installHandler sigINT  old_int Nothing
-  _ <- installHandler sigQUIT old_quit Nothing
   return r
+    where
+      installHandlers = do
+        old_int  <- installHandler sigINT  Ignore Nothing
+        old_quit <- installHandler sigQUIT Ignore Nothing
+        return (old_int, old_quit)
+      restoreHandlers (old_int, old_quit) = do
+        _ <- installHandler sigINT  old_int Nothing
+        _ <- installHandler sigQUIT old_quit Nothing
+        return ()
 #endif  /* mingw32_HOST_OS */
 
 -- Exit with the same exitcode if the subcommand fails
@@ -471,9 +477,9 @@ rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do
                 , Process.std_in  = mbToStd inp
                 , Process.std_out = mbToStd out
                 , Process.std_err = mbToStd err }
+                `Exception.finally` (mapM_ maybeClose [inp, out, err])
     unless (exitcode == ExitSuccess) $ do
       debug verbosity $ path ++ " returned " ++ show exitcode
-    mapM_ maybeClose [inp, out, err]
     return exitcode
   where
   -- Also taken from System.Process