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@gmail.com>

Reviewers: Phyx, bgamari

Reviewed By: Phyx

Subscribers: dfeuer, thomie, carter

GHC Trac Issues: #12721

Differential Revision: https://phabricator.haskell.org/D4631

1 files changed, 32 insertions, 23 deletions

diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs
index f72efe30ae..9f3044f36d 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