diff options
author | Ian Lynagh <igloo@earth.li> | 2008-01-20 11:15:32 +0000 |
---|---|---|
committer | Ian Lynagh <igloo@earth.li> | 2008-01-20 11:15:32 +0000 |
commit | 51e76b4432580d2fffd051868826239cec51a3c9 (patch) | |
tree | 381cc6d2aa56e452298bf7163552b652705275df /testsuite/timeout/timeout.hs | |
parent | 4ae9de8e7502c2525b28848d735da7ea092e7182 (diff) | |
download | haskell-51e76b4432580d2fffd051868826239cec51a3c9.tar.gz |
Fix #1599: Improve timeout on Windows
We now run programs in a Job, which means that we can kill a process
and all of its children when a timeout happens.
Diffstat (limited to 'testsuite/timeout/timeout.hs')
-rw-r--r-- | testsuite/timeout/timeout.hs | 95 |
1 files changed, 52 insertions, 43 deletions
diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs index edc69188af..74ba8f4a00 100644 --- a/testsuite/timeout/timeout.hs +++ b/testsuite/timeout/timeout.hs @@ -6,10 +6,11 @@ import Control.Exception (try) import Data.Maybe (isNothing) import System.Cmd (system) import System.Environment (getArgs) -import System.Exit (exitWith, ExitCode(ExitFailure)) +import System.Exit import System.IO (hPutStrLn, stderr) import System.Process -import Control.Monad (when) +import Control.Monad + #if !defined(mingw32_HOST_OS) import System.Process.Internals (mkProcessHandle) import System.Posix.Process (forkProcess, createSession, executeFile) @@ -17,17 +18,31 @@ import System.Posix.Signals (installHandler, Handler(Catch), signalProcessGroup, sigINT, sigTERM, sigKILL ) #endif +#if defined(mingw32_HOST_OS) +import WinCBindings +import Foreign +import System.Win32.DebugApi +import System.Win32.Types +#endif - -#if !defined(mingw32_HOST_OS) +main :: IO () main = do args <- getArgs case args of - [secs,cmd] -> do + [secs,cmd] -> run (read secs) cmd + _ -> do hPutStrLn stderr $ "timeout: bad arguments " ++ show args + exitWith (ExitFailure 1) + +timeoutMsg :: String +timeoutMsg = "Timeout happened...killing process..." + +run :: Int -> String -> IO () +#if !defined(mingw32_HOST_OS) +run secs cmd = do m <- newEmptyMVar mp <- newEmptyMVar installHandler sigINT (Catch (putMVar m Nothing)) Nothing - forkIO (do threadDelay (read secs * 1000000) + forkIO (do threadDelay (secs * 1000000) putMVar m Nothing ) forkIO (do try (do pid <- systemSession cmd @@ -41,13 +56,11 @@ main = do r <- takeMVar m case r of Nothing -> do - hPutStrLn stderr "Timeout happened...killing process..." + hPutStrLn stderr timeoutMsg killProcess pid ph exitWith (ExitFailure 99) Just r -> do exitWith r - _other -> do hPutStrLn stderr "timeout: bad arguments" - exitWith (ExitFailure 1) systemSession cmd = forkProcess $ do @@ -72,40 +85,36 @@ killProcess pid ph = do checkReallyDead n #else +run secs cmd = + alloca $ \p_startupinfo -> + alloca $ \p_pi -> + withTString ("sh -c \"" ++ cmd ++ "\"") $ \cmd' -> + do job <- createJobObjectW nullPtr nullPtr + let creationflags = 0 + b <- createProcessW nullPtr cmd' nullPtr nullPtr True + creationflags + nullPtr nullPtr p_startupinfo p_pi + unless b $ errorWin "createProcessW" + pi <- peek p_pi + assignProcessToJobObject job (piProcess pi) + resumeThread (piThread pi) -main = do - args <- getArgs - case args of - [secs,cmd] -> do - m <- newEmptyMVar - mp <- newEmptyMVar - forkIO (do threadDelay (read secs * 1000000) - putMVar m Nothing - ) - -- Assume sh.exe is in the path - forkIO (do p <- runProcess - "sh" ["-c",cmd] - Nothing Nothing Nothing Nothing Nothing - putMVar mp p - r <- waitForProcess p - putMVar m (Just r)) - p <- takeMVar mp - r <- takeMVar m - case r of - Nothing -> do - hPutStrLn stderr "Timeout happened...killing process..." - killProcess p - exitWith (ExitFailure 99) - Just r -> do - exitWith r - _other -> do hPutStrLn stderr $ "timeout: bad arguments " ++ show args - exitWith (ExitFailure 1) - -killProcess p = do - terminateProcess p - -- ToDo: we should kill the process and its descendents on Win32 - threadDelay (3*100000) -- 3/10 sec - m <- getProcessExitCode p - when (isNothing m) $ killProcess p + -- The program is now running + let handle = piProcess pi + let millisecs = secs * 1000 + rc <- waitForSingleObject handle (fromIntegral millisecs) + if rc == cWAIT_TIMEOUT + then do hPutStrLn stderr timeoutMsg + 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 + |