diff options
| author | Ben Gamari <bgamari.foss@gmail.com> | 2016-10-16 20:49:15 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2016-10-17 14:33:29 -0400 |
| commit | c6ee773a93397c197caa09db9f8d8145d9d930b0 (patch) | |
| tree | 64f74bbdd3b0445376dc05b333ceb2857fa6661a | |
| parent | 8bb960eff05ef8171ce2632a62db89b4e96aff74 (diff) | |
| download | haskell-c6ee773a93397c197caa09db9f8d8145d9d930b0.tar.gz | |
testsuite/timeout: Ensure that processes are cleaned up on Windows
Previously if the test is interrupted (e.g. with Ctrl-C) any processes
which it spawned may not be properly terminated. Here we catch any
exception and ensure that we job is terminated.
Test Plan: Validate on Windows
Reviewers: Phyx, austin
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D2599
| -rw-r--r-- | testsuite/timeout/timeout.hs | 35 |
1 files changed, 19 insertions, 16 deletions
diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs index 3684b9174c..c015eb6a80 100644 --- a/testsuite/timeout/timeout.hs +++ b/testsuite/timeout/timeout.hs @@ -110,23 +110,26 @@ run secs cmd = unless b $ errorWin "createProcessW" pi <- peek p_pi assignProcessToJobObject job (piProcess pi) - resumeThread (piThread pi) + let handleInterrupt action = + action `onException` terminateJobObject job 99 + handleInterrupt $ do + resumeThread (piThread pi) - -- The program is now running + -- The program is now running - let handle = piProcess pi - let millisecs = secs * 1000 - rc <- waitForSingleObject handle (fromIntegral millisecs) - if rc == cWAIT_TIMEOUT - then do terminateJobObject job 99 - exitWith (ExitFailure 99) - else alloca $ \p_exitCode -> - do 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" + let handle = piProcess pi + let millisecs = secs * 1000 + rc <- waitForSingleObject handle (fromIntegral millisecs) + if rc == cWAIT_TIMEOUT + then do terminateJobObject job 99 + exitWith (ExitFailure 99) + else alloca $ \p_exitCode -> + do 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" #endif |