Commit 51e76b44 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

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.
parent 4ae9de8e
......@@ -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
......
{-# 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" #-}
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment