diff options
Diffstat (limited to 'testsuite/timeout/timeout.hs')
| -rw-r--r-- | testsuite/timeout/timeout.hs | 173 |
1 files changed, 42 insertions, 131 deletions
diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs index 9f3044f36d..a156fbbce3 100644 --- a/testsuite/timeout/timeout.hs +++ b/testsuite/timeout/timeout.hs @@ -3,27 +3,15 @@ module Main where import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar) +import Control.Concurrent.MVar import Control.Monad import Control.Exception import Data.Maybe (isNothing) import System.Environment (getArgs) import System.Exit +import System.Process import System.IO (hPutStrLn, stderr) - -#if !defined(mingw32_HOST_OS) -import System.Posix hiding (killProcess) import System.IO.Error hiding (try,catch) -#endif - -#if defined(mingw32_HOST_OS) -import System.Process -import WinCBindings -import Foreign -import System.Win32.DebugApi -import System.Win32.Types -import System.Win32.Console.CtrlHandler -#endif main :: IO () main = do @@ -35,22 +23,40 @@ main = do _ -> die ("Can't parse " ++ show secs ++ " as a number of seconds") _ -> die ("Bad arguments " ++ show args) +data FinishedReason + = TimedOut + | Exited ExitCode + | InterruptedSignal + | OtherError SomeException + 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 (secs * 1000000) - putMVar m Nothing - forkIO $ do ei <- try $ do pid <- systemSession cmd - return pid - putMVar mp ei - case ei of - Left _ -> return () - Right pid -> do - r <- getProcessStatus True False pid - putMVar m r + m <- newEmptyMVar :: IO (MVar FinishedReason) + mp <- newEmptyMVar :: IO (MVar (Either IOException ProcessHandle)) + + -- The timeout thread + forkIO $ do + threadDelay (secs * 1000000) + putMVar m TimedOut + + -- the process itself + forkIO $ handle (\exc -> putMVar mp $ Left (userError $ show (exc :: SomeException))) $ do + ei <- fmap (fmap (\(_,_,_,ph) -> ph)) $ try $ createProcess (shell cmd) + { new_session = True + , use_process_jobs = True + } + putMVar mp ei + case ei of + Left _ -> return () + Right pid -> do + r <- waitForProcess pid + putMVar m (Exited r) + + -- Be sure to catch SIGINT while waiting + let handleINT UserInterrupt = putMVar m InterruptedSignal + handleINT other = throwIO other + + handle handleINT $ do ei_pid_ph <- takeMVar mp case ei_pid_ph of Left e -> do hPutStrLn stderr @@ -59,107 +65,12 @@ run secs cmd = do Right pid -> do r <- takeMVar m case r of - Nothing -> do - killProcess pid - exitWith (ExitFailure 99) - Just (Exited r) -> exitWith r - Just (Terminated s) -> raiseSignal s - Just _ -> exitWith (ExitFailure 1) - -systemSession cmd = - forkProcess $ do - createSession - executeFile "/bin/sh" False ["-c", cmd] Nothing - -- need to use exec() directly here, rather than something like - -- System.Process.system, because we are in a forked child and some - -- pthread libraries get all upset if you start doing certain - -- things in a forked child of a pthread process, such as forking - -- more threads. - -killProcess pid = do - ignoreIOExceptions (signalProcessGroup sigTERM pid) - checkReallyDead 10 - where - checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up" - checkReallyDead (n+1) = - do threadDelay (3*100000) -- 3/10 sec - m <- tryJust (guard . isDoesNotExistError) $ - getProcessStatus False False pid - case m of - Right Nothing -> return () - Left _ -> return () - _ -> do - ignoreIOExceptions (signalProcessGroup sigKILL pid) - checkReallyDead n - -ignoreIOExceptions :: IO () -> IO () -ignoreIOExceptions io = io `catch` ((\_ -> return ()) :: IOException -> IO ()) - -#else -run secs cmd = - let escape '\\' = "\\\\" - escape '"' = "\\\"" - escape c = [c] - cmd' = "sh -c \"" ++ concatMap escape cmd ++ "\"" in - alloca $ \p_startupinfo -> - alloca $ \p_pi -> - withTString cmd' $ \cmd'' -> - do job <- createJobObjectW nullPtr nullPtr - b_info <- setJobParameters job - unless b_info $ errorWin "setJobParameters" - - ioPort <- createCompletionPort job - when (ioPort == nullPtr) $ errorWin "createCompletionPort, cannot continue." - - -- We're explicitly turning off handle inheritance to prevent misc handles - -- from being inherited by the child. Notable we don't want the I/O Completion - -- Ports and Job handles to be inherited. So we mark them as non-inheritable. - setHandleInformation job cHANDLE_FLAG_INHERIT 0 - setHandleInformation ioPort cHANDLE_FLAG_INHERIT 0 - - -- Now create the process suspended so we can add it to the job and then resume. - -- This is so we don't miss any events on the receiving end of the I/O port. - let creationflags = cCREATE_SUSPENDED - b <- createProcessW nullPtr cmd'' nullPtr nullPtr True - creationflags - nullPtr nullPtr p_startupinfo p_pi - unless b $ errorWin "createProcessW" - - pi <- peek p_pi - b_assign <- assignProcessToJobObject job (piProcess pi) - unless b_assign $ errorWin "assignProcessToJobObject, cannot continue." - - let handleInterrupt action = - action `onException` terminateJobObject job 99 - handleCtrl _ = do - terminateJobObject job 99 - closeHandle ioPort - closeHandle job - exitWith (ExitFailure 99) - return True - - withConsoleCtrlHandler handleCtrl $ - handleInterrupt $ do - resumeThread (piThread pi) - -- The program is now running - let handle = piProcess pi - let millisecs = secs * 1000 - rc <- waitForJobCompletion job ioPort (fromIntegral millisecs) - closeHandle ioPort - - if not rc - then do terminateJobObject job 99 - closeHandle job + TimedOut -> do + interruptProcessGroupOf pid + terminateProcess pid exitWith (ExitFailure 99) - else alloca $ \p_exitCode -> - do terminateJobObject job 0 - -- Ensured it's all really dead. - closeHandle job - r <- getExitCodeProcess handle p_exitCode - if r - then peek p_exitCode >>= \case - 0 -> exitWith ExitSuccess - e -> exitWith $ ExitFailure (fromIntegral e) - else errorWin "getExitCodeProcess" -#endif - + InterruptedSignal -> do + interruptProcessGroupOf pid + terminateProcess pid + exitWith (ExitFailure 2) + Exited r -> exitWith r |