[commit: ghc] master: Adds CTRL-C handler in Windows's timeout (trac issue #12721) (2323ffd)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/2323ffdd552327a8954de8ac37908029ec7cad38/ghc

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

commit 2323ffdd552327a8954de8ac37908029ec7cad38
Author: ARJANEN Loïc Jean David <arjanen.loic at gmail.com>
Date:   Sat May 12 08:35:27 2018 +0100

    Adds CTRL-C handler in Windows's timeout (trac issue #12721)
    
    Summary:
    Uses Win32's System.Win32.Console.CtrlHandler.withConsoleCtrlHandler to add
    to Windows's version of the timeout executable a CTRL-C/CTRL-BREAK
    handler which does the close IO port/kill job cleanup, just in case.
    
    Signed-off-by: ARJANEN Loïc Jean David <arjanen.loic at gmail.com>
    
    Reviewers: Phyx, bgamari
    
    Reviewed By: Phyx
    
    Subscribers: dfeuer, thomie, carter
    
    GHC Trac Issues: #12721
    
    Differential Revision: https://phabricator.haskell.org/D4631


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

2323ffdd552327a8954de8ac37908029ec7cad38
 testsuite/timeout/timeout.hs | 55 ++++++++++++++++++++++++++------------------
 1 file changed, 32 insertions(+), 23 deletions(-)

diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs
index f72efe3..9f3044f 100644
--- a/testsuite/timeout/timeout.hs
+++ b/testsuite/timeout/timeout.hs
@@ -1,4 +1,5 @@
 {-# OPTIONS -cpp #-}
+{-# LANGUAGE LambdaCase #-}
 module Main where
 
 import Control.Concurrent (forkIO, threadDelay)
@@ -21,6 +22,7 @@ import WinCBindings
 import Foreign
 import System.Win32.DebugApi
 import System.Win32.Types
+import System.Win32.Console.CtrlHandler
 #endif
 
 main :: IO ()
@@ -129,28 +131,35 @@ run secs cmd =
 
        let handleInterrupt action =
                action `onException` terminateJobObject job 99
-
-       handleInterrupt $ do
-          resumeThread (piThread pi)
-          -- The program is now running
-          let handle = piProcess pi
-          let millisecs = secs * 1000
-          rc <- waitForJobCompletion job ioPort (fromIntegral millisecs)
-          closeHandle ioPort
-
-          if not rc
-              then do terminateJobObject job 99
-                      closeHandle job
-                      exitWith (ExitFailure 99)
-              else alloca $ \p_exitCode ->
-                    do terminateJobObject job 0 -- Ensure it's all really dead.
-                       closeHandle job
-                       r <- getExitCodeProcess handle p_exitCode
-                       if r then do ec <- peek p_exitCode
-                                    let ec' = if ec == 0
-                                              then ExitSuccess
-                                              else ExitFailure $ fromIntegral ec
-                                    exitWith ec'
-                            else errorWin "getExitCodeProcess"
+           handleCtrl _ = do
+               terminateJobObject job 99
+               closeHandle ioPort
+               closeHandle job
+               exitWith (ExitFailure 99)
+               return True
+
+       withConsoleCtrlHandler handleCtrl $
+           handleInterrupt $ do
+              resumeThread (piThread pi)
+              -- The program is now running
+              let handle = piProcess pi
+              let millisecs = secs * 1000
+              rc <- waitForJobCompletion job ioPort (fromIntegral millisecs)
+              closeHandle ioPort
+
+              if not rc
+                then do terminateJobObject job 99
+                        closeHandle job
+                        exitWith (ExitFailure 99)
+                else alloca $ \p_exitCode ->
+                      do terminateJobObject job 0
+                         -- Ensured it's all really dead.
+                         closeHandle job
+                         r <- getExitCodeProcess handle p_exitCode
+                         if r
+                           then peek p_exitCode >>= \case
+                                   0 -> exitWith ExitSuccess
+                                   e -> exitWith $ ExitFailure (fromIntegral e)
+                           else errorWin "getExitCodeProcess"
 #endif