packages feed

erebos-tester 0.3.2 → 0.3.3

raw patch · 18 files changed

+394/−125 lines, 18 files

Files

CHANGELOG.md view
@@ -1,5 +1,14 @@ # Revision history for erebos-tester +## 0.3.3 -- 2025-06-25++* Added optional `timeout` setting to config file+* Added `multiply_timeout` command+* Added `True` and `False` literals, and comparison operators for boolean values+* Added `--exclude` command-line option to exclude tests+* Execute shell commands in appropriate network namespace+* Show name of failed test in output+ ## 0.3.2 -- 2025-05-16  * Asset files and directories for use during tests
README.md view
@@ -88,6 +88,7 @@  * `tool`: path to the test tool, which may be overridden by the `--tool` command-line option. * `tests`: glob pattern that expands to all the test script files that should be used.+* `timeout`: initial timeout for test steps like `expect`, given as `int` or `float`; defaults to `1` if not specified.  Script language ---------------@@ -178,6 +179,7 @@ #### boolean  Result of comparison operators `==` and `/=`.+Values are `True` and `False`.  #### network @@ -335,6 +337,13 @@ Execute `<test block>` with `<expr>` as context.  ```+multiply_timeout by <multiplier>+```++Modify the timeout used for commands like `expect` by multiplying it with `<multiplier>`.+The effect lasts until the end of the block.++``` wait ``` @@ -466,9 +475,17 @@     send to p "use-asset ${my_asset.path}" ``` -The `my_asset.path` expression expands to a strict containing path to the asset-that can be used by the spawn process `p`. The process should not try to modify-the file.+The `my_asset.path` expression expands to a string containing path to the asset+that can be used by the spawned process `p`. The process should not try to+modify the file.++Assets can be exported for use in other modules using the `export` keyword,+just like other definitions:++```+export asset my_asset:+    path: ../path/to/file+```   Optional dependencies
erebos-tester.cabal view
@@ -1,7 +1,7 @@ cabal-version:       3.0  name:                erebos-tester-version:             0.3.2+version:             0.3.3 synopsis:            Test framework with virtual network using Linux namespaces description:     This framework is intended mainly for networking libraries/applications and@@ -65,6 +65,7 @@         Script.Expr         Script.Expr.Class         Script.Module+        Script.Object         Script.Shell         Script.Var         Test
src/Config.hs view
@@ -2,11 +2,13 @@     Config(..),     findConfig,     parseConfig,+    getConfigTestFiles, ) where  import Control.Monad.Combinators  import Data.ByteString.Lazy qualified as BS+import Data.Scientific import Data.Text qualified as T import Data.YAML @@ -16,32 +18,32 @@ import System.FilePath.Glob  data Config = Config-    { configTool :: Maybe FilePath-    , configTests :: [Pattern]+    { configDir :: FilePath+    , configTool :: Maybe FilePath+    , configTests :: [ Pattern ]+    , configTimeout :: Maybe Scientific     }     deriving (Show) -instance Semigroup Config where-    a <> b = Config-        { configTool = maybe (configTool b) Just (configTool a)-        , configTests = configTests a ++ configTests b-        }--instance Monoid Config where-    mempty = Config-        { configTool = Nothing-        , configTests = []-        }--instance FromYAML Config where-    parseYAML = withMap "Config" $ \m -> Config-        <$> (fmap T.unpack <$> m .:? "tool")-        <*> (map (compile . T.unpack) <$> foldr1 (<|>)+instance FromYAML (FilePath -> Config) where+    parseYAML = withMap "Config" $ \m -> do+        configTool <- (fmap T.unpack <$> m .:? "tool")+        configTests <- (map (compile . T.unpack) <$> foldr1 (<|>)                 [ fmap (:[]) (m .: "tests") -- single pattern                 , m .:? "tests" .!= []      -- list of patterns                 ]             )+        configTimeout <- fmap fromNumber <$> m .:! "timeout"+        return $ \configDir -> Config {..} +newtype Number = Number { fromNumber :: Scientific }++instance FromYAML Number where+    parseYAML = \case+        Scalar _ (SFloat x) -> return $ Number $ realToFrac x+        Scalar _ (SInt x) -> return $ Number $ fromIntegral x+        node -> typeMismatch "int or float" node+ findConfig :: IO (Maybe FilePath) findConfig = go "."   where@@ -63,4 +65,7 @@         Left (pos, err) -> do             putStr $ prettyPosWithSource pos contents err             exitFailure-        Right conf -> return conf+        Right conf -> return $ conf $ takeDirectory path++getConfigTestFiles :: Config -> IO [ FilePath ]+getConfigTestFiles config = concat <$> mapM (flip globDir1 $ configDir config) (configTests config)
src/Main.hs view
@@ -2,27 +2,24 @@  import Control.Monad -import Data.Bifunctor import Data.List import Data.Maybe+import Data.Text (Text) import Data.Text qualified as T  import Text.Read (readMaybe)-import Text.Megaparsec (errorBundlePretty, showErrorComponent)  import System.Console.GetOpt import System.Directory import System.Environment import System.Exit import System.FilePath-import System.FilePath.Glob import System.IO import System.Posix.Terminal import System.Posix.Types  import Config import Output-import Parser import Process import Run import Script.Module@@ -34,6 +31,7 @@ data CmdlineOptions = CmdlineOptions     { optTest :: TestOptions     , optRepeat :: Int+    , optExclude :: [ Text ]     , optVerbose :: Bool     , optColor :: Maybe Bool     , optShowHelp :: Bool@@ -45,6 +43,7 @@ defaultCmdlineOptions = CmdlineOptions     { optTest = defaultTestOptions     , optRepeat = 1+    , optExclude = []     , optVerbose = False     , optColor = Nothing     , optShowHelp = False@@ -86,6 +85,9 @@     , Option ['r'] ["repeat"]         (ReqArg (\str opts -> opts { optRepeat = read str }) "<count>")         "number of times to repeat the test(s)"+    , Option [ 'e' ] [ "exclude" ]+        (ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test>")+        "exclude given test from execution"     , Option [] ["wait"]         (NoArg $ to $ \opts -> opts { optWait = True })         "wait at the end of each test"@@ -108,9 +110,8 @@  main :: IO () main = do-    configPath <- findConfig-    config <- mapM parseConfig configPath-    let baseDir = maybe "." dropFileName configPath+    config <- mapM parseConfig =<< findConfig+    let baseDir = maybe "." configDir config      envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool ->         return $ fromMaybe (error "No test tool defined") $ mbtool `mplus` (return . (baseDir </>) =<< configTool =<< config)@@ -119,6 +120,7 @@             { optTest = defaultTestOptions                 { optDefaultTool = envtool                 , optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions+                , optTimeout = fromMaybe (optTimeout defaultTestOptions) $ configTimeout =<< config                 }             } @@ -151,7 +153,7 @@         exitSuccess      when (optTestMode opts) $ do-        testMode+        testMode config         exitSuccess      case words $ optDefaultTool $ optTest opts of@@ -165,7 +167,7 @@             case span (/= ':') ofile of                 (path, ':':test) -> (path, Just $ T.pack test)                 (path, _)        -> (path, Nothing)-        else map (, Nothing) . concat <$> mapM (flip globDir1 baseDir) (maybe [] configTests config)+        else map (, Nothing) <$> maybe (return []) (getConfigTestFiles) config      when (null files) $ fail $ "No test files" @@ -177,18 +179,8 @@             | otherwise       = OutputStyleQuiet     out <- startOutput outputStyle useColor -    ( modules, allModules ) <- parseTestFiles (map fst files) >>= \case-        Right res -> do-            return res-        Left err -> do-            case err of-                ImportModuleError bundle ->-                    putStr (errorBundlePretty bundle)-                _ -> do-                    putStrLn (showErrorComponent err)-            exitFailure--    tests <- if null otests+    ( modules, globalDefs ) <- loadModules (map fst files)+    tests <- filter ((`notElem` optExclude opts) . testName) <$> if null otests         then fmap concat $ forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do             case mbTestName of                 Nothing -> return moduleTests@@ -206,9 +198,6 @@                 -> do                     hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found"                     exitFailure---    let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules      ok <- allM (runTest out (optTest opts) globalDefs) $         concat $ replicate (optRepeat opts) tests
src/Network/Ip.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Network.Ip (     IpPrefix(..),     textIpNetwork,@@ -17,7 +19,9 @@     NetworkNamespace,     HasNetns(..),     addNetworkNamespace,+    setNetworkNamespace,     textNetnsName,+    runInNetworkNamespace,     callOn,      Link(..),@@ -32,7 +36,9 @@     addRoute, ) where +import Control.Concurrent import Control.Concurrent.STM+import Control.Exception import Control.Monad import Control.Monad.Writer @@ -42,6 +48,11 @@ import Data.Typeable import Data.Word +import Foreign.C.Error+import Foreign.C.Types++import System.Posix.IO+import System.Posix.Types import System.Process  newtype IpPrefix = IpPrefix [Word8]@@ -122,12 +133,37 @@     netnsRoutesActive <- liftSTM $ newTVar []     return $ NetworkNamespace {..} +setNetworkNamespace :: MonadIO m => NetworkNamespace -> m ()+setNetworkNamespace netns = liftIO $ do+    let path = "/var/run/netns/" <> T.unpack (textNetnsName netns)+#if MIN_VERSION_unix(2,8,0)+        open = openFd path ReadOnly defaultFileFlags { cloexec = True }+#else+        open = openFd path ReadOnly Nothing defaultFileFlags+#endif+    res <- bracket open closeFd $ \(Fd fd) -> do+        c_setns fd c_CLONE_NEWNET+    when (res /= 0) $ do+        throwErrno "setns failed"++foreign import ccall unsafe "sched.h setns" c_setns :: CInt -> CInt -> IO CInt+c_CLONE_NEWNET :: CInt+c_CLONE_NEWNET = 0x40000000++runInNetworkNamespace :: NetworkNamespace -> IO a -> IO a+runInNetworkNamespace netns act = do+    mvar <- newEmptyMVar+    void $ forkOS $ do+        setNetworkNamespace netns+        putMVar mvar =<< act+    takeMVar mvar++ textNetnsName :: NetworkNamespace -> Text textNetnsName = netnsName  callOn :: HasNetns a => a -> Text -> IO ()-callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> ns <> "\" " <> cmd-    where ns = textNetnsName $ getNetns n+callOn n cmd = runInNetworkNamespace (getNetns n) $ callCommand $ T.unpack cmd   data Link a = Link
src/Parser.hs view
@@ -43,7 +43,7 @@         modify $ \s -> s             { testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar             }-        block (\name steps -> return $ Test name $ mconcat steps) header testStep+        block (\name steps -> return $ Test name $ Scope <$> mconcat steps) header testStep   where     header = do         wsymbol "test"@@ -64,7 +64,7 @@                 osymbol ":"                 scn                 ref <- L.indentGuard scn GT href-                SomeExpr <$> blockOf ref testStep+                SomeExpr <$> testBlock ref             , do                 osymbol "="                 someExpr <* eol
src/Parser/Expr.hs view
@@ -118,6 +118,13 @@              else return $ SomeExpr $ Pure x         ] +boolLiteral :: TestParser SomeExpr+boolLiteral = label "bool" $ lexeme $ do+    SomeExpr . Pure <$> choice+        [ wsymbol "True"  *> return True+        , wsymbol "False" *> return False+        ]+ quotedString :: TestParser (Expr Text) quotedString = label "string" $ lexeme $ do     void $ char '"'@@ -261,11 +268,13 @@                               [ SomeBinOp ((==) @Integer)                               , SomeBinOp ((==) @Scientific)                               , SomeBinOp ((==) @Text)+                              , SomeBinOp ((==) @Bool)                               ]               , binary' "/=" (\op xs ys -> length xs /= length ys || or  (zipWith op xs ys)) $                               [ SomeBinOp ((/=) @Integer)                               , SomeBinOp ((/=) @Scientific)                               , SomeBinOp ((/=) @Text)+                              , SomeBinOp ((/=) @Bool)                               ]               , binary ">" $                   [ SomeBinOp ((>) @Integer)@@ -347,6 +356,7 @@ literal :: TestParser SomeExpr literal = label "literal" $ choice     [ numberLiteral+    , boolLiteral     , SomeExpr <$> quotedString     , SomeExpr <$> regex     , list
src/Parser/Shell.hs view
@@ -3,6 +3,7 @@     shellScript, ) where +import Control.Applicative (liftA2) import Control.Monad  import Data.Char@@ -66,11 +67,13 @@  shellStatement :: TestParser (Expr [ ShellStatement ]) shellStatement = label "shell statement" $ do+    line <- getSourceLine     command <- parseArgument     args <- parseArguments     return $ fmap (: []) $ ShellStatement         <$> command         <*> args+        <*> pure line  shellScript :: TestParser (Expr ShellScript) shellScript = do
src/Parser/Statement.hs view
@@ -1,5 +1,6 @@ module Parser.Statement (     testStep,+    testBlock, ) where  import Control.Monad@@ -43,7 +44,7 @@         addVarName off tname         void $ eol         body <- testBlock indent-        return $ Let line tname e body+        return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body)  forStatement :: TestParser (Expr (TestBlock ())) forStatement = do@@ -68,7 +69,7 @@         body <- testBlock indent         return $ (\xs f -> mconcat $ map f xs)             <$> (unpack <$> e)-            <*> LambdaAbstraction tname body+            <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body)  shellStatement :: TestParser (Expr (TestBlock ())) shellStatement = do@@ -108,7 +109,7 @@             void eol             void $ L.indentGuard scn GT ref             script <- shellScript-            cont <- testBlock ref+            cont <- fmap Scope <$> testBlock ref             let expr | Just pname <- mbpname = LambdaAbstraction pname cont                      | otherwise = const <$> cont             return $ TestBlockStep EmptyTestBlock <$>@@ -290,14 +291,14 @@         combine f (x : xs) = f x xs         combine _ [] = error "inner block parameter count mismatch" -innerBlock :: CommandDef (TestBlock ())+innerBlock :: CommandDef (TestStep ()) innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun -innerBlockFun :: ExprType a => CommandDef (a -> TestBlock ())+innerBlockFun :: ExprType a => CommandDef (a -> TestStep ()) innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList -innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock ())-innerBlockFunList = fromInnerBlock <$> param ""+innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ())+innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param ""  newtype ExprParam a = ExprParam { fromExprParam :: a }     deriving (Functor, Foldable, Traversable)@@ -380,7 +381,8 @@     void $ eol      indent <- L.indentGuard scn GT ref-    localState $ testBlock indent+    localState $ do+        fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent  testWith :: TestParser (Expr (TestBlock ())) testWith = do@@ -406,7 +408,7 @@     indent <- L.indentGuard scn GT ref     localState $ do         modify $ \s -> s { testContext = ctx }-        testBlock indent+        fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent  testSubnet :: TestParser (Expr (TestBlock ())) testSubnet = command "subnet" $ Subnet
src/Process.hs view
@@ -7,6 +7,7 @@     lineReadingLoop,     spawnOn,     closeProcess,+    closeTestProcess,     withProcess, ) where @@ -18,9 +19,10 @@ import Control.Monad.Reader  import Data.Function+import Data.Scientific import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T+import Data.Text qualified as T+import Data.Text.IO qualified as T  import System.Directory import System.Environment@@ -93,7 +95,7 @@ spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process spawnOn target pname killWith cmd = do     -- When executing command given with relative path, turn it to absolute one,-    -- because working directory will be changed for the "ip netns exec" wrapper.+    -- because working directory will be changed for the shell wrapper.     cmd' <- liftIO $ do         case span (/= ' ') cmd of             ( path, rest )@@ -104,13 +106,13 @@             _ -> return cmd      let netns = either getNetns getNetns target-    let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" "     currentEnv <- liftIO $ getEnvironment-    (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd')-        { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe-        , cwd = Just (either netDir nodeDir target)-        , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv-        }+    (Just hin, 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@@ -136,8 +138,8 @@      return process -closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m ()-closeProcess p = do+closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Scientific -> Process -> m ()+closeProcess timeout p = do     liftIO $ hClose $ procStdin p     case procKillWith p of         Nothing -> return ()@@ -146,7 +148,7 @@             Just pid -> signalProcess sig pid      liftIO $ void $ forkIO $ do-        threadDelay 1000000+        threadDelay $ floor $ 1000000 * timeout         either terminateProcess (killThread . fst) $ procHandle p     liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) >>= \case         ExitSuccess -> return ()@@ -154,6 +156,11 @@             outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code             throwError Failed +closeTestProcess :: Process -> TestRun ()+closeTestProcess process = do+    timeout <- liftIO . readMVar =<< asks (teTimeout . fst)+    closeProcess timeout process+ withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a withProcess target pname killWith cmd inner = do     procVar <- asks $ teProcesses . fst@@ -163,5 +170,5 @@      inner process `finally` do         ps <- liftIO $ takeMVar procVar-        closeProcess process `finally` do+        closeTestProcess process `finally` do             liftIO $ putMVar procVar $ filter (/=process) ps
src/Run.hs view
@@ -1,6 +1,7 @@ module Run (     module Run.Monad,     runTest,+    loadModules,     evalGlobalDefs, ) where @@ -11,13 +12,16 @@ import Control.Monad.Except import Control.Monad.Fix import Control.Monad.Reader+import Control.Monad.Writer +import Data.Bifunctor import Data.Map qualified as M import Data.Maybe-import Data.Set qualified as S+import Data.Proxy import Data.Scientific+import Data.Set qualified as S import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified as T  import System.Directory import System.Exit@@ -26,17 +30,23 @@ import System.Posix.Signals import System.Process +import Text.Megaparsec (errorBundlePretty, showErrorComponent)+ import GDB import Network import Network.Ip import Output+import Parser import Process import Run.Monad import Script.Expr+import Script.Module+import Script.Object import Script.Shell import Test import Test.Builtins + runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool runTest out opts gdefs test = do     let testDir = optTestDir opts@@ -47,7 +57,9 @@     createDirectoryIfMissing True testDir      failedVar <- newTVarIO Nothing+    objIdVar <- newMVar 1     procVar <- newMVar []+    timeoutVar <- newMVar $ optTimeout opts      mgdb <- if optGDB opts         then flip runReaderT out $ do@@ -59,7 +71,9 @@             { teOutput = out             , teFailed = failedVar             , teOptions = opts+            , teNextObjId = objIdVar             , teProcesses = procVar+            , teTimeout = timeoutVar             , teGDB = fst <$> mgdb             }         tstate = TestState@@ -88,16 +102,16 @@     oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing      resetOutputTime out-    res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do+    ( res, [] ) <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do         withInternet $ \_ -> do-            evalBlock =<< eval (testSteps test)+            runStep =<< eval (testSteps test)             when (optWait opts) $ do                 void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."      void $ installHandler processStatusChanged oldHandler Nothing      Right () <- runExceptT $ flip runReaderT out $ do-        maybe (return ()) (closeProcess . snd) mgdb+        maybe (return ()) (closeProcess 1 . snd) mgdb     [] <- readMVar procVar      failed <- atomically $ readTVar (teFailed tenv)@@ -105,21 +119,54 @@         (Right (), Nothing) -> do             when (not $ optKeep opts) $ removeDirectoryRecursive testDir             return True-        _ -> return False+        _ -> do+            flip runReaderT out $ do+                void $ outLine OutputError Nothing $ "Test ‘" <> testName test <> "’ failed."+            return False  +loadModules :: [ FilePath ] -> IO ( [ Module ], GlobalDefs )+loadModules files = do+    ( modules, allModules ) <- parseTestFiles files >>= \case+        Right res -> do+            return res+        Left err -> do+            case err of+                ImportModuleError bundle ->+                    putStr (errorBundlePretty bundle)+                _ -> do+                    putStrLn (showErrorComponent err)+            exitFailure+    let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules+    return ( modules, globalDefs )++ evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs evalGlobalDefs exprs = fix $ \gdefs ->     builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs) -evalBlock :: TestBlock () -> TestRun ()-evalBlock EmptyTestBlock = return ()-evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of+runBlock :: TestBlock () -> TestRun ()+runBlock EmptyTestBlock = return ()+runBlock (TestBlockStep prev step) = runBlock prev >> runStep step++runStep :: TestStep () -> TestRun ()+runStep = \case+    Scope block -> do+        ( x, objs ) <- censor (const []) $ listen $ catchError (Right <$> runBlock block) (return . Left)+        mapM_ destroySomeObject (reverse objs)+        either throwError return x++    CreateObject (Proxy :: Proxy o) cargs -> do+        objIdVar <- asks (teNextObjId . fst)+        oid <- liftIO $ modifyMVar objIdVar (\x -> return ( x + 1, x ))+        obj <- createObject @TestRun @o (ObjectId oid) cargs+        tell [ toSomeObject obj ]+     Subnet name parent inner -> do-        withSubnet parent (Just name) $ evalBlock . inner+        withSubnet parent (Just name) $ runStep . inner      DeclNode name net inner -> do-        withNode net (Left name) $ evalBlock . inner+        withNode net (Left name) $ runStep . inner      Spawn tvname@(TypedVarName (VarName tname)) target args inner -> do         case target of@@ -132,20 +179,20 @@                 tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)                 cmd = unwords $ tool : map (T.unpack . escape) args                 escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''"-            withProcess (Right node) pname Nothing cmd $ evalBlock . inner+            withProcess (Right node) pname Nothing cmd $ runStep . inner      SpawnShell mbname node script inner -> do         let tname | Just (TypedVarName (VarName name)) <- mbname = name                   | otherwise = "shell"         let pname = ProcName tname-        withShellProcess node pname script $ evalBlock . inner+        withShellProcess node pname script $ runStep . inner      Send p line -> do         outProc OutputChildStdin p line         send p line      Expect line p expr captures inner -> do-        expect line p expr captures $ evalBlock . inner+        expect line p expr captures $ runStep . inner      Flush p regex -> do         flush p regex@@ -154,18 +201,18 @@         testStepGuard line vars expr      DisconnectNode node inner -> do-        withDisconnectedUp (nodeUpstream node) $ evalBlock inner+        withDisconnectedUp (nodeUpstream node) $ runStep inner      DisconnectNodes net inner -> do-        withDisconnectedBridge (netBridge net) $ evalBlock inner+        withDisconnectedBridge (netBridge net) $ runStep inner      DisconnectUpstream net inner -> do         case netUpstream net of-            Just link -> withDisconnectedUp link $ evalBlock inner-            Nothing -> evalBlock inner+            Just link -> withDisconnectedUp link $ runStep inner+            Nothing -> runStep inner      PacketLoss loss node inner -> do-        withNodePacketLoss node loss $ evalBlock inner+        withNodePacketLoss node loss $ runStep inner      Wait -> do         void $ outPromptGetLine "Waiting..."@@ -268,7 +315,7 @@  expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun () expect sline p (Traced trace re) tvars inner = do-    timeout <- asks $ optTimeout . teOptions . fst+    timeout <- liftIO . readMVar =<< asks (teTimeout . fst)     delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout     mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do         line <- readTVar (procOutput p)
src/Run/Monad.hs view
@@ -7,6 +7,7 @@      finally,     forkTest,+    forkTestUsing, ) where  import Control.Concurrent@@ -14,6 +15,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Reader+import Control.Monad.Writer  import Data.Map (Map) import Data.Scientific@@ -25,15 +27,23 @@ import Output import {-# SOURCE #-} Process import Script.Expr+import Script.Object -newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }-    deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)+newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed (WriterT [ SomeObject TestRun ] IO)) a }+  deriving+    ( Functor, Applicative, Monad+    , MonadReader ( TestEnv, TestState )+    , MonadWriter [ SomeObject TestRun ]+    , MonadIO+    )  data TestEnv = TestEnv     { teOutput :: Output     , teFailed :: TVar (Maybe Failed)     , teOptions :: TestOptions-    , teProcesses :: MVar [Process]+    , teNextObjId :: MVar Int+    , teProcesses :: MVar [ Process ]+    , teTimeout :: MVar Scientific     , teGDB :: Maybe (MVar GDB)     } @@ -110,9 +120,13 @@     return x  forkTest :: TestRun () -> TestRun ThreadId-forkTest act = do+forkTest = forkTestUsing forkIO++forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId+forkTestUsing fork act = do     tenv <- ask-    liftIO $ forkIO $ do-        runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case+    liftIO $ fork $ do+        ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act)+        case res of             Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)             Right () -> return ()
+ src/Script/Object.hs view
@@ -0,0 +1,42 @@+module Script.Object (+    ObjectId(..),+    ObjectType(..),+    Object(..), SomeObject(..),+    toSomeObject, fromSomeObject,+    destroySomeObject,+) where++import Data.Kind+import Data.Typeable+++newtype ObjectId = ObjectId Int++class Typeable a => ObjectType m a where+    type ConstructorArgs a :: Type+    type ConstructorArgs a = ()++    createObject :: ObjectId -> ConstructorArgs a -> m (Object m a)+    destroyObject :: Object m a -> m ()++data Object m a = ObjectType m a => Object+    { objId :: ObjectId+    , objImpl :: a+    }++data SomeObject m = forall a. ObjectType m a => SomeObject+    { sobjId :: ObjectId+    , sobjImpl :: a+    }++toSomeObject :: Object m a -> SomeObject m+toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl }++fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a)+fromSomeObject SomeObject {..} = do+    let objId = sobjId+    objImpl <- cast sobjImpl+    return Object {..}++destroySomeObject :: SomeObject m -> m ()+destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl)
src/Script/Shell.hs view
@@ -20,21 +20,25 @@ import System.Process hiding (ShellCommand)  import Network+import Network.Ip import Output import Process import Run.Monad+import Script.Var   data ShellStatement = ShellStatement     { shellCommand :: Text     , shellArguments :: [ Text ]+    , shellSourceLine :: SourceLine     }  newtype ShellScript = ShellScript [ ShellStatement ]  -executeScript :: Node -> ProcName -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()-executeScript node pname pstdin pstdout pstderr (ShellScript statements) = do+executeScript :: Node -> ProcName -> MVar ExitCode -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()+executeScript node pname statusVar pstdin pstdout pstderr (ShellScript statements) = do+    setNetworkNamespace $ getNetns node     forM_ statements $ \ShellStatement {..} -> case shellCommand of         "echo" -> liftIO $ do             T.hPutStrLn pstdout $ T.intercalate " " shellArguments@@ -50,9 +54,11 @@                     }             liftIO (waitForProcess phandle) >>= \case                 ExitSuccess -> return ()-                ExitFailure code -> do-                    outLine OutputChildFail (Just $ textProcName pname) $ T.pack $ "exit code: " ++ show code+                status -> do+                    outLine OutputChildFail (Just $ textProcName pname) $ "failed at: " <> textSourceLine shellSourceLine+                    liftIO $ putMVar statusVar status                     throwError Failed+    liftIO $ putMVar statusVar ExitSuccess  spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process spawnShell procNode procName script = do@@ -61,9 +67,8 @@     ( pstdin, procStdin ) <- liftIO $ createPipe     ( hout, pstdout ) <- liftIO $ createPipe     ( herr, pstderr ) <- liftIO $ createPipe-    procHandle <- fmap (Right . (, statusVar)) $ forkTest $ do-        executeScript procNode procName pstdin pstdout pstderr script-        liftIO $ putMVar statusVar ExitSuccess+    procHandle <- fmap (Right . (, statusVar)) $ forkTestUsing forkOS $ do+        executeScript procNode procName statusVar pstdin pstdout pstderr script      let procKillWith = Nothing     let process = Process {..}@@ -85,5 +90,5 @@      inner process `finally` do         ps <- liftIO $ takeMVar procVar-        closeProcess process `finally` do+        closeTestProcess process `finally` do             liftIO $ putMVar procVar $ filter (/=process) ps
src/Test.hs view
@@ -2,20 +2,29 @@     Test(..),     TestStep(..),     TestBlock(..),++    MultiplyTimeout(..), ) where +import Control.Concurrent.MVar+import Control.Monad.Except+import Control.Monad.Reader+ import Data.Scientific import Data.Text (Text) import Data.Typeable  import Network+import Output import Process+import Run.Monad import Script.Expr+import Script.Object import Script.Shell  data Test = Test     { testName :: Text-    , testSteps :: Expr (TestBlock ())+    , testSteps :: Expr (TestStep ())     }  data TestBlock a where@@ -31,20 +40,42 @@     mempty = EmptyTestBlock  data TestStep a where-    Subnet :: TypedVarName Network -> Network -> (Network -> TestBlock a) -> TestStep a-    DeclNode :: TypedVarName Node -> Network -> (Node -> TestBlock a) -> TestStep a-    Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> (Process -> TestBlock a) -> TestStep a-    SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestBlock a) -> TestStep a+    Scope :: TestBlock a -> TestStep a+    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+    SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a     Send :: Process -> Text -> TestStep ()-    Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestBlock a) -> TestStep a+    Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a     Flush :: Process -> Maybe Regex -> TestStep ()     Guard :: SourceLine -> EvalTrace -> Bool -> TestStep ()-    DisconnectNode :: Node -> TestBlock a -> TestStep a-    DisconnectNodes :: Network -> TestBlock a -> TestStep a-    DisconnectUpstream :: Network -> TestBlock a -> TestStep a-    PacketLoss :: Scientific -> Node -> TestBlock a -> TestStep a+    DisconnectNode :: Node -> TestStep a -> TestStep a+    DisconnectNodes :: Network -> TestStep a -> TestStep a+    DisconnectUpstream :: Network -> TestStep a -> TestStep a+    PacketLoss :: Scientific -> Node -> TestStep a -> TestStep a     Wait :: TestStep ()  instance Typeable a => ExprType (TestBlock a) where     textExprType _ = "test block"     textExprValue _ = "<test block>"+++data MultiplyTimeout = MultiplyTimeout Scientific++instance ObjectType TestRun MultiplyTimeout where+    type ConstructorArgs MultiplyTimeout = Scientific++    createObject oid timeout+        | timeout > 0 = do+            var <- asks (teTimeout . fst)+            liftIO $ modifyMVar_ var $ return . (* timeout)+            return $ Object oid $ MultiplyTimeout timeout++        | otherwise = do+            outLine OutputError Nothing "timeout must be positive"+            throwError Failed++    destroyObject Object { objImpl = MultiplyTimeout timeout } = do+        var <- asks (teTimeout . fst)+        liftIO $ modifyMVar_ var $ return . (/ timeout)
src/Test/Builtins.hs view
@@ -4,6 +4,8 @@  import Data.Map qualified as M import Data.Maybe+import Data.Proxy+import Data.Scientific import Data.Text (Text)  import Process (Process)@@ -15,6 +17,7 @@     [ fq "send" builtinSend     , fq "flush" builtinFlush     , fq "guard" builtinGuard+    , fq "multiply_timeout" builtinMultiplyTimeout     , fq "wait" builtinWait     ]   where@@ -52,6 +55,10 @@ builtinGuard :: SomeVarValue builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $     \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing)++builtinMultiplyTimeout :: SomeVarValue+builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $+    \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @MultiplyTimeout) (getArg args (Just "by"))  builtinWait :: SomeVarValue builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait
src/TestMode.hs view
@@ -4,12 +4,14 @@     testMode, ) where +import Control.Monad import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State  import Data.Bifunctor import Data.List+import Data.Maybe import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T@@ -19,6 +21,7 @@ import Text.Megaparsec.Error import Text.Megaparsec.Pos +import Config import Output import Parser import Run@@ -29,29 +32,32 @@  data TestModeInput = TestModeInput     { tmiOutput :: Output+    , tmiConfig :: Maybe Config     , tmiParams :: [ Text ]     }  data TestModeState = TestModeState     { tmsModules :: [ Module ]     , tmsGlobals :: GlobalDefs+    , tmsNextTestNumber :: Int     }  initTestModeState :: TestModeState initTestModeState = TestModeState     { tmsModules = mempty     , tmsGlobals = mempty+    , tmsNextTestNumber = 1     } -testMode :: IO ()-testMode = do-    out <- startOutput OutputStyleTest False+testMode :: Maybe Config -> IO ()+testMode tmiConfig = do+    tmiOutput <- startOutput OutputStyleTest False     let testLoop = getLineMb >>= \case             Just line -> do                 case T.words line of-                    cname : params+                    cname : tmiParams                         | Just (CommandM cmd) <- lookup cname commands -> do-                            runReaderT cmd $ TestModeInput out params+                            runReaderT cmd $ TestModeInput {..}                         | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'"                     [] -> return ()                 testLoop@@ -59,7 +65,7 @@             Nothing -> return ()      runExceptT (evalStateT testLoop initTestModeState) >>= \case-        Left err -> flip runReaderT out $ outLine OutputError Nothing $ T.pack err+        Left err -> flip runReaderT tmiOutput $ outLine OutputError Nothing $ T.pack err         Right () -> return ()  getLineMb :: MonadIO m => m (Maybe Text)@@ -70,7 +76,26 @@     out <- asks tmiOutput     flip runReaderT out $ outLine OutputTestRaw Nothing line +getNextTestNumber :: CommandM Int+getNextTestNumber = do+    num <- gets tmsNextTestNumber+    modify $ \s -> s { tmsNextTestNumber = num + 1 }+    return num +runSingleTest :: Test -> CommandM Bool+runSingleTest test = do+    out <- asks tmiOutput+    num <- getNextTestNumber+    globals <- gets tmsGlobals+    mbconfig <- asks tmiConfig+    let opts = defaultTestOptions+            { optDefaultTool = fromMaybe "" $ configTool =<< mbconfig+            , optTestDir = ".test" <> show num+            , optKeep = True+            }+    liftIO (runTest out opts globals test)++ newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a)     deriving     ( Functor, Applicative, Monad, MonadIO@@ -85,7 +110,9 @@ commands :: [ ( Text, Command ) ] commands =     [ ( "load", cmdLoad )+    , ( "load-config", cmdLoadConfig )     , ( "run", cmdRun )+    , ( "run-all", cmdRunAll )     ]  cmdLoad :: Command@@ -117,6 +144,16 @@         , ":", show $ unPos sourceColumn         ] +cmdLoadConfig :: Command+cmdLoadConfig = do+    Just config <- asks tmiConfig+    ( modules, globalDefs ) <- liftIO $ loadModules =<< getConfigTestFiles config+    modify $ \s -> s+        { tmsModules = modules+        , tmsGlobals = globalDefs+        }+    cmdOut "load-config-done"+ cmdRun :: Command cmdRun = do     [ name ] <- asks tmiParams@@ -124,7 +161,14 @@     case find ((name ==) . testName) $ concatMap moduleTests tmsModules of         Nothing -> cmdOut "run-not-found"         Just test -> do-            out <- asks tmiOutput-            liftIO (runTest out defaultTestOptions tmsGlobals test) >>= \case+            runSingleTest test >>= \case                 True -> cmdOut "run-done"                 False -> cmdOut "run-failed"++cmdRunAll :: Command+cmdRunAll = do+    TestModeState {..} <- get+    forM_ (concatMap moduleTests tmsModules) $ \test -> do+        res <- runSingleTest test+        cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed")+    cmdOut "run-all-done"