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
107
108
109
110
111
112
113
114
115
116
117
118
|
import Control.Concurrent.MVar (readMVar)
import System.Environment (getArgs)
import System.Exit (ExitCode (ExitFailure), exitFailure)
import System.IO (hClose, hGetLine, hPutStrLn)
import System.Posix.Process (exitImmediately, getProcessID)
import System.Posix.Signals (Handler (Catch), installHandler, sigHUP,
signalProcess)
import System.Process (StdStream (CreatePipe), createProcess, proc,
std_in, std_out, waitForProcess)
import System.Process.Internals (ProcessHandle (..),
ProcessHandle__ (OpenHandle))
import System.Timeout (timeout)
main :: IO ()
main = do
args <- getArgs
case args of
["--runghc", runghc] -> runParent runghc
["child"] -> runChild
_ -> error $ "Unknown args: " ++ show args
runParent :: FilePath -> IO ()
runParent runghc = do
(Just inH, Just outH, Nothing, ph@(ProcessHandle mvar _)) <-
createProcess (proc runghc ["T-signals-child.hs", "child"])
{ std_in = CreatePipe
, std_out = CreatePipe
}
-- Get the PID of the actual child process. This will initially be
-- runghc. If executeFile is used by runghc, that same process
-- will become the ghc process running our code from
-- runChild. Otherwise, runChild will run in a child of this
-- process.
OpenHandle childPid <- readMVar mvar
-- Get the PID of the process actually running the runChild code,
-- by reading it from its stdout (see runChild below).
pidS <- hGetLine outH
let pid = fromIntegral (read pidS :: Int)
-- Send the child process the HUP signal. We know this is after
-- the signal handler has been installed, since we already got the
-- PID from the process.
signalProcess sigHUP childPid
-- Send the child some input so that it will exit if it didn't
-- have a sigHUP handler installed.
hPutStrLn inH ""
hClose inH
-- Read out the rest of stdout from the child, which will be
-- either "NOSIGNAL\n" or "HUP\n"
rest <- hGetLine outH
-- Get the exit code of the child
ec <- waitForProcess ph
-- Check that everything matches
if childPid /= pid || rest /= hupMessage || ec /= hupExitCode
then do
-- Debugging display
putStrLn $ concat
[ "Child process: "
, show childPid
, ", real process: "
, show pid
]
putStrLn $ concat
[ "Expected "
, show hupMessage
, ", received: "
, show rest
]
putStrLn $ concat
[ "Expected "
, show hupExitCode
, ", received "
, show ec
]
exitFailure
else return ()
runChild :: IO ()
runChild = do
-- Install our sigHUP handler: print the HUP message and exit with
-- the HUP exit code.
let handler = Catch $ do
putStrLn hupMessage
exitImmediately hupExitCode
_ <- installHandler sigHUP handler Nothing
-- Get our actual process ID and print it to stdout.
pid <- getProcessID
print (fromIntegral pid :: Int)
-- Block until we receive input, giving a chance for the signal
-- handler to be triggered, and if the signal handler isn't
-- triggered, gives us an escape route from this function.
--
-- Include a reasonable timeout to prevent this from running for
-- too long
_ <- timeout 10000000 getLine
-- Reaching this point indicates a failure of the test. Print some
-- non HUP message and exit with a non HUP exit
-- code. Interestingly, in a failure, this exit code will _not_
-- be received by the parent process, since the runghc process
-- itself will exit with ExitFailure -1, indicating that it was
-- killed by signal 1 (SIGHUP).
putStrLn "No signal received"
exitImmediately $ ExitFailure 41
hupExitCode :: ExitCode
hupExitCode = ExitFailure 42
hupMessage :: String
hupMessage = "HUP"
|
