d0c66b1a72906fbb8597a9200943b230fbf51e7f
[ghc.git] / testsuite / timeout / timeout.hs
1 {-# OPTIONS -cpp #-}
2
3 import Control.Concurrent (forkIO, threadDelay)
4 import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
5 import Control.Exception (try)
6 import Data.Maybe (isNothing)
7 import System.Cmd (system)
8 import System.Environment (getArgs)
9 import System.Exit (exitWith, ExitCode(ExitFailure))
10 import System.IO (hPutStrLn, stderr)
11 import System.Process
12 import Control.Monad (when)
13 #if !defined(mingw32_HOST_OS)
14 import System.Process.Internals (mkProcessHandle)
15 import System.Posix.Process (forkProcess, createSession)
16 import System.Posix.Signals (installHandler, Handler(Catch),
17 signalProcessGroup, sigINT, sigTERM, sigKILL )
18 #endif
19
20
21
22 #if !defined(mingw32_HOST_OS)
23 main = do
24 args <- getArgs
25 case args of
26 [secs,cmd] -> do
27 m <- newEmptyMVar
28 mp <- newEmptyMVar
29 installHandler sigINT (Catch (putMVar m Nothing)) Nothing
30 forkIO (do threadDelay (read secs * 1000000)
31 putMVar m Nothing
32 )
33 forkIO (do try (do pid <- forkProcess $ do
34 createSession
35 r <- system cmd
36 exitWith r
37 ph <- mkProcessHandle pid
38 putMVar mp (pid,ph)
39 r <- waitForProcess ph
40 putMVar m (Just r))
41 return ())
42
43 (pid,ph) <- takeMVar mp
44 r <- takeMVar m
45 case r of
46 Nothing -> do
47 killProcess pid ph
48 exitWith (ExitFailure 99)
49 Just r -> do
50 exitWith r
51 _other -> do hPutStrLn stderr "timeout: bad arguments"
52 exitWith (ExitFailure 1)
53
54 killProcess pid ph = do
55 try (signalProcessGroup sigTERM pid)
56 checkReallyDead 10
57 where
58 checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up"
59 checkReallyDead (n+1) =
60 do threadDelay (3*100000) -- 3/10 sec
61 m <- getProcessExitCode ph
62 when (isNothing m) $ do
63 try (signalProcessGroup sigKILL pid)
64 checkReallyDead n
65
66 #else
67
68 main = do
69 args <- getArgs
70 case args of
71 [secs,cmd] -> do
72 m <- newEmptyMVar
73 mp <- newEmptyMVar
74 forkIO (do threadDelay (read secs * 1000000)
75 putMVar m Nothing
76 )
77 forkIO (do p <- runCommand cmd
78 putMVar mp p
79 r <- waitForProcess p
80 putMVar m (Just r))
81 p <- takeMVar mp
82 r <- takeMVar m
83 case r of
84 Nothing -> do
85 killProcess p
86 exitWith (ExitFailure 99)
87 Just r -> do
88 exitWith r
89 _other -> do hPutStrLn stderr "timeout: bad arguments"
90 exitWith (ExitFailure 1)
91
92 killProcess p = do
93 terminateProcess p
94 -- ToDo: we should kill the process and its descendents on Win32
95 threadDelay (3*100000) -- 3/10 sec
96 m <- getProcessExitCode p
97 when (isNothing m) $ killProcess p
98
99 #endif