summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2021-09-11 21:32:33 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2021-09-11 21:37:28 +0200
commit0995df8a9185c0128eb7350dae34e2c06f20aefd (patch)
tree1a2cb8cf67fea6695a7e7d44887b7e3c75404879
parent66a1261c68f123b604622e4729d966974198e50e (diff)
Report when child process terminates
-rw-r--r--erebos-tester.cabal1
-rw-r--r--src/Main.hs18
2 files changed, 19 insertions, 0 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index 3722a6e..9399c6d 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -47,5 +47,6 @@ executable erebos-tester-core
regex-tdfa ^>=1.3.1.0,
stm ^>=2.5.0.1,
text ^>=1.2.4.0,
+ unix ^>=2.7.2.2,
hs-source-dirs: src
default-language: Haskell2010
diff --git a/src/Main.hs b/src/Main.hs
index d4134bd..baec638 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -19,6 +19,8 @@ import System.Exit
import System.FilePath
import System.IO
import System.IO.Error
+import System.Posix.Process
+import System.Posix.Signals
import System.Process
import Parser
@@ -177,6 +179,21 @@ runTest :: String -> Test -> IO ()
runTest tool test = do
net <- initNetwork
+ let sigHandler SignalInfo { siginfoSpecific = chld } = do
+ nodes <- readMVar (netNodes net)
+ forM_ nodes $ \node -> do
+ processes <- readMVar (nodeProcesses node)
+ forM_ processes $ \p -> do
+ mbpid <- getPid (procHandle p)
+ when (mbpid == Just (siginfoPid chld)) $ do
+ let err detail = putStrLn $ "\ESC[31m" ++ unpackNodeName (nodeName node) ++ "!!> child " ++ detail ++ "\ESC[0m"
+ case siginfoStatus chld of
+ Exited ExitSuccess -> putStrLn $ unpackNodeName (nodeName node) ++ ".> child exited successfully"
+ Exited (ExitFailure code) -> err $ "process exited with status " ++ show code
+ Terminated sig _ -> err $ "terminated with signal " ++ show sig
+ Stopped sig -> err $ "stopped with signal " ++ show sig
+ oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing
+
forM_ (testSteps test) $ \case
Spawn pname nname -> do
node <- getNode net nname
@@ -195,6 +212,7 @@ runTest tool test = do
hFlush stdout
void $ getLine
+ _ <- installHandler processStatusChanged oldHandler Nothing
exitNetwork net
main :: IO ()