summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GDB.hs2
-rw-r--r--src/Process.hs84
-rw-r--r--src/Run.hs9
-rw-r--r--src/Script/Shell.hs8
-rw-r--r--src/Test/Builtins.hs12
5 files changed, 79 insertions, 36 deletions
diff --git a/src/GDB.hs b/src/GDB.hs
index 0819600..8d50d7f 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -72,12 +72,14 @@ gdbStart onCrash = do
{ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
}
pout <- liftIO $ newTVarIO []
+ ignore <- liftIO $ newTVarIO ( 0, [] )
let process = Process
{ procName = ProcNameGDB
, procHandle = Left handle
, procStdin = hin
, procOutput = pout
+ , procIgnore = ignore
, procKillWith = Nothing
, procNode = undefined
}
diff --git a/src/Process.hs b/src/Process.hs
index 8ea345d..0c24b4f 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -5,10 +5,14 @@ module Process (
send,
outProc,
lineReadingLoop,
+ startProcessIOLoops,
spawnOn,
closeProcess,
closeTestProcess,
withProcess,
+
+ IgnoreProcessOutput(..),
+ flushProcessOutput,
) where
import Control.Arrow
@@ -19,6 +23,7 @@ import Control.Monad.Except
import Control.Monad.Reader
import Data.Function
+import Data.Maybe
import Data.Scientific
import Data.Text (Text)
import Data.Text qualified as T
@@ -38,13 +43,16 @@ import Network
import Network.Ip
import Output
import Run.Monad
+import Script.Expr
import Script.Expr.Class
+import Script.Object
data Process = Process
{ procName :: ProcName
, procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode )
, procStdin :: Handle
- , procOutput :: TVar [Text]
+ , procOutput :: TVar [ Text ]
+ , procIgnore :: TVar ( Int, [ ( Int, Maybe Regex ) ] )
, procKillWith :: Maybe Signal
, procNode :: Node
}
@@ -93,8 +101,30 @@ lineReadingLoop process h act =
act line
lineReadingLoop process h act
+startProcessIOLoops :: Process -> Handle -> Handle -> TestRun ()
+startProcessIOLoops process@Process {..} hout herr = do
+
+ void $ forkTest $ lineReadingLoop process hout $ \line -> do
+ outProc OutputChildStdout process line
+ liftIO $ atomically $ do
+ ignores <- map snd . snd <$> readTVar procIgnore
+ when (not $ any (matches line) ignores) $ do
+ modifyTVar procOutput (++ [ line ])
+
+ void $ forkTest $ lineReadingLoop process herr $ \line -> do
+ case procName of
+ ProcNameTcpdump -> return ()
+ _ -> outProc OutputChildStderr process line
+
+ where
+ matches _ Nothing
+ = True
+ matches line (Just re)
+ | Right (Just _) <- regexMatch re line = True
+ | otherwise = False
+
spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process
-spawnOn target pname killWith cmd = do
+spawnOn target procName procKillWith cmd = do
-- When executing command given with relative path, turn it to absolute one,
-- because working directory will be changed for the shell wrapper.
cmd' <- liftIO $ do
@@ -108,33 +138,22 @@ spawnOn target pname killWith cmd = do
let netns = either getNetns getNetns target
currentEnv <- liftIO $ getEnvironment
- (Just hin, Just hout, Just herr, handle) <- liftIO $ do
+ (Just procStdin, Just hout, Just herr, handle) <- liftIO $ do
runInNetworkNamespace netns $ createProcess (shell cmd')
{ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
, cwd = Just (either netDir nodeDir target)
, env = Just $ ( "EREBOS_DIR", "." ) : currentEnv
}
- pout <- liftIO $ newTVarIO []
-
- let process = Process
- { procName = pname
- , procHandle = Left handle
- , procStdin = hin
- , procOutput = pout
- , procKillWith = killWith
- , procNode = either (const undefined) id target
- }
+ let procHandle = Left handle
+ procOutput <- liftIO $ newTVarIO []
+ procIgnore <- liftIO $ newTVarIO ( 0, [] )
+ let procNode = either (const undefined) id target
+ let process = Process {..}
- void $ forkTest $ lineReadingLoop process hout $ \line -> do
- outProc OutputChildStdout process line
- liftIO $ atomically $ modifyTVar pout (++[line])
- void $ forkTest $ lineReadingLoop process herr $ \line -> do
- case pname of
- ProcNameTcpdump -> return ()
- _ -> outProc OutputChildStderr process line
+ startProcessIOLoops process hout herr
asks (teGDB . fst) >>= maybe (return Nothing) (liftIO . tryReadMVar) >>= \case
- Just gdb | ProcName _ <- pname -> addInferior gdb process
+ Just gdb | ProcName _ <- procName -> addInferior gdb process
_ -> return ()
return process
@@ -173,3 +192,26 @@ withProcess target pname killWith cmd inner = do
ps <- liftIO $ takeMVar procVar
closeTestProcess process `finally` do
liftIO $ putMVar procVar $ filter (/=process) ps
+
+
+data IgnoreProcessOutput = IgnoreProcessOutput Process Int
+
+instance ObjectType TestRun IgnoreProcessOutput where
+ type ConstructorArgs IgnoreProcessOutput = ( Process, Maybe Regex )
+
+ createObject oid ( process@Process {..}, regex ) = do
+ liftIO $ atomically $ do
+ flushProcessOutput process regex
+ ( iid, list ) <- readTVar procIgnore
+ writeTVar procIgnore ( iid + 1, ( iid, regex ) : list )
+ return $ Object oid $ IgnoreProcessOutput process iid
+
+ destroyObject Object { objImpl = IgnoreProcessOutput Process {..} iid } = do
+ liftIO $ atomically $ do
+ writeTVar procIgnore . fmap (filter ((iid /=) . fst)) =<< readTVar procIgnore
+
+flushProcessOutput :: Process -> Maybe Regex -> STM ()
+flushProcessOutput p mbre = do
+ writeTVar (procOutput p) =<< case mbre of
+ Nothing -> return []
+ Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p)
diff --git a/src/Run.hs b/src/Run.hs
index b38bedd..a09947b 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -206,7 +206,7 @@ runStep = \case
expect line p expr captures $ runStep . inner
Flush p regex -> do
- flush p regex
+ atomicallyTest $ flushProcessOutput p regex
Guard line vars expr -> do
testStepGuard line vars expr
@@ -348,13 +348,6 @@ expect sline p (Traced trace re) tvars inner = do
Nothing -> exprFailed (T.pack "expect") sline (Just $ procName p) trace
-flush :: Process -> Maybe Regex -> TestRun ()
-flush p mbre = do
- atomicallyTest $ do
- writeTVar (procOutput p) =<< case mbre of
- Nothing -> return []
- Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p)
-
testStepGuard :: SourceLine -> EvalTrace -> Bool -> TestRun ()
testStepGuard sline vars x = do
when (not x) $ exprFailed (T.pack "guard") sline Nothing vars
diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs
index 1c052b0..23c3891 100644
--- a/src/Script/Shell.hs
+++ b/src/Script/Shell.hs
@@ -123,6 +123,7 @@ executeScript sei@ShellExecInfo {..} pstdin pstdout pstderr (ShellScript stateme
spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process
spawnShell procNode procName script = do
procOutput <- liftIO $ newTVarIO []
+ procIgnore <- liftIO $ newTVarIO ( 0, [] )
seiStatusVar <- liftIO $ newEmptyMVar
( pstdin, procStdin ) <- createPipeCloexec
( hout, pstdout ) <- createPipeCloexec
@@ -139,12 +140,7 @@ spawnShell procNode procName script = do
let procKillWith = Nothing
let process = Process {..}
- void $ forkTest $ lineReadingLoop process hout $ \line -> do
- outProc OutputChildStdout process line
- liftIO $ atomically $ modifyTVar procOutput (++ [ line ])
- void $ forkTest $ lineReadingLoop process herr $ \line -> do
- outProc OutputChildStderr process line
-
+ startProcessIOLoops process hout herr
return process
withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 6dba707..244ff57 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -8,7 +8,7 @@ import Data.Proxy
import Data.Scientific
import Data.Text (Text)
-import Process (Process)
+import Process
import Script.Expr
import Test
@@ -16,6 +16,7 @@ builtins :: GlobalDefs
builtins = M.fromList
[ fq "send" builtinSend
, fq "flush" builtinFlush
+ , fq "ignore" builtinIgnore
, fq "guard" builtinGuard
, fq "multiply_timeout" builtinMultiplyTimeout
, fq "wait" builtinWait
@@ -52,6 +53,15 @@ builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes
, ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )
]
+builtinIgnore :: SomeVarValue
+builtinIgnore = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
+ \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @IgnoreProcessOutput) ( getArg args (Just "from"), getArgMb args (Just "matching") )
+ where
+ atypes =
+ [ ( Just "from", SomeArgumentType (ContextDefault @Process) )
+ , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )
+ ]
+
builtinGuard :: SomeVarValue
builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
\sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing)
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 17:55:05 +0000