Commit 2323ffdd authored by Azel's avatar Azel Committed by Tamar Christina

Adds CTRL-C handler in Windows's timeout (trac issue #12721)

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: Azel's avatarARJANEN Loïc Jean David <>

Reviewers: Phyx, bgamari

Reviewed By: Phyx

Subscribers: dfeuer, thomie, carter

GHC Trac Issues: #12721

Differential Revision:
parent 37810347
{-# 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
main :: IO ()
......@@ -129,7 +131,14 @@ run secs cmd =
let handleInterrupt action =
action `onException` terminateJobObject job 99
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
......@@ -143,14 +152,14 @@ run secs cmd =
closeHandle job
exitWith (ExitFailure 99)
else alloca $ \p_exitCode ->
do terminateJobObject job 0 -- Ensure it's all really dead.
do terminateJobObject job 0
-- Ensured 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'
if r
then peek p_exitCode >>= \case
0 -> exitWith ExitSuccess
e -> exitWith $ ExitFailure (fromIntegral e)
else errorWin "getExitCodeProcess"
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment