summaryrefslogtreecommitdiff
path: root/testsuite/timeout
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite/timeout')
-rw-r--r--testsuite/timeout/Makefile4
-rw-r--r--testsuite/timeout/WinCBindings.hs193
-rw-r--r--testsuite/timeout/timeout.hs95
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
+
View Lorry Controller Status