summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Parser/Statement.hs1
-rw-r--r--src/Process.hs7
-rw-r--r--src/Process/Signal.hs88
-rw-r--r--src/Run.hs7
-rw-r--r--src/Test.hs2
-rw-r--r--src/Test/Builtins.hs17
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 )
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-11 20:32:53 +0000