Fix #1599: Improve timeout on Windows
authorIan Lynagh <igloo@earth.li>
Sun, 20 Jan 2008 11:15:32 +0000 (11:15 +0000)
committerIan Lynagh <igloo@earth.li>
Sun, 20 Jan 2008 11:15:32 +0000 (11:15 +0000)
We now run programs in a Job, which means that we can kill a process
and all of its children when a timeout happens.

testsuite/timeout/Makefile
testsuite/timeout/WinCBindings.hs [new file with mode: 0644]
testsuite/timeout/timeout.hs

index 9233712..9f3a4e1 100644 (file)
@@ -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 (file)
index 0000000..1876726
--- /dev/null
@@ -0,0 +1,193 @@
+{-# INCLUDE <windows.h> #-}\r
+{-# LINE 1 "WinCBindings.hsc" #-}\r
+{-# OPTIONS -cpp -fffi #-}\r
+{-# LINE 2 "WinCBindings.hsc" #-}\r
+\r
+module WinCBindings where\r
+\r
+\r
+{-# LINE 6 "WinCBindings.hsc" #-}\r
+\r
+import Foreign\r
+import System.Win32.File\r
+import System.Win32.Types\r
+\r
+\r
+{-# LINE 12 "WinCBindings.hsc" #-}\r
+\r
+type LPPROCESS_INFORMATION = Ptr PROCESS_INFORMATION\r
+data PROCESS_INFORMATION = PROCESS_INFORMATION\r
+    { piProcess :: HANDLE\r
+    , piThread :: HANDLE\r
+    , piProcessId :: DWORD\r
+    , piThreadId :: DWORD\r
+    } deriving Show\r
+\r
+instance Storable PROCESS_INFORMATION where\r
+    sizeOf = const (16)\r
+{-# LINE 23 "WinCBindings.hsc" #-}\r
+    alignment = sizeOf\r
+    poke buf pi = do\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 0))    buf (piProcess   pi)\r
+{-# LINE 26 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 4))     buf (piThread    pi)\r
+{-# LINE 27 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) buf (piProcessId pi)\r
+{-# LINE 28 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 12))  buf (piThreadId  pi)\r
+{-# LINE 29 "WinCBindings.hsc" #-}\r
+\r
+    peek buf = do\r
+        vhProcess    <- ((\hsc_ptr -> peekByteOff hsc_ptr 0))    buf\r
+{-# LINE 32 "WinCBindings.hsc" #-}\r
+        vhThread     <- ((\hsc_ptr -> peekByteOff hsc_ptr 4))     buf\r
+{-# LINE 33 "WinCBindings.hsc" #-}\r
+        vdwProcessId <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) buf\r
+{-# LINE 34 "WinCBindings.hsc" #-}\r
+        vdwThreadId  <- ((\hsc_ptr -> peekByteOff hsc_ptr 12))  buf\r
+{-# LINE 35 "WinCBindings.hsc" #-}\r
+        return $ PROCESS_INFORMATION {\r
+            piProcess   = vhProcess,\r
+            piThread    = vhThread,\r
+            piProcessId = vdwProcessId,\r
+            piThreadId  = vdwThreadId}\r
+\r
+type LPSTARTUPINFO = Ptr STARTUPINFO\r
+data STARTUPINFO = STARTUPINFO\r
+    { siCb :: DWORD\r
+    , siDesktop :: LPTSTR\r
+    , siTitle :: LPTSTR\r
+    , siX :: DWORD\r
+    , siY :: DWORD\r
+    , siXSize :: DWORD\r
+    , siYSize :: DWORD\r
+    , siXCountChars :: DWORD\r
+    , siYCountChars :: DWORD\r
+    , siFillAttribute :: DWORD\r
+    , siFlags :: DWORD\r
+    , siShowWindow :: WORD\r
+    , siStdInput :: HANDLE\r
+    , siStdOutput :: HANDLE\r
+    , siStdError :: HANDLE\r
+    } deriving Show\r
+\r
+instance Storable STARTUPINFO where\r
+    sizeOf = const (68)\r
+{-# LINE 62 "WinCBindings.hsc" #-}\r
+    alignment = sizeOf\r
+    poke buf si = do\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 0))              buf (siCb si)\r
+{-# LINE 65 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 8))       buf (siDesktop si)\r
+{-# LINE 66 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 12))         buf (siTitle si)\r
+{-# LINE 67 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 16))             buf (siX si)\r
+{-# LINE 68 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 20))             buf (siY si)\r
+{-# LINE 69 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 24))         buf (siXSize si)\r
+{-# LINE 70 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 28))         buf (siYSize si)\r
+{-# LINE 71 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 32))   buf (siXCountChars si)\r
+{-# LINE 72 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 36))   buf (siYCountChars si)\r
+{-# LINE 73 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) buf (siFillAttribute si)\r
+{-# LINE 74 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 44))         buf (siFlags si)\r
+{-# LINE 75 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 48))     buf (siShowWindow si)\r
+{-# LINE 76 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 56))       buf (siStdInput si)\r
+{-# LINE 77 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 60))      buf (siStdOutput si)\r
+{-# LINE 78 "WinCBindings.hsc" #-}\r
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 64))       buf (siStdError si)\r
+{-# LINE 79 "WinCBindings.hsc" #-}\r
+\r
+    peek buf = do\r
+        vcb              <- ((\hsc_ptr -> peekByteOff hsc_ptr 0))              buf\r
+{-# LINE 82 "WinCBindings.hsc" #-}\r
+        vlpDesktop       <- ((\hsc_ptr -> peekByteOff hsc_ptr 8))       buf\r
+{-# LINE 83 "WinCBindings.hsc" #-}\r
+        vlpTitle         <- ((\hsc_ptr -> peekByteOff hsc_ptr 12))         buf\r
+{-# LINE 84 "WinCBindings.hsc" #-}\r
+        vdwX             <- ((\hsc_ptr -> peekByteOff hsc_ptr 16))             buf\r
+{-# LINE 85 "WinCBindings.hsc" #-}\r
+        vdwY             <- ((\hsc_ptr -> peekByteOff hsc_ptr 20))             buf\r
+{-# LINE 86 "WinCBindings.hsc" #-}\r
+        vdwXSize         <- ((\hsc_ptr -> peekByteOff hsc_ptr 24))         buf\r
+{-# LINE 87 "WinCBindings.hsc" #-}\r
+        vdwYSize         <- ((\hsc_ptr -> peekByteOff hsc_ptr 28))         buf\r
+{-# LINE 88 "WinCBindings.hsc" #-}\r
+        vdwXCountChars   <- ((\hsc_ptr -> peekByteOff hsc_ptr 32))   buf\r
+{-# LINE 89 "WinCBindings.hsc" #-}\r
+        vdwYCountChars   <- ((\hsc_ptr -> peekByteOff hsc_ptr 36))   buf\r
+{-# LINE 90 "WinCBindings.hsc" #-}\r
+        vdwFillAttribute <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) buf\r
+{-# LINE 91 "WinCBindings.hsc" #-}\r
+        vdwFlags         <- ((\hsc_ptr -> peekByteOff hsc_ptr 44))         buf\r
+{-# LINE 92 "WinCBindings.hsc" #-}\r
+        vwShowWindow     <- ((\hsc_ptr -> peekByteOff hsc_ptr 48))     buf\r
+{-# LINE 93 "WinCBindings.hsc" #-}\r
+        vhStdInput       <- ((\hsc_ptr -> peekByteOff hsc_ptr 56))       buf\r
+{-# LINE 94 "WinCBindings.hsc" #-}\r
+        vhStdOutput      <- ((\hsc_ptr -> peekByteOff hsc_ptr 60))      buf\r
+{-# LINE 95 "WinCBindings.hsc" #-}\r
+        vhStdError       <- ((\hsc_ptr -> peekByteOff hsc_ptr 64))       buf\r
+{-# LINE 96 "WinCBindings.hsc" #-}\r
+        return $ STARTUPINFO {\r
+            siCb            =  vcb,\r
+            siDesktop       =  vlpDesktop,\r
+            siTitle         =  vlpTitle,\r
+            siX             =  vdwX,\r
+            siY             =  vdwY,\r
+            siXSize         =  vdwXSize,\r
+            siYSize         =  vdwYSize,\r
+            siXCountChars   =  vdwXCountChars,\r
+            siYCountChars   =  vdwYCountChars,\r
+            siFillAttribute =  vdwFillAttribute,\r
+            siFlags         =  vdwFlags,\r
+            siShowWindow    =  vwShowWindow,\r
+            siStdInput      =  vhStdInput,\r
+            siStdOutput     =  vhStdOutput,\r
+            siStdError      =  vhStdError}\r
+\r
+foreign import stdcall unsafe "windows.h WaitForSingleObject"\r
+    waitForSingleObject :: HANDLE -> DWORD -> IO DWORD\r
+\r
+cWAIT_ABANDONED :: DWORD\r
+cWAIT_ABANDONED = 128\r
+{-# LINE 118 "WinCBindings.hsc" #-}\r
+\r
+cWAIT_OBJECT_0 :: DWORD\r
+cWAIT_OBJECT_0 = 0\r
+{-# LINE 121 "WinCBindings.hsc" #-}\r
+\r
+cWAIT_TIMEOUT :: DWORD\r
+cWAIT_TIMEOUT = 258\r
+{-# LINE 124 "WinCBindings.hsc" #-}\r
+\r
+foreign import stdcall unsafe "windows.h GetExitCodeProcess"\r
+    getExitCodeProcess :: HANDLE -> LPDWORD -> IO BOOL\r
+\r
+foreign import stdcall unsafe "windows.h TerminateJobObject"\r
+    terminateJobObject :: HANDLE -> UINT -> IO BOOL\r
+\r
+foreign import stdcall unsafe "windows.h AssignProcessToJobObject"\r
+    assignProcessToJobObject :: HANDLE -> HANDLE -> IO BOOL\r
+\r
+foreign import stdcall unsafe "windows.h CreateJobObjectW"\r
+    createJobObjectW :: LPSECURITY_ATTRIBUTES -> LPCTSTR -> IO HANDLE\r
+\r
+foreign import stdcall unsafe "windows.h CreateProcessW"\r
+    createProcessW :: LPCTSTR -> LPTSTR\r
+                   -> LPSECURITY_ATTRIBUTES -> LPSECURITY_ATTRIBUTES\r
+                   -> BOOL -> DWORD -> LPVOID -> LPCTSTR -> LPSTARTUPINFO\r
+                   -> LPPROCESS_INFORMATION -> IO BOOL\r
+\r
+\r
+{-# LINE 144 "WinCBindings.hsc" #-}\r
+\r
index edc6918..74ba8f4 100644 (file)
@@ -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
+