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

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: Azel's avatarARJANEN 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
parent 37810347
{-# OPTIONS -cpp #-} {-# OPTIONS -cpp #-}
{-# LANGUAGE LambdaCase #-}
module Main where module Main where
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
...@@ -21,6 +22,7 @@ import WinCBindings ...@@ -21,6 +22,7 @@ import WinCBindings
import Foreign import Foreign
import System.Win32.DebugApi import System.Win32.DebugApi
import System.Win32.Types import System.Win32.Types
import System.Win32.Console.CtrlHandler
#endif #endif
main :: IO () main :: IO ()
...@@ -129,28 +131,35 @@ run secs cmd = ...@@ -129,28 +131,35 @@ run secs cmd =
let handleInterrupt action = let handleInterrupt action =
action `onException` terminateJobObject job 99 action `onException` terminateJobObject job 99
handleCtrl _ = do
handleInterrupt $ do terminateJobObject job 99
resumeThread (piThread pi) closeHandle ioPort
-- The program is now running closeHandle job
let handle = piProcess pi exitWith (ExitFailure 99)
let millisecs = secs * 1000 return True
rc <- waitForJobCompletion job ioPort (fromIntegral millisecs)
closeHandle ioPort withConsoleCtrlHandler handleCtrl $
handleInterrupt $ do
if not rc resumeThread (piThread pi)
then do terminateJobObject job 99 -- The program is now running
closeHandle job let handle = piProcess pi
exitWith (ExitFailure 99) let millisecs = secs * 1000
else alloca $ \p_exitCode -> rc <- waitForJobCompletion job ioPort (fromIntegral millisecs)
do terminateJobObject job 0 -- Ensure it's all really dead. closeHandle ioPort
closeHandle job
r <- getExitCodeProcess handle p_exitCode if not rc
if r then do ec <- peek p_exitCode then do terminateJobObject job 99
let ec' = if ec == 0 closeHandle job
then ExitSuccess exitWith (ExitFailure 99)
else ExitFailure $ fromIntegral ec else alloca $ \p_exitCode ->
exitWith ec' do terminateJobObject job 0
else errorWin "getExitCodeProcess" -- 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 #endif
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