Fix some excessive spacing in error messages
[ghc.git] / testsuite / timeout / timeout.hs
1 {-# OPTIONS -cpp #-}
2 module Main where
3
4 import Control.Concurrent (forkIO, threadDelay)
5 import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
6 import Control.Monad
7 import Control.Exception
8 import Data.Maybe (isNothing)
9 import System.Environment (getArgs)
10 import System.Exit
11 import System.IO (hPutStrLn, stderr)
12
13 #if !defined(mingw32_HOST_OS)
14 import System.Posix hiding (killProcess)
15 import System.IO.Error hiding (try,catch)
16 #endif
17
18 #if defined(mingw32_HOST_OS)
19 import System.Process
20 import WinCBindings
21 import Foreign
22 import System.Win32.DebugApi
23 import System.Win32.Types
24 #endif
25
26 main :: IO ()
27 main = do
28 args <- getArgs
29 case args of
30 [secs,cmd] ->
31 case reads secs of
32 [(secs', "")] -> run secs' cmd
33 _ -> die ("Can't parse " ++ show secs ++ " as a number of seconds")
34 _ -> die ("Bad arguments " ++ show args)
35
36 run :: Int -> String -> IO ()
37 #if !defined(mingw32_HOST_OS)
38 run secs cmd = do
39 m <- newEmptyMVar
40 mp <- newEmptyMVar
41 installHandler sigINT (Catch (putMVar m Nothing)) Nothing
42 forkIO $ do threadDelay (secs * 1000000)
43 putMVar m Nothing
44 forkIO $ do ei <- try $ do pid <- systemSession cmd
45 return pid
46 putMVar mp ei
47 case ei of
48 Left _ -> return ()
49 Right pid -> do
50 r <- getProcessStatus True False pid
51 putMVar m r
52 ei_pid_ph <- takeMVar mp
53 case ei_pid_ph of
54 Left e -> do hPutStrLn stderr
55 ("Timeout:\n" ++ show (e :: IOException))
56 exitWith (ExitFailure 98)
57 Right pid -> do
58 r <- takeMVar m
59 case r of
60 Nothing -> do
61 killProcess pid
62 exitWith (ExitFailure 99)
63 Just (Exited r) -> exitWith r
64 Just (Terminated s) -> raiseSignal s
65 Just _ -> exitWith (ExitFailure 1)
66
67 systemSession cmd =
68 forkProcess $ do
69 createSession
70 executeFile "/bin/sh" False ["-c", cmd] Nothing
71 -- need to use exec() directly here, rather than something like
72 -- System.Process.system, because we are in a forked child and some
73 -- pthread libraries get all upset if you start doing certain
74 -- things in a forked child of a pthread process, such as forking
75 -- more threads.
76
77 killProcess pid = do
78 ignoreIOExceptions (signalProcessGroup sigTERM pid)
79 checkReallyDead 10
80 where
81 checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up"
82 checkReallyDead (n+1) =
83 do threadDelay (3*100000) -- 3/10 sec
84 m <- tryJust (guard . isDoesNotExistError) $
85 getProcessStatus False False pid
86 case m of
87 Right Nothing -> return ()
88 Left _ -> return ()
89 _ -> do
90 ignoreIOExceptions (signalProcessGroup sigKILL pid)
91 checkReallyDead n
92
93 ignoreIOExceptions :: IO () -> IO ()
94 ignoreIOExceptions io = io `catch` ((\_ -> return ()) :: IOException -> IO ())
95
96 #else
97 run secs cmd =
98 let escape '\\' = "\\\\"
99 escape '"' = "\\\""
100 escape c = [c]
101 cmd' = "sh -c \"" ++ concatMap escape cmd ++ "\"" in
102 alloca $ \p_startupinfo ->
103 alloca $ \p_pi ->
104 withTString cmd' $ \cmd'' ->
105 do job <- createJobObjectW nullPtr nullPtr
106 b_info <- setJobParameters job
107 unless b_info $ errorWin "setJobParameters"
108
109 ioPort <- createCompletionPort job
110 when (ioPort == nullPtr) $ errorWin "createCompletionPort, cannot continue."
111
112 -- We're explicitly turning off handle inheritance to prevent misc handles
113 -- from being inherited by the child. Notable we don't want the I/O Completion
114 -- Ports and Job handles to be inherited. So we mark them as non-inheritable.
115 setHandleInformation job cHANDLE_FLAG_INHERIT 0
116 setHandleInformation ioPort cHANDLE_FLAG_INHERIT 0
117
118 -- Now create the process suspended so we can add it to the job and then resume.
119 -- This is so we don't miss any events on the receiving end of the I/O port.
120 let creationflags = cCREATE_SUSPENDED
121 b <- createProcessW nullPtr cmd'' nullPtr nullPtr True
122 creationflags
123 nullPtr nullPtr p_startupinfo p_pi
124 unless b $ errorWin "createProcessW"
125
126 pi <- peek p_pi
127 b_assign <- assignProcessToJobObject job (piProcess pi)
128 unless b_assign $ errorWin "assignProcessToJobObject, cannot continue."
129
130 let handleInterrupt action =
131 action `onException` terminateJobObject job 99
132
133 handleInterrupt $ do
134 resumeThread (piThread pi)
135 -- The program is now running
136 let handle = piProcess pi
137 let millisecs = secs * 1000
138 rc <- waitForJobCompletion job ioPort (fromIntegral millisecs)
139 closeHandle ioPort
140
141 if not rc
142 then do terminateJobObject job 99
143 closeHandle job
144 exitWith (ExitFailure 99)
145 else alloca $ \p_exitCode ->
146 do terminateJobObject job 0 -- Ensure it's all really dead.
147 closeHandle job
148 r <- getExitCodeProcess handle p_exitCode
149 if r then do ec <- peek p_exitCode
150 let ec' = if ec == 0
151 then ExitSuccess
152 else ExitFailure $ fromIntegral ec
153 exitWith ec'
154 else errorWin "getExitCodeProcess"
155 #endif
156