From 51e76b4432580d2fffd051868826239cec51a3c9 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sun, 20 Jan 2008 11:15:32 +0000 Subject: 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. --- testsuite/timeout/Makefile | 4 +- testsuite/timeout/WinCBindings.hs | 193 ++++++++++++++++++++++++++++++++++++++ testsuite/timeout/timeout.hs | 95 ++++++++++--------- 3 files changed, 248 insertions(+), 44 deletions(-) create mode 100644 testsuite/timeout/WinCBindings.hs (limited to 'testsuite/timeout') 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 #-} +{-# 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 + -- cgit v1.2.1