Custom signals to kill spawned processHEADmaster

Changelog: Added `killwith` clause to set a signal used to terminate `spawn`ed process.

6 files changed, 108 insertions, 14 deletions

diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 7876542..4548b63 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -430,6 +430,7 @@ testSpawn = command "spawn" $ Spawn
     <$> param "as"
     <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on")
     <*> (maybe [] fromExprParam <$> param "args")
+    <*> (maybe Nothing (Just . fromExprParam) <$> param "killwith")
     <*> innerBlockFun
 
 testExpect :: TestParser (Expr (TestBlock ()))
diff --git a/src/Process.hs b/src/Process.hs
index d4ee68b..4f4c286 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -2,6 +2,7 @@ module Process (
     Process(..),
     ProcessId(..), textProcId,
     ProcName(..), textProcName, unpackProcName,
+    Signal,
     send,
     outProc, outProcName,
     lineReadingLoop,
@@ -37,13 +38,13 @@ import System.FilePath
 import System.IO
 import System.IO.Error
 import System.Posix.Process
-import System.Posix.Signals
 import System.Process
 
 import {-# SOURCE #-} GDB
 import Network
 import Network.Ip
 import Output
+import Process.Signal
 import Run.Monad
 import Script.Expr
 import Script.Expr.Class
@@ -189,7 +190,7 @@ closeProcess timeout p = do
         Nothing -> return ()
         Just sig -> case procPid p of
             Nothing -> return ()
-            Just pid -> liftIO $ signalProcess sig pid
+            Just pid -> signalProcess sig pid
 
     liftIO $ void $ forkIO $ do
         threadDelay $ floor $ 1000000 * timeout
@@ -205,7 +206,7 @@ closeProcess timeout p = do
             outProc OutputChildFail p $ "exit code: " <> T.pack (show code)
             throwError Failed
         Just (Terminated sig _)
-            | Just sig == procKillWith p -> return ()
+            | Just (Signal sig) == procKillWith p -> return ()
             | otherwise -> do
                 outProc OutputChildFail p $ "killed with signal " <> T.pack (show sig)
                 throwError Failed
diff --git a/src/Process/Signal.hs b/src/Process/Signal.hs
new file mode 100644
index 0000000..f6619f6
--- /dev/null
+++ b/src/Process/Signal.hs
@@ -0,0 +1,88 @@
+module Process.Signal (
+    Signal(..),
+    signalBuiltins,
+    signalProcess,
+) where
+
+import Control.Monad.IO.Class
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import Script.Expr
+
+import System.Posix qualified as Posix
+
+
+newtype Signal = Signal Posix.Signal
+    deriving (Eq, Ord)
+
+instance ExprType Signal where
+    textExprType _ = "Signal"
+    textExprValue (Signal sig)
+        | sig == Posix.sigHUP = "SIGHUP"
+        | sig == Posix.sigINT = "SIGINT"
+        | sig == Posix.sigQUIT = "SIGQUIT"
+        | sig == Posix.sigILL = "SIGILL"
+        | sig == Posix.sigTRAP = "SIGTRAP"
+        | sig == Posix.sigABRT = "SIGABRT"
+        | sig == Posix.sigBUS = "SIGBUS"
+        | sig == Posix.sigFPE = "SIGFPE"
+        | sig == Posix.sigKILL = "SIGKILL"
+        | sig == Posix.sigUSR1 = "SIGUSR1"
+        | sig == Posix.sigSEGV = "SIGSEGV"
+        | sig == Posix.sigUSR2 = "SIGUSR2"
+        | sig == Posix.sigPIPE = "SIGPIPE"
+        | sig == Posix.sigALRM = "SIGALRM"
+        | sig == Posix.sigTERM = "SIGTERM"
+        | sig == Posix.sigCHLD = "SIGCHLD"
+        | sig == Posix.sigCONT = "SIGCONT"
+        | sig == Posix.sigSTOP = "SIGSTOP"
+        | sig == Posix.sigTSTP = "SIGTSTP"
+        | sig == Posix.sigTTIN = "SIGTTIN"
+        | sig == Posix.sigTTOU = "SIGTTOU"
+        | sig == Posix.sigURG = "SIGURG"
+        | sig == Posix.sigXCPU = "SIGXCPU"
+        | sig == Posix.sigXFSZ = "SIGXFSZ"
+        | sig == Posix.sigVTALRM = "SIGVTALRM"
+        | sig == Posix.sigPROF = "SIGPROF"
+        | sig == Posix.sigPOLL = "SIGPOLL"
+        | sig == Posix.sigSYS = "SIGSYS"
+        | otherwise = "<SIG_" <> T.pack (show sig) <> ">"
+
+
+signalBuiltins :: [ ( Text, SomeVarValue ) ]
+signalBuiltins = map (fmap someConstValue)
+    [ ( "SIGHUP", Signal Posix.sigHUP )
+    , ( "SIGINT", Signal Posix.sigINT )
+    , ( "SIGQUIT", Signal Posix.sigQUIT )
+    , ( "SIGILL", Signal Posix.sigILL )
+    , ( "SIGTRAP", Signal Posix.sigTRAP )
+    , ( "SIGABRT", Signal Posix.sigABRT )
+    , ( "SIGBUS", Signal Posix.sigBUS )
+    , ( "SIGFPE", Signal Posix.sigFPE )
+    , ( "SIGKILL", Signal Posix.sigKILL )
+    , ( "SIGUSR1", Signal Posix.sigUSR1 )
+    , ( "SIGSEGV", Signal Posix.sigSEGV )
+    , ( "SIGUSR2", Signal Posix.sigUSR2 )
+    , ( "SIGPIPE", Signal Posix.sigPIPE )
+    , ( "SIGALRM", Signal Posix.sigALRM )
+    , ( "SIGTERM", Signal Posix.sigTERM )
+    , ( "SIGCHLD", Signal Posix.sigCHLD )
+    , ( "SIGCONT", Signal Posix.sigCONT )
+    , ( "SIGSTOP", Signal Posix.sigSTOP )
+    , ( "SIGTSTP", Signal Posix.sigTSTP )
+    , ( "SIGTTIN", Signal Posix.sigTTIN )
+    , ( "SIGTTOU", Signal Posix.sigTTOU )
+    , ( "SIGURG", Signal Posix.sigURG )
+    , ( "SIGXCPU", Signal Posix.sigXCPU )
+    , ( "SIGXFSZ", Signal Posix.sigXFSZ )
+    , ( "SIGVTALRM", Signal Posix.sigVTALRM )
+    , ( "SIGPROF", Signal Posix.sigPROF )
+    , ( "SIGPOLL", Signal Posix.sigPOLL )
+    , ( "SIGSYS", Signal Posix.sigSYS )
+    ]
+
+
+signalProcess :: MonadIO m => Signal -> Posix.ProcessID -> m ()
+signalProcess (Signal sig) pid = liftIO $ Posix.signalProcess sig pid
diff --git a/src/Run.hs b/src/Run.hs
index 8a95daf..a23b254 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -38,6 +38,7 @@ import Network.Ip
 import Output
 import Parser
 import Process
+import Process.Signal
 import Run.Monad
 import Sandbox
 import Script.Expr
@@ -185,7 +186,7 @@ runStep = \case
     DeclNode name net inner -> do
         withNode net (Left name) $ runStep . inner
 
-    Spawn tvname@(TypedVarName (VarName tname)) target args inner -> do
+    Spawn tvname@(TypedVarName (VarName tname)) target args killWith inner -> do
         case target of
             Left net -> withNode net (Right tvname) go
             Right node -> go node
@@ -197,7 +198,7 @@ runStep = \case
                 cmd = T.unwords $ T.pack tool : map escape args
                 escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''"
             outProcName OutputChildExec pname cmd
-            withProcess (Right node) pname Nothing (T.unpack cmd) $ runStep . inner
+            withProcess (Right node) pname killWith (T.unpack cmd) $ runStep . inner
 
     SpawnShell mbname node script inner -> do
         let tname | Just (TypedVarName (VarName name)) <- mbname = name
@@ -254,7 +255,7 @@ withSubnet parent tvname inner = do
 withNetwork :: Network -> (Network -> TestRun a) -> TestRun a
 withNetwork net inner = do
     tcpdump <- asks (optTcpdump . teOptions . fst) >>= return . \case
-        Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination)
+        Just path -> withProcess (Left net) ProcNameTcpdump (Just (Signal softwareTermination))
             (path ++ " -i br0 -w './br0.pcap' -U -Z root") . const
         Nothing -> id
 
diff --git a/src/Test.hs b/src/Test.hs
index 2320d23..cfeaa2d 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -45,7 +45,7 @@ data TestStep a where
     CreateObject :: forall o. ObjectType TestRun o => Proxy o -> ConstructorArgs o -> TestStep ()
     Subnet :: TypedVarName Network -> Network -> (Network -> TestStep a) -> TestStep a
     DeclNode :: TypedVarName Node -> Network -> (Node -> TestStep a) -> TestStep a
-    Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> (Process -> TestStep a) -> TestStep a
+    Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> Maybe Signal -> (Process -> TestStep a) -> TestStep a
     SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a
     Send :: Process -> Text -> TestStep ()
     Expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 5f9f890..3dc6554 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -9,17 +9,20 @@ import Data.Scientific
 import Data.Text (Text)
 
 import Process
+import Process.Signal
 import Script.Expr
 import Test
 
 builtins :: GlobalDefs
-builtins = M.fromList
-    [ fq "send" builtinSend
-    , fq "flush" builtinFlush
-    , fq "ignore" builtinIgnore
-    , fq "guard" builtinGuard
-    , fq "multiply_timeout" builtinMultiplyTimeout
-    , fq "wait" builtinWait
+builtins = M.fromList $ concat
+    [ [ fq "send" builtinSend
+      , fq "flush" builtinFlush
+      , fq "ignore" builtinIgnore
+      , fq "guard" builtinGuard
+      , fq "multiply_timeout" builtinMultiplyTimeout
+      , fq "wait" builtinWait
+      ]
+    , map (uncurry fq) signalBuiltins
     ]
   where
     fq name impl = (( ModuleName [ "$" ], VarName name ), impl )