diff options
37 files changed, 1194 insertions, 223 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index d7872ef..bdfbc83 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # 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 +* Select tests from project configuration using only test name on command line without script path +* Added `args` parameter to `spawn` command to pass extra command-line arguments to the spawned tool +* Experimental shell interpreter + ## 0.3.1 -- 2025-03-03 * Fix executing test tool given with relative path @@ -56,14 +56,26 @@ cmake --build build erebos-tester --verbose ``` -To run tests from a given test file, pass it as command-line argument: +To run all tests from project configuration (see below), run the tester without any argument: ``` -erebos-tester path/to/script.test +erebos-tester +``` + +To run only some named tests, list the names on command line: +``` +erebos-tester FirstTest SecondTest +``` + +To run tests from a given test file, pass it as command-line argument (the path +must contain a slash, so use e.g. `./script.et` for script in the current +directory): +``` +erebos-tester path/to/script.et ``` To select single test from a file, use `:` separator: ``` -erebos-tester path/to/script.test:TestName +erebos-tester path/to/script.et:TestName ``` Configuration @@ -76,6 +88,7 @@ This is a YAML file with following fields: * `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 --------------- @@ -166,6 +179,7 @@ let re2 = /$str$re1/ # match '.' followed by any character #### boolean Result of comparison operators `==` and `/=`. +Values are `True` and `False`. #### network @@ -231,11 +245,12 @@ node <name> [on <network>] Create a node on network `<network>` (or context network if omitted) and assign the new node to the variable `<name>`. ``` -spawn as <name> [on (<node> | <network>)] +spawn as <name> [on (<node> | <network>)] [args <arguments>] ``` Spawn a new test process on `<node>` or `<network>` (or one from context) and assign the new process to variable `<name>`. When spawning on network, create a new node for this process. +Extra `<arguments>` to the tool can be given as a list of strings using the `args` keyword. The process is terminated when the variable `<name>` goes out of scope (at the end of the block in which it was created) by closing its stdin. When the process fails to terminate successfully within a timeout, the test fails. @@ -267,6 +282,15 @@ Flush memory of `<proc>` output, so no following `expect` command will match any If the `matching` clause is used, discard only output lines matching `<regex>`. ``` +ignore [from <proc>] [matching <regex>] +``` + +Ignore output lines from `<proc>` (or context process) that match the given +`<regex>` (or all lines if the `matching` clause is not used). Affects both +past and future output of the process; the effect lasts until the end of +the block. + +``` guard <expr> ``` @@ -322,6 +346,13 @@ with <expr>: 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 ``` @@ -453,9 +484,17 @@ test: 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 diff --git a/erebos-tester.cabal b/erebos-tester.cabal index 6661f8b..e8fe761 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: erebos-tester -version: 0.3.1 +version: 0.3.3 synopsis: Test framework with virtual network using Linux namespaces description: This framework is intended mainly for networking libraries/applications and @@ -62,9 +62,11 @@ executable erebos-tester Process Run Run.Monad + Sandbox Script.Expr Script.Expr.Class Script.Module + Script.Object Script.Shell Script.Var Test @@ -79,6 +81,7 @@ executable erebos-tester c-sources: src/main.c + src/shell.c other-extensions: CPP diff --git a/minici.yaml b/minici.yaml index 95dc61d..0813962 100644 --- a/minici.yaml +++ b/minici.yaml @@ -1,3 +1,13 @@ job build: shell: - cabal build -fci --constraint='megaparsec >= 9.7.0' + - mkdir build + - cp $(cabal list-bin erebos-tester) build/erebos-tester + artifact bin: + path: build/erebos-tester + +job test: + uses: + - build.bin + shell: + - EREBOS_TEST_TOOL='build/erebos-tester --test-mode' erebos-tester --verbose diff --git a/src/Config.hs b/src/Config.hs index 7f5895c..adf0321 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -2,11 +2,13 @@ module Config ( 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,31 +18,31 @@ import System.FilePath 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 "." @@ -63,4 +65,7 @@ parseConfig path = do 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) @@ -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/Main.hs b/src/Main.hs index abc96ac..b3f7a2a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,27 +2,24 @@ module Main (main) where 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 @@ import Version data CmdlineOptions = CmdlineOptions { optTest :: TestOptions , optRepeat :: Int + , optExclude :: [ Text ] , optVerbose :: Bool , optColor :: Maybe Bool , optShowHelp :: Bool @@ -45,6 +43,7 @@ defaultCmdlineOptions :: CmdlineOptions defaultCmdlineOptions = CmdlineOptions { optTest = defaultTestOptions , optRepeat = 1 + , optExclude = [] , optVerbose = False , optColor = Nothing , optShowHelp = False @@ -86,6 +85,9 @@ options = , 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 @@ hiddenOptions = 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,19 +120,26 @@ main = do { optTest = defaultTestOptions { optDefaultTool = envtool , optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions + , optTimeout = fromMaybe (optTimeout defaultTestOptions) $ configTimeout =<< config } } args <- getArgs - (opts, ofiles) <- case getOpt Permute (options ++ hiddenOptions) args of + (opts, oselection) <- case getOpt Permute (options ++ hiddenOptions) args of (o, files, []) -> return (foldl (flip id) initOpts o, files) (_, _, errs) -> do hPutStrLn stderr $ concat errs <> "Try `erebos-tester --help' for more information." exitFailure + let ( ofiles, otests ) + | any (any isPathSeparator) oselection = ( oselection, [] ) + | otherwise = ( [], map T.pack oselection ) + when (optShowHelp opts) $ do let header = unlines - [ "Usage: erebos-tester [<option>...] [<script>[:<test>]...]" + [ "Usage: erebos-tester [<option>...] [<test-name>...]" + , " or: erebos-tester [<option>...] <script>[:<test>]..." + , " <test-name> name of a test from project configuration" , " <script> path to test script file" , " <test> name of the test to run" , "" @@ -145,7 +153,7 @@ main = do exitSuccess when (optTestMode opts) $ do - testMode + testMode config exitSuccess case words $ optDefaultTool $ optTest opts of @@ -159,7 +167,7 @@ main = do 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" @@ -171,32 +179,28 @@ main = do | 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 <- forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do - case mbTestName of - Nothing -> return moduleTests - Just name - | Just test <- find ((==name) . testName) moduleTests - -> return [ test ] + ( 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 + Just name + | Just test <- find ((name ==) . testName) moduleTests + -> return [ test ] + | otherwise + -> do + hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found in ‘" <> filePath <> "’" + exitFailure + else forM otests $ \name -> if + | Just test <- find ((name ==) . testName) $ concatMap moduleTests modules + -> return test | otherwise -> do - hPutStrLn stderr $ "Test `" <> T.unpack name <> "' not found in `" <> filePath <> "'" + 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) $ concat tests + concat $ replicate (optRepeat opts) tests when (not ok) exitFailure foreign export ccall testerMain :: IO () diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs index 8f0887a..69a6b43 100644 --- a/src/Network/Ip.hs +++ b/src/Network/Ip.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Network.Ip ( IpPrefix(..), textIpNetwork, @@ -17,7 +19,9 @@ module Network.Ip ( NetworkNamespace, HasNetns(..), addNetworkNamespace, + setNetworkNamespace, textNetnsName, + runInNetworkNamespace, callOn, Link(..), @@ -32,7 +36,9 @@ module Network.Ip ( 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.Text qualified as T 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 @@ addNetworkNamespace netnsName = do 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 diff --git a/src/Parser.hs b/src/Parser.hs index 0716457..9f1a0e3 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -43,7 +43,7 @@ parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do 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 @@ parseDefinition href = label "symbol definition" $ do osymbol ":" scn ref <- L.indentGuard scn GT href - SomeExpr <$> blockOf ref testStep + SomeExpr <$> testBlock ref , do osymbol "=" someExpr <* eol diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index 3700602..b9b5f01 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -118,6 +118,13 @@ numberLiteral = label "number" $ lexeme $ do 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 @@ someExpr = join inner <?> "expression" [ 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 @@ typedExpr = do literal :: TestParser SomeExpr literal = label "literal" $ choice [ numberLiteral + , boolLiteral , SomeExpr <$> quotedString , SomeExpr <$> regex , list @@ -394,7 +404,7 @@ checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr Nothing -> do registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $ case kw of - Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword `" <> tkw <> "'" + Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’" Nothing -> "unexpected parameter" return sexpr diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs index 0f34fee..22d47ed 100644 --- a/src/Parser/Shell.hs +++ b/src/Parser/Shell.hs @@ -3,6 +3,7 @@ module Parser.Shell ( shellScript, ) where +import Control.Applicative (liftA2) import Control.Monad import Data.Char @@ -22,12 +23,15 @@ import Script.Shell parseArgument :: TestParser (Expr Text) parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice [ doubleQuotedString - , escapedChar + , singleQuotedString + , standaloneEscapedChar , stringExpansion , unquotedString ] where - specialChars = [ '\"', '\\', '$' ] + specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']', '{', '}', '(', ')', '*', '?', '~', '&', '!' ] + + stringSpecialChars = [ '"', '\\', '$' ] unquotedString :: TestParser (Expr Text) unquotedString = do @@ -38,36 +42,67 @@ parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:) void $ char '"' let inner = choice [ char '"' >> return [] - , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner - , (:) <$> escapedChar <*> inner + , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` stringSpecialChars)) <*> inner + , (:) <$> stringEscapedChar <*> inner , (:) <$> stringExpansion <*> inner ] App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner - escapedChar :: TestParser (Expr Text) - escapedChar = do + singleQuotedString :: TestParser (Expr Text) + singleQuotedString = do + Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'') + + stringEscapedChar :: TestParser (Expr Text) + stringEscapedChar = do void $ char '\\' - Pure <$> choice - [ char '\\' >> return "\\" - , char '"' >> return "\"" - , char '$' >> return "$" - , char 'n' >> return "\n" + fmap Pure $ choice $ + map (\c -> char c >> return (T.singleton c)) stringSpecialChars ++ + [ char 'n' >> return "\n" , char 'r' >> return "\r" , char 't' >> return "\t" + , return "\\" + ] + + standaloneEscapedChar :: TestParser (Expr Text) + standaloneEscapedChar = do + void $ char '\\' + fmap Pure $ choice $ + map (\c -> char c >> return (T.singleton c)) specialChars ++ + [ char ' ' >> return " " ] parseArguments :: TestParser (Expr [ Text ]) parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument -shellStatement :: TestParser (Expr [ ShellStatement ]) -shellStatement = label "shell statement" $ do +parseCommand :: TestParser (Expr ShellCommand) +parseCommand = label "shell statement" $ do + line <- getSourceLine command <- parseArgument args <- parseArguments - return $ fmap (: []) $ ShellStatement + return $ ShellCommand <$> command <*> args + <*> pure line + +parsePipeline :: Expr (Maybe ShellPipeline) -> TestParser (Expr ShellPipeline) +parsePipeline upper = do + cmd <- parseCommand + let pipeline = ShellPipeline <$> cmd <*> upper + choice + [ do + osymbol "|" + parsePipeline (Just <$> pipeline) + + , do + return pipeline + ] + +parseStatement :: TestParser (Expr [ ShellStatement ]) +parseStatement = do + line <- getSourceLine + fmap ((: []) . flip ShellStatement line) <$> parsePipeline (pure Nothing) shellScript :: TestParser (Expr ShellScript) shellScript = do indent <- L.indentLevel - fmap ShellScript <$> blockOf indent shellStatement + fmap ShellScript <$> blockOf indent parseStatement diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 7c2977d..474fa03 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -1,5 +1,6 @@ module Parser.Statement ( testStep, + testBlock, ) where import Control.Monad @@ -43,7 +44,7 @@ letStatement = do 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,23 +69,52 @@ forStatement = do 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 ref <- L.indentLevel wsymbol "shell" - wsymbol "as" - pname <- newVarName - wsymbol "on" - node <- typedExpr - symbol ":" - void eol - void $ L.indentGuard scn GT ref - script <- shellScript - cont <- testBlock ref - return $ TestBlockStep EmptyTestBlock <$> - (SpawnShell pname <$> node <*> script <*> LambdaAbstraction pname cont) + parseParams ref Nothing Nothing + + where + parseParamKeyword kw prev = do + off <- stateOffset <$> getParserState + wsymbol kw + when (isJust prev) $ do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "unexpected parameter with keyword ‘" <> kw <> "’" + + parseParams ref mbpname mbnode = choice + [ do + parseParamKeyword "as" mbpname + pname <- newVarName + parseParams ref (Just pname) mbnode + + , do + parseParamKeyword "on" mbnode + node <- typedExpr + parseParams ref mbpname (Just node) + + , do + off <- stateOffset <$> getParserState + symbol ":" + node <- case mbnode of + Just node -> return node + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "missing parameter with keyword ‘on’" + return $ Undefined "" + + void eol + void $ L.indentGuard scn GT ref + script <- shellScript + cont <- fmap Scope <$> testBlock ref + let expr | Just pname <- mbpname = LambdaAbstraction pname cont + | otherwise = const <$> cont + return $ TestBlockStep EmptyTestBlock <$> + (SpawnShell mbpname <$> node <*> script <*> expr) + ] exprStatement :: TestParser (Expr (TestBlock ())) exprStatement = do @@ -261,14 +291,14 @@ instance ExprType a => ParamType (InnerBlock a) where 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) @@ -351,7 +381,8 @@ testLocal = do 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 @@ -377,7 +408,7 @@ testWith = do 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 @@ -395,6 +426,7 @@ testSpawn :: TestParser (Expr (TestBlock ())) testSpawn = command "spawn" $ Spawn <$> param "as" <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") + <*> (maybe [] fromExprParam <$> param "args") <*> innerBlockFun testExpect :: TestParser (Expr (TestBlock ())) diff --git a/src/Process.hs b/src/Process.hs index 290aedf..0c24b4f 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -5,9 +5,14 @@ module Process ( send, outProc, lineReadingLoop, + startProcessIOLoops, spawnOn, closeProcess, + closeTestProcess, withProcess, + + IgnoreProcessOutput(..), + flushProcessOutput, ) where import Control.Arrow @@ -18,9 +23,11 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Function +import Data.Maybe +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 @@ -36,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 } @@ -83,17 +93,40 @@ outProc otype p line = outLine otype (Just $ textProcName $ procName p) line lineReadingLoop :: MonadOutput m => Process -> Handle -> (Text -> m ()) -> m () lineReadingLoop process h act = liftIO (tryIOError (T.hGetLine h)) >>= \case - Left err - | isEOFError err -> return () - | otherwise -> outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err + Left err -> do + when (not (isEOFError err)) $ do + outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err + liftIO $ hClose h Right line -> do 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 "ip netns exec" wrapper. + -- because working directory will be changed for the shell wrapper. cmd' <- liftIO $ do case span (/= ' ') cmd of ( path, rest ) @@ -104,40 +137,29 @@ spawnOn target pname killWith cmd = do _ -> 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 - } - pout <- liftIO $ newTVarIO [] - - let process = Process - { procName = pname - , procHandle = Left handle - , procStdin = hin - , procOutput = pout - , procKillWith = killWith - , procNode = either (const undefined) id target + (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 } + 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 -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 +168,7 @@ closeProcess p = do 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 +176,11 @@ closeProcess p = do 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 +190,28 @@ withProcess target pname killWith cmd inner = do inner process `finally` do ps <- liftIO $ takeMVar procVar - closeProcess process `finally` do + 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) @@ -1,6 +1,7 @@ module Run ( module Run.Monad, runTest, + loadModules, evalGlobalDefs, ) where @@ -11,13 +12,16 @@ import Control.Monad 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,24 @@ import System.Posix.Process 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 Sandbox 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 +58,9 @@ runTest out opts gdefs test = do 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 +72,9 @@ runTest out opts gdefs test = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teNextObjId = objIdVar , teProcesses = procVar + , teTimeout = timeoutVar , teGDB = fst <$> mgdb } tstate = TestState @@ -88,16 +103,26 @@ runTest out opts gdefs test = do oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing resetOutputTime out - res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do - withInternet $ \_ -> do - evalBlock =<< eval (testSteps test) - when (optWait opts) $ do - void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + testRunResult <- newEmptyMVar + + void $ forkOS $ do + isolateFilesystem testDir >>= \case + True -> do + tres <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do + withInternet $ \_ -> do + runStep =<< eval (testSteps test) + when (optWait opts) $ do + void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + putMVar testRunResult tres + _ -> do + putMVar testRunResult ( Left Failed, [] ) + + ( res, [] ) <- takeMVar testRunResult 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,23 +130,56 @@ runTest out opts gdefs test = do (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 inner -> do + Spawn tvname@(TypedVarName (VarName tname)) target args inner -> do case target of Left net -> withNode net (Right tvname) go Right node -> go node @@ -130,38 +188,42 @@ evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of opts <- asks $ teOptions . fst let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) - withProcess (Right node) pname Nothing tool $ evalBlock . inner + cmd = unwords $ tool : map (T.unpack . escape) args + escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" + withProcess (Right node) pname Nothing cmd $ runStep . inner - SpawnShell (TypedVarName (VarName tname)) node script inner -> do + 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 + atomicallyTest $ flushProcessOutput p regex Guard line vars expr -> do 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..." @@ -264,7 +326,7 @@ exprFailed desc sline pname exprVars = do 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) @@ -286,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/Run/Monad.hs b/src/Run/Monad.hs index e107017..f681e99 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -7,6 +7,7 @@ module Run.Monad ( finally, forkTest, + forkTestUsing, ) where import Control.Concurrent @@ -14,6 +15,7 @@ import Control.Concurrent.STM 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 Network.Ip 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 @@ finally act handler = do 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 () diff --git a/src/Sandbox.hs b/src/Sandbox.hs new file mode 100644 index 0000000..a05a455 --- /dev/null +++ b/src/Sandbox.hs @@ -0,0 +1,16 @@ +module Sandbox ( + isolateFilesystem, +) where + +import Foreign.C.String +import Foreign.C.Types + +import System.Directory + + +isolateFilesystem :: FilePath -> IO Bool +isolateFilesystem rwDir = do + absDir <- makeAbsolute rwDir + withCString absDir c_isolate_fs >>= return . (== 0) + +foreign import ccall unsafe "erebos_tester_isolate_fs" c_isolate_fs :: CString -> IO CInt diff --git a/src/Script/Object.hs b/src/Script/Object.hs new file mode 100644 index 0000000..9232b21 --- /dev/null +++ b/src/Script/Object.hs @@ -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) diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs index 60ec929..23c3891 100644 --- a/src/Script/Shell.hs +++ b/src/Script/Shell.hs @@ -1,6 +1,8 @@ module Script.Shell ( - ShellStatement(..), ShellScript(..), + ShellStatement(..), + ShellPipeline(..), + ShellCommand(..), withShellProcess, ) where @@ -15,65 +17,130 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Marshal.Array +import Foreign.Storable + import System.Exit import System.IO +import System.Posix.IO qualified as P +import System.Posix.Types import System.Process hiding (ShellCommand) import Network +import Network.Ip import Output import Process import Run.Monad +import Script.Var +newtype ShellScript = ShellScript [ ShellStatement ] + data ShellStatement = ShellStatement - { shellCommand :: Text - , shellArguments :: [ Text ] + { shellPipeline :: ShellPipeline + , shellSourceLine :: SourceLine } -newtype ShellScript = ShellScript [ ShellStatement ] +data ShellPipeline = ShellPipeline + { pipeCommand :: ShellCommand + , pipeUpstream :: Maybe ShellPipeline + } + +data ShellCommand = ShellCommand + { cmdCommand :: Text + , cmdArguments :: [ Text ] + , cmdSourceLine :: SourceLine + } + + +data ShellExecInfo = ShellExecInfo + { seiNode :: Node + , seiProcName :: ProcName + , seiStatusVar :: MVar ExitCode + } -executeScript :: Node -> ProcName -> Handle -> Handle -> Handle -> ShellScript -> TestRun () -executeScript node pname pstdin pstdout pstderr (ShellScript statements) = do - forM_ statements $ \ShellStatement {..} -> case shellCommand of +data HandleHandling + = CloseHandle Handle + | KeepHandle Handle + +closeIfRequested :: MonadIO m => HandleHandling -> m () +closeIfRequested (CloseHandle h) = liftIO $ hClose h +closeIfRequested (KeepHandle _) = return () + +handledHandle :: HandleHandling -> Handle +handledHandle (CloseHandle h) = h +handledHandle (KeepHandle h) = h + + +executeCommand :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellCommand -> TestRun () +executeCommand ShellExecInfo {..} pstdin pstdout pstderr ShellCommand {..} = do + case cmdCommand of "echo" -> liftIO $ do - T.hPutStrLn pstdout $ T.intercalate " " shellArguments - hFlush pstdout + T.hPutStrLn (handledHandle pstdout) $ T.intercalate " " cmdArguments + hFlush (handledHandle pstdout) + mapM_ closeIfRequested [ pstdin, pstdout, pstderr ] cmd -> do (_, _, _, phandle) <- liftIO $ createProcess_ "shell" - (proc (T.unpack cmd) (map T.unpack shellArguments)) - { std_in = UseHandle pstdin - , std_out = UseHandle pstdout - , std_err = UseHandle pstderr - , cwd = Just (nodeDir node) + (proc (T.unpack cmd) (map T.unpack cmdArguments)) + { std_in = UseHandle $ handledHandle pstdin + , std_out = UseHandle $ handledHandle pstdout + , std_err = UseHandle $ handledHandle pstderr + , cwd = Just (nodeDir seiNode) , env = Just [] } + mapM_ closeIfRequested [ pstdin, pstdout, pstderr ] 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 seiProcName) $ "failed at: " <> textSourceLine cmdSourceLine + liftIO $ putMVar seiStatusVar status throwError Failed +executePipeline :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellPipeline -> TestRun () +executePipeline sei pstdin pstdout pstderr ShellPipeline {..} = do + case pipeUpstream of + Nothing -> do + executeCommand sei pstdin pstdout pstderr pipeCommand + + Just upstream -> do + ( pipeRead, pipeWrite ) <- createPipeCloexec + void $ forkTestUsing forkOS $ do + executePipeline sei pstdin (CloseHandle pipeWrite) (KeepHandle $ handledHandle pstderr) upstream + + executeCommand sei (CloseHandle pipeRead) pstdout (KeepHandle $ handledHandle pstderr) pipeCommand + closeIfRequested pstderr + +executeScript :: ShellExecInfo -> Handle -> Handle -> Handle -> ShellScript -> TestRun () +executeScript sei@ShellExecInfo {..} pstdin pstdout pstderr (ShellScript statements) = do + setNetworkNamespace $ getNetns seiNode + forM_ statements $ \ShellStatement {..} -> do + executePipeline sei (KeepHandle pstdin) (KeepHandle pstdout) (KeepHandle pstderr) shellPipeline + liftIO $ putMVar seiStatusVar ExitSuccess + spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process spawnShell procNode procName script = do procOutput <- liftIO $ newTVarIO [] - statusVar <- liftIO $ newEmptyMVar - ( 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 + procIgnore <- liftIO $ newTVarIO ( 0, [] ) + seiStatusVar <- liftIO $ newEmptyMVar + ( pstdin, procStdin ) <- createPipeCloexec + ( hout, pstdout ) <- createPipeCloexec + ( herr, pstderr ) <- createPipeCloexec + procHandle <- fmap (Right . (, seiStatusVar)) $ forkTestUsing forkOS $ do + let seiNode = procNode + seiProcName = procName + executeScript ShellExecInfo {..} pstdin pstdout pstderr script + liftIO $ do + hClose pstdin + hClose pstdout + hClose pstderr 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 @@ -85,5 +152,19 @@ withShellProcess node pname script inner = do inner process `finally` do ps <- liftIO $ takeMVar procVar - closeProcess process `finally` do + closeTestProcess process `finally` do liftIO $ putMVar procVar $ filter (/=process) ps + + +foreign import ccall "shell_pipe_cloexec" c_pipe_cloexec :: Ptr Fd -> IO CInt + +createPipeCloexec :: (MonadIO m, MonadFail m) => m ( Handle, Handle ) +createPipeCloexec = liftIO $ do + allocaArray 2 $ \ptr -> do + c_pipe_cloexec ptr >>= \case + 0 -> do + rh <- P.fdToHandle =<< peekElemOff ptr 0 + wh <- P.fdToHandle =<< peekElemOff ptr 1 + return ( rh, wh ) + _ -> do + fail $ "failed to create pipe" diff --git a/src/Test.hs b/src/Test.hs index b8c5049..3e98efa 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -2,20 +2,29 @@ module Test ( 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 @@ instance Monoid (TestBlock ()) where 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 -> (Process -> TestBlock a) -> TestStep a - SpawnShell :: 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) diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index 69579bc..244ff57 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -4,9 +4,11 @@ module Test.Builtins ( import Data.Map qualified as M import Data.Maybe +import Data.Proxy +import Data.Scientific import Data.Text (Text) -import Process (Process) +import Process import Script.Expr import Test @@ -14,7 +16,9 @@ builtins :: GlobalDefs builtins = M.fromList [ fq "send" builtinSend , fq "flush" builtinFlush + , fq "ignore" builtinIgnore , fq "guard" builtinGuard + , fq "multiply_timeout" builtinMultiplyTimeout , fq "wait" builtinWait ] where @@ -49,9 +53,22 @@ 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) +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 diff --git a/src/TestMode.hs b/src/TestMode.hs index ab938e6..c052fb9 100644 --- a/src/TestMode.hs +++ b/src/TestMode.hs @@ -4,12 +4,14 @@ module TestMode ( 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 System.IO.Error import Text.Megaparsec.Error import Text.Megaparsec.Pos +import Config import Output import Parser import Run @@ -29,29 +32,32 @@ import Test 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 @@ testMode = do 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,6 +76,25 @@ cmdOut line = do 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 @@ -85,7 +110,9 @@ type Command = CommandM () commands :: [ ( Text, Command ) ] commands = [ ( "load", cmdLoad ) + , ( "load-config", cmdLoadConfig ) , ( "run", cmdRun ) + , ( "run-all", cmdRunAll ) ] cmdLoad :: Command @@ -117,6 +144,16 @@ cmdLoad = do , ":", 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 @@ cmdRun = do 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" @@ -9,8 +9,11 @@ #include <sched.h> #include <stdbool.h> #include <stdio.h> +#include <stdlib.h> #include <string.h> #include <sys/mount.h> +#include <sys/stat.h> +#include <sys/syscall.h> #include <unistd.h> /* @@ -45,9 +48,15 @@ static bool writeProcSelfFile( const char * file, const char * data, size_t size int main( int argc, char * argv[] ) { + int ret; + uid_t uid = geteuid(); gid_t gid = getegid(); - unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS ); + ret = unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS ); + if( ret < 0 ){ + fprintf( stderr, "unsharing user, network and mount namespaces failed: %s\n", strerror( errno )); + return 1; + } char buf[ 256 ]; int len; @@ -71,7 +80,63 @@ int main( int argc, char * argv[] ) if ( ! writeProcSelfFile( "gid_map", buf, len ) ) return 1; - mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" ); + /* + * Prepare for future filesystem isolation within additional mount namespace: + * - clone whole mount tree as read-only under new /tmp/new_root + * - keep writable /proc and /tmp + */ + + ret = mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" ); + if( ret < 0 ){ + fprintf( stderr, "failed to mount tmpfs on /run: %s\n", strerror( errno )); + return 1; + } + + ret = mkdir( "/run/new_root", 0700 ); + if( ret < 0 ){ + fprintf( stderr, "failed to create new_root directory: %s\n", strerror( errno )); + return 1; + } + + ret = mount( "/", "/run/new_root", NULL, MS_BIND | MS_REC, NULL ); + if( ret < 0 ){ + fprintf( stderr, "failed to bind-mount / on new_root: %s\n", strerror( errno )); + return 1; + } + + struct mount_attr * attr_ro = &( struct mount_attr ) { + .attr_set = MOUNT_ATTR_RDONLY, + }; + ret = mount_setattr( -1, "/run/new_root", AT_RECURSIVE, attr_ro, sizeof( * attr_ro ) ); + if( ret < 0 ){ + fprintf( stderr, "failed set new_root as read-only: %s\n", strerror( errno )); + return 1; + } + + struct mount_attr * attr_rw = &( struct mount_attr ) { + .attr_clr = MOUNT_ATTR_RDONLY, + }; + ret = mount_setattr( -1, "/run/new_root/proc", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) ); + if( ret < 0 ){ + fprintf( stderr, "failed set new_root/proc as read-write: %s\n", strerror( errno )); + return 1; + } + ret = mount_setattr( -1, "/run/new_root/tmp", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) ); + if( ret < 0 ){ + fprintf( stderr, "failed set new_root/tmp as read-write: %s\n", strerror( errno )); + } + + ret = mount( "tmpfs", "/run/new_root/run", "tmpfs", 0, "size=4m" ); + if( ret < 0 ){ + fprintf( stderr, "failed to mount tmpfs on new_root/run: %s\n", strerror( errno )); + return 1; + } + + ret = mkdir( "/run/new_root/run/old_root", 0700 ); + if( ret < 0 ){ + fprintf( stderr, "failed to create old_root directory: %s\n", strerror( errno )); + return 1; + } hs_init( &argc, &argv ); testerMain(); @@ -79,3 +144,46 @@ int main( int argc, char * argv[] ) return 0; } + +/* + * - Replace filesystem hierarchy with read-only version, + * - bind-mound rwdir from writable tree, and + * - keep writeable /tmp from host. + */ +int erebos_tester_isolate_fs( const char * rwdir ) +{ + int ret; + + ret = unshare( CLONE_NEWNS ); + if( ret < 0 ){ + fprintf( stderr, "unsharing mount namespace failed: %s\n", strerror( errno )); + return -1; + } + + char * cwd = getcwd( NULL, 0 ); + ret = syscall( SYS_pivot_root, "/run/new_root", "/run/new_root/run/old_root" ); + if( ret < 0 ){ + fprintf( stderr, "failed to pivot_root: %s\n", strerror( errno )); + free( cwd ); + return -1; + } + + char oldrwdir[ strlen(rwdir) + 15 ]; + snprintf( oldrwdir, sizeof oldrwdir, "/run/old_root/%s", rwdir ); + ret = mount( oldrwdir, rwdir, NULL, MS_BIND, NULL ); + if( ret < 0 ){ + fprintf( stderr, "failed to bind-mount %s on %s: %s\n", oldrwdir, rwdir, strerror( errno )); + free( cwd ); + return -1; + } + + ret = chdir( cwd ); + if( ret < 0 ){ + fprintf( stderr, "failed to chdir to %s: %s\n", cwd, strerror( errno )); + free( cwd ); + return -1; + } + free( cwd ); + + return 0; +} diff --git a/src/shell.c b/src/shell.c new file mode 100644 index 0000000..d832078 --- /dev/null +++ b/src/shell.c @@ -0,0 +1,8 @@ +#define _GNU_SOURCE +#include <fcntl.h> +#include <unistd.h> + +int shell_pipe_cloexec( int pipefd[ 2 ] ) +{ + return pipe2( pipefd, O_CLOEXEC ); +} diff --git a/test/asset/run-fail/bool.et b/test/asset/run-fail/bool.et new file mode 100644 index 0000000..1608a08 --- /dev/null +++ b/test/asset/run-fail/bool.et @@ -0,0 +1,3 @@ +test Test: + node n + guard (True == False) diff --git a/test/asset/run-success/bool.et b/test/asset/run-success/bool.et new file mode 100644 index 0000000..7121cc0 --- /dev/null +++ b/test/asset/run-success/bool.et @@ -0,0 +1,7 @@ +test Test: + node n + guard (True == True) + guard (False == False) + guard (False /= True) + guard ((1 == 1) == True) + guard ((1 == 0) == False) diff --git a/test/asset/run-success/command-ignore.et b/test/asset/run-success/command-ignore.et new file mode 100644 index 0000000..dc950d1 --- /dev/null +++ b/test/asset/run-success/command-ignore.et @@ -0,0 +1,39 @@ +def expect_next from p (str): + expect /(.*)/ from p capture line + guard (line == str) + +test Test: + node n + shell on n as p: + cat + + send "a" to p + send "b" to p + send "x" to p + expect /x/ from p + + ignore from p matching /a/ + send "a" to p + send "c" to p + + expect_next "b" from p + expect_next "c" from p + + send "a" to p + send "b" to p + with p: + send "c" + ignore matching /[bcd]/ + send "d" + send "e" + expect_next "e" from p + + send "a" to p + send "b" to p + local: + send "c" to p + send "d" to p + + expect_next "b" from p + expect_next "c" from p + expect_next "d" from p diff --git a/test/asset/run/echo.et b/test/asset/run/echo.et new file mode 100644 index 0000000..9950d7b --- /dev/null +++ b/test/asset/run/echo.et @@ -0,0 +1,4 @@ +test ExpectEcho: + spawn as p + send "abcdef" to p + expect /abcdef/ from p diff --git a/test/asset/run/erebos-tester.yaml b/test/asset/run/erebos-tester.yaml new file mode 100644 index 0000000..937ca97 --- /dev/null +++ b/test/asset/run/erebos-tester.yaml @@ -0,0 +1,2 @@ +tests: ./scripts/**/*.et +tool: ./tools/tool diff --git a/test/asset/run/sysinfo.et b/test/asset/run/sysinfo.et new file mode 100644 index 0000000..1b9f6aa --- /dev/null +++ b/test/asset/run/sysinfo.et @@ -0,0 +1,12 @@ +test SysInfo: + node n + spawn on n as p1 + with p1: + send "network-info" + expect /ip ${n.ifname} ${n.ip}/ + + spawn as p2 + guard (p2.node.ip /= p1.node.ip) + with p2: + send "network-info" + expect /ip ${n.ifname} ${p2.node.ip}/ diff --git a/test/asset/run/tools/echo.sh b/test/asset/run/tools/echo.sh new file mode 100755 index 0000000..53b1eae --- /dev/null +++ b/test/asset/run/tools/echo.sh @@ -0,0 +1,2 @@ +#!/bin/sh +cat diff --git a/test/asset/run/tools/sysinfo.sh b/test/asset/run/tools/sysinfo.sh new file mode 100755 index 0000000..38591f4 --- /dev/null +++ b/test/asset/run/tools/sysinfo.sh @@ -0,0 +1,9 @@ +#!/bin/sh + +while read cmd; do + case "$cmd" in + network-info) + ip -o addr show | sed -e 's/[0-9]*: \([a-z0-9]*\).*inet6\? \([0-9a-f:.]*\).*/ip \1 \2/' + ;; + esac +done diff --git a/test/asset/run/trivial.et b/test/asset/run/trivial.et new file mode 100644 index 0000000..0b2e878 --- /dev/null +++ b/test/asset/run/trivial.et @@ -0,0 +1,7 @@ +test AlwaysSucceeds: + node n + guard (1 == 1) + +test AlwaysFails: + node n + guard (1 == 0) diff --git a/test/asset/shell/echo.et b/test/asset/shell/echo.et new file mode 100644 index 0000000..1e48cac --- /dev/null +++ b/test/asset/shell/echo.et @@ -0,0 +1,25 @@ +test Echo: + node n + let echo_str = "echo" + let space_str = "a b" + + shell on n as sh: + echo a b c + echo "a b c" + echo 'a b d' + echo a b " c d" + + /bin/echo "abcd" xyz + "echo" a"a" "b"c d + $echo_str b $echo_str c + + echo "$space_str" + echo $space_str + echo '$space_str' + + echo \$ \" \\ + echo "\""\""a" + echo "'" '"' '\\\' "\\" + echo a\ b\ \ c + + echo \" \' \\ \$ \# \| \> \< \; \[ \] \{ \} \( \) \* \? \~ \& \! diff --git a/test/asset/shell/pipe.et b/test/asset/shell/pipe.et new file mode 100644 index 0000000..64dcb07 --- /dev/null +++ b/test/asset/shell/pipe.et @@ -0,0 +1,5 @@ +test Pipe: + node n + shell on n as sh: + echo abcd | grep -o '[bc]*' + echo abcd | grep -o '[bcd]*' | grep -o '[ab]*' diff --git a/test/asset/shell/spawn.et b/test/asset/shell/spawn.et new file mode 100644 index 0000000..9d48e72 --- /dev/null +++ b/test/asset/shell/spawn.et @@ -0,0 +1,13 @@ +test ShellTrue: + node n + shell on n: + true + + shell on n as sh: + true + + +test ShellFalse: + node n + shell on n as sh: + false diff --git a/test/script/run.et b/test/script/run.et new file mode 100644 index 0000000..c3c698e --- /dev/null +++ b/test/script/run.et @@ -0,0 +1,105 @@ +module run + +asset scripts: + path: ../asset/run + +asset scripts_success: + path: ../asset/run-success + +asset scripts_fail: + path: ../asset/run-fail + + +test TrivialRun: + spawn as p + with p: + send "load ${scripts.path}/trivial.et" + expect /load-done/ + + send "run AlwaysSucceeds" + local: + expect /(run-.*)/ capture done + guard (done == "run-done") + + send "run AlwaysFails" + local: + expect /match-fail .*/ + expect /(run-.*)/ capture done + guard (done == "run-failed") + + +test SimpleRun: + let should_succeed = [ "bool", "command-ignore" ] + let should_fail = [ "bool" ] + spawn as p + + with p: + for file in should_succeed: + send "load ${scripts_success.path}/$file.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run Test" + local: + expect /(run-.*)/ capture done + guard (done == "run-done") + flush + + for file in should_fail: + send "load ${scripts_fail.path}/$file.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run Test" + local: + expect /(run-.*)/ capture done + guard (done == "run-failed") + flush + + +test RunConfig: + node n + shell on n: + cp ${scripts.path}/erebos-tester.yaml . + mkdir tools + cp ${scripts.path}/tools/echo.sh ./tools/tool + mkdir scripts + # TODO: it seems that namespaces are not properly cleaned up after the failed test + #cp ${scripts.path}/trivial.et ./scripts/ + cp ${scripts.path}/echo.et ./scripts/ + + spawn as p on n + + with p: + send "load-config" + expect /load-config-done/ + send "run-all" + #expect /run-test-result AlwaysSucceeds done/ + #expect /run-test-result AlwaysFails failed/ + expect /child-stdin p abcdef/ + expect /child-stdout p abcdef/ + expect /match p abcdef/ + expect /run-test-result ExpectEcho done/ + expect /run-all-done/ + + +test GetSysInfo: + node n + shell on n: + cp ${scripts.path}/erebos-tester.yaml . + mkdir tools + cp ${scripts.path}/tools/sysinfo.sh ./tools/tool + mkdir scripts + cp ${scripts.path}/sysinfo.et ./scripts/ + + spawn as p on n + + with p: + send "load-config" + expect /load-config-done/ + send "run SysInfo" + expect /run-done/ diff --git a/test/script/shell.et b/test/script/shell.et new file mode 100644 index 0000000..2fe4ec3 --- /dev/null +++ b/test/script/shell.et @@ -0,0 +1,80 @@ +asset scripts: + path: ../asset/shell + + +test ShellSpawn: + spawn as p + with p: + send "load ${scripts.path}/spawn.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run-all" + expect /run-test-result ShellTrue done/ + expect /child-fail sh failed at: .*: false/ + expect /child-fail sh exit code: 1/ + expect /run-test-result ShellFalse failed/ + expect /run-all-done/ + + +def expect_next_stdout from p (expected): + expect from p /child-stdout sh (.*)/ capture line + guard (line == expected) + +test ShellEcho: + spawn as p + with p: + send "load ${scripts.path}/echo.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run-all" + + expect_next_stdout from p: + "a b c" + "a b c" + "a b d" + "a b c d" + + "abcd xyz" + "aa bc d" + "b echo c" + + "a b" + "a b" + "\$space_str" + + "\$ \" \\" + "\"\"a" + "' \" \\\\\\ \\" + "a b c" + + "\" ' \\ \$ # | > < ; [ ] { } ( ) * ? ~ & !" + + with p: + expect /run-test-result Echo done/ + expect /run-all-done/ + + +test ShellPipe: + spawn as p + with p: + send "load ${scripts.path}/pipe.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run-all" + + expect_next_stdout from p: + "bc" + "b" + + with p: + expect /run-test-result Pipe done/ + expect /run-all-done/ |