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