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.

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
+