Add "ignore" commandHEADmaster

Changelog: Added `ignore` builtin command

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)