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.

3 files changed, 248 insertions, 44 deletions

diff --git a/testsuite/timeout/Makefile b/testsuite/timeout/Makefile
index 923371209b..9f3a4e1304 100644
--- a/testsuite/timeout/Makefile
+++ b/testsuite/timeout/Makefile
@@ -6,7 +6,9 @@ MKDEPENDHS = $(GHC_INPLACE)
 SRC_HC_OPTS += -threaded
 EXCLUDED_SRCS += TimeMe.hs
 
-ifeq "$(Windows)" "NO"
+ifeq "$(Windows)" "YES"
+SRC_HC_OPTS += -package Win32
+else
 SRC_HC_OPTS += -package unix
 endif
 
diff --git a/testsuite/timeout/WinCBindings.hs b/testsuite/timeout/WinCBindings.hs
new file mode 100644
index 0000000000..1876726735
--- /dev/null
+++ b/testsuite/timeout/WinCBindings.hs
@@ -0,0 +1,193 @@
+{-# INCLUDE <windows.h> #-}

+{-# LINE 1 "WinCBindings.hsc" #-}

+{-# OPTIONS -cpp -fffi #-}

+{-# LINE 2 "WinCBindings.hsc" #-}

+

+module WinCBindings where

+

+

+{-# LINE 6 "WinCBindings.hsc" #-}

+

+import Foreign

+import System.Win32.File

+import System.Win32.Types

+

+

+{-# LINE 12 "WinCBindings.hsc" #-}

+

+type LPPROCESS_INFORMATION = Ptr PROCESS_INFORMATION

+data PROCESS_INFORMATION = PROCESS_INFORMATION

+    { piProcess :: HANDLE

+    , piThread :: HANDLE

+    , piProcessId :: DWORD

+    , piThreadId :: DWORD

+    } deriving Show

+

+instance Storable PROCESS_INFORMATION where

+    sizeOf = const (16)

+{-# LINE 23 "WinCBindings.hsc" #-}

+    alignment = sizeOf

+    poke buf pi = do

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 0))    buf (piProcess   pi)

+{-# LINE 26 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 4))     buf (piThread    pi)

+{-# LINE 27 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) buf (piProcessId pi)

+{-# LINE 28 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 12))  buf (piThreadId  pi)

+{-# LINE 29 "WinCBindings.hsc" #-}

+

+    peek buf = do

+        vhProcess    <- ((\hsc_ptr -> peekByteOff hsc_ptr 0))    buf

+{-# LINE 32 "WinCBindings.hsc" #-}

+        vhThread     <- ((\hsc_ptr -> peekByteOff hsc_ptr 4))     buf

+{-# LINE 33 "WinCBindings.hsc" #-}

+        vdwProcessId <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) buf

+{-# LINE 34 "WinCBindings.hsc" #-}

+        vdwThreadId  <- ((\hsc_ptr -> peekByteOff hsc_ptr 12))  buf

+{-# LINE 35 "WinCBindings.hsc" #-}

+        return $ PROCESS_INFORMATION {

+            piProcess   = vhProcess,

+            piThread    = vhThread,

+            piProcessId = vdwProcessId,

+            piThreadId  = vdwThreadId}

+

+type LPSTARTUPINFO = Ptr STARTUPINFO

+data STARTUPINFO = STARTUPINFO

+    { siCb :: DWORD

+    , siDesktop :: LPTSTR

+    , siTitle :: LPTSTR

+    , siX :: DWORD

+    , siY :: DWORD

+    , siXSize :: DWORD

+    , siYSize :: DWORD

+    , siXCountChars :: DWORD

+    , siYCountChars :: DWORD

+    , siFillAttribute :: DWORD

+    , siFlags :: DWORD

+    , siShowWindow :: WORD

+    , siStdInput :: HANDLE

+    , siStdOutput :: HANDLE

+    , siStdError :: HANDLE

+    } deriving Show

+

+instance Storable STARTUPINFO where

+    sizeOf = const (68)

+{-# LINE 62 "WinCBindings.hsc" #-}

+    alignment = sizeOf

+    poke buf si = do

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 0))              buf (siCb si)

+{-# LINE 65 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 8))       buf (siDesktop si)

+{-# LINE 66 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 12))         buf (siTitle si)

+{-# LINE 67 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 16))             buf (siX si)

+{-# LINE 68 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 20))             buf (siY si)

+{-# LINE 69 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 24))         buf (siXSize si)

+{-# LINE 70 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 28))         buf (siYSize si)

+{-# LINE 71 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 32))   buf (siXCountChars si)

+{-# LINE 72 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 36))   buf (siYCountChars si)

+{-# LINE 73 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) buf (siFillAttribute si)

+{-# LINE 74 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 44))         buf (siFlags si)

+{-# LINE 75 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 48))     buf (siShowWindow si)

+{-# LINE 76 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 56))       buf (siStdInput si)

+{-# LINE 77 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 60))      buf (siStdOutput si)

+{-# LINE 78 "WinCBindings.hsc" #-}

+        ((\hsc_ptr -> pokeByteOff hsc_ptr 64))       buf (siStdError si)

+{-# LINE 79 "WinCBindings.hsc" #-}

+

+    peek buf = do

+        vcb              <- ((\hsc_ptr -> peekByteOff hsc_ptr 0))              buf

+{-# LINE 82 "WinCBindings.hsc" #-}

+        vlpDesktop       <- ((\hsc_ptr -> peekByteOff hsc_ptr 8))       buf

+{-# LINE 83 "WinCBindings.hsc" #-}

+        vlpTitle         <- ((\hsc_ptr -> peekByteOff hsc_ptr 12))         buf

+{-# LINE 84 "WinCBindings.hsc" #-}

+        vdwX             <- ((\hsc_ptr -> peekByteOff hsc_ptr 16))             buf

+{-# LINE 85 "WinCBindings.hsc" #-}

+        vdwY             <- ((\hsc_ptr -> peekByteOff hsc_ptr 20))             buf

+{-# LINE 86 "WinCBindings.hsc" #-}

+        vdwXSize         <- ((\hsc_ptr -> peekByteOff hsc_ptr 24))         buf

+{-# LINE 87 "WinCBindings.hsc" #-}

+        vdwYSize         <- ((\hsc_ptr -> peekByteOff hsc_ptr 28))         buf

+{-# LINE 88 "WinCBindings.hsc" #-}

+        vdwXCountChars   <- ((\hsc_ptr -> peekByteOff hsc_ptr 32))   buf

+{-# LINE 89 "WinCBindings.hsc" #-}

+        vdwYCountChars   <- ((\hsc_ptr -> peekByteOff hsc_ptr 36))   buf

+{-# LINE 90 "WinCBindings.hsc" #-}

+        vdwFillAttribute <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) buf

+{-# LINE 91 "WinCBindings.hsc" #-}

+        vdwFlags         <- ((\hsc_ptr -> peekByteOff hsc_ptr 44))         buf

+{-# LINE 92 "WinCBindings.hsc" #-}

+        vwShowWindow     <- ((\hsc_ptr -> peekByteOff hsc_ptr 48))     buf

+{-# LINE 93 "WinCBindings.hsc" #-}

+        vhStdInput       <- ((\hsc_ptr -> peekByteOff hsc_ptr 56))       buf

+{-# LINE 94 "WinCBindings.hsc" #-}

+        vhStdOutput      <- ((\hsc_ptr -> peekByteOff hsc_ptr 60))      buf

+{-# LINE 95 "WinCBindings.hsc" #-}

+        vhStdError       <- ((\hsc_ptr -> peekByteOff hsc_ptr 64))       buf

+{-# LINE 96 "WinCBindings.hsc" #-}

+        return $ STARTUPINFO {

+            siCb            =  vcb,

+            siDesktop       =  vlpDesktop,

+            siTitle         =  vlpTitle,

+            siX             =  vdwX,

+            siY             =  vdwY,

+            siXSize         =  vdwXSize,

+            siYSize         =  vdwYSize,

+            siXCountChars   =  vdwXCountChars,

+            siYCountChars   =  vdwYCountChars,

+            siFillAttribute =  vdwFillAttribute,

+            siFlags         =  vdwFlags,

+            siShowWindow    =  vwShowWindow,

+            siStdInput      =  vhStdInput,

+            siStdOutput     =  vhStdOutput,

+            siStdError      =  vhStdError}

+

+foreign import stdcall unsafe "windows.h WaitForSingleObject"

+    waitForSingleObject :: HANDLE -> DWORD -> IO DWORD

+

+cWAIT_ABANDONED :: DWORD

+cWAIT_ABANDONED = 128

+{-# LINE 118 "WinCBindings.hsc" #-}

+

+cWAIT_OBJECT_0 :: DWORD

+cWAIT_OBJECT_0 = 0

+{-# LINE 121 "WinCBindings.hsc" #-}

+

+cWAIT_TIMEOUT :: DWORD

+cWAIT_TIMEOUT = 258

+{-# LINE 124 "WinCBindings.hsc" #-}

+

+foreign import stdcall unsafe "windows.h GetExitCodeProcess"

+    getExitCodeProcess :: HANDLE -> LPDWORD -> IO BOOL

+

+foreign import stdcall unsafe "windows.h TerminateJobObject"

+    terminateJobObject :: HANDLE -> UINT -> IO BOOL

+

+foreign import stdcall unsafe "windows.h AssignProcessToJobObject"

+    assignProcessToJobObject :: HANDLE -> HANDLE -> IO BOOL

+

+foreign import stdcall unsafe "windows.h CreateJobObjectW"

+    createJobObjectW :: LPSECURITY_ATTRIBUTES -> LPCTSTR -> IO HANDLE

+

+foreign import stdcall unsafe "windows.h CreateProcessW"

+    createProcessW :: LPCTSTR -> LPTSTR

+                   -> LPSECURITY_ATTRIBUTES -> LPSECURITY_ATTRIBUTES

+                   -> BOOL -> DWORD -> LPVOID -> LPCTSTR -> LPSTARTUPINFO

+                   -> LPPROCESS_INFORMATION -> IO BOOL

+

+

+{-# LINE 144 "WinCBindings.hsc" #-}

+

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
+