erebos-tester 0.3.3 → 0.3.4
raw patch · 22 files changed
+888/−255 lines, 22 filesdep ~basedep ~containersdep ~template-haskell
Dependency ranges changed: base, containers, template-haskell
Files
- CHANGELOG.md +11/−0
- README.md +46/−1
- erebos-tester.cabal +6/−4
- src/GDB.hs +4/−1
- src/Network.hs +2/−2
- src/Output.hs +110/−44
- src/Parser/Core.hs +3/−2
- src/Parser/Shell.hs +71/−19
- src/Parser/Statement.hs +15/−10
- src/Process.hs +102/−31
- src/Run.hs +51/−44
- src/Run/Monad.hs +10/−1
- src/Sandbox.hs +16/−0
- src/Script/Expr.hs +68/−37
- src/Script/Expr/Class.hs +14/−0
- src/Script/Object.hs +11/−0
- src/Script/Shell.hs +180/−40
- src/Script/Var.hs +10/−0
- src/Test.hs +20/−10
- src/Test/Builtins.hs +13/−7
- src/main.c +117/−2
- src/shell.c +8/−0
CHANGELOG.md view
@@ -1,5 +1,16 @@ # Revision history for erebos-tester +## 0.3.4 -- 2026-01-15++* Show call stack in error messages.+* Verbose output now includes test names, command and arguments for spawned processes, and marks flushed/ignored output lines.+* Added `ignore` builtin command.+* Added `timeout` argument for the `expect` command.+* Support zero as a timeout multiplier.+* Make host filesystems read-only for the test process (except for test dir).+* Implemented pipes and input/output redirection in shell scripts.+* Support for GHC up to 9.14.+ ## 0.3.3 -- 2025-06-25 * Added optional `timeout` setting to config file
README.md view
@@ -261,7 +261,7 @@ Send line with `<string>` to the standard input of `<process>`. ```-expect <regex> from <process> [capture <var1> [, <var2> ... ]]+expect <regex> from <process> [timeout <timeout>] [capture <var1> [, <var2> ... ]] ``` Check whether `<process>` produces line matching `<regex>` on standard output, and if this does not happen within current timeout, the test fails. Output lines produced before starting this command and not matched by some previous `expect` are accepted as well.@@ -274,6 +274,9 @@ In that case the expect command has to have the `capture` clause with matching number of variable names. Results of the captures are then assigned to the newly created variables as strings. +If the `timeout` clause is used, the current timeout value is multiplied by the given `<timeout>` for this `expect` call.+Timeout of zero can be used to expect a matching output line to have been already produced in the past.+ ``` flush [from <proc>] [matching <regex>] ```@@ -282,6 +285,15 @@ 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> ``` @@ -348,6 +360,39 @@ ``` Wait for user input before continuing. Useful mostly for debugging or test development.+++### Shell interpreter++**Experimental feature**: Functionality is not fully implemented and behavior may change in incompatible ways between releases.++Using the `shell` expression, it's possible to embed a shell script inside a test script.+The shell script is not passed to an external interpreter, but rather executed by the tester itself,+which allows the use of variables from the rest of the test script:++```+test:+ node some_node+ let x = "abc"+ shell as sh on some_node:+ echo $x > some_file+ echo ${some_node.ip} >> some_file+ cat some_file | sed 's/a/A/' > other_file+```++The syntax is intended to be generally similar to the classic Bourne shell,+however, only limited functionality is implemented so far (that includes executing commands, pipelines or input/output redirection).++The general form of the `shell` expression is:++```+shell [as <name>] on <node>:+ <shell commands>+```++Where `<node>` is the network node on which to run the script (it will be run in the network namespace of the node, and with working directory set to the node root),+and `<name>`, if given, is the name of the variable that will refer to the shell process (this can be used e.g. in the `expect` command to check the standard output of the script).+As with the `spawn` command, the resulting process is terminated at the end of the current scope. ### Functions
erebos-tester.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: erebos-tester-version: 0.3.3+version: 0.3.4 synopsis: Test framework with virtual network using Linux namespaces description: This framework is intended mainly for networking libraries/applications and@@ -62,6 +62,7 @@ Process Run Run.Monad+ Sandbox Script.Expr Script.Expr.Class Script.Module@@ -80,6 +81,7 @@ c-sources: src/main.c+ src/shell.c other-extensions: CPP@@ -106,9 +108,9 @@ TypeOperators build-depends:- base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 },+ base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21, 4.22 }, bytestring ^>= { 0.10, 0.11, 0.12 },- containers ^>= { 0.6.2.1, 0.7 },+ containers ^>= { 0.6.2.1, 0.7, 0.8 }, clock ^>= { 0.8.3 }, directory ^>=1.3.6.0, filepath ^>= { 1.4.2.1, 1.5.2 },@@ -122,7 +124,7 @@ regex-tdfa ^>=1.3.1.0, scientific >=0.3 && < 0.4, stm ^>= { 2.5.0 },- template-haskell^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 },+ template-haskell^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23, 2.24 }, text ^>= { 1.2, 2.0, 2.1 }, th-compat >=0.1 && <0.2, unix >=2.7 && <2.9,
src/GDB.hs view
@@ -72,12 +72,15 @@ { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } pout <- liftIO $ newTVarIO []+ ignore <- liftIO $ newTVarIO ( 0, [] ) let process = Process- { procName = ProcNameGDB+ { procId = ProcessId (-2)+ , procName = ProcNameGDB , procHandle = Left handle , procStdin = hin , procOutput = pout+ , procIgnore = ignore , procKillWith = Nothing , procNode = undefined }
src/Network.hs view
@@ -102,11 +102,11 @@ instance ExprType Network where textExprType _ = T.pack "network"- textExprValue n = "s:" <> textNetworkName (netPrefix n)+ textExprValue n = "<network:" <> textNetworkName (netPrefix n) <> ">" instance ExprType Node where textExprType _ = T.pack "node"- textExprValue n = T.pack "n:" <> textNodeName (nodeName n)+ textExprValue n = T.pack "<node:" <> textNodeName (nodeName n) <> ">" recordMembers = map (first T.pack) [ ( "ifname", RecordSelector $ const ("veth0" :: Text) )
src/Output.hs view
@@ -9,6 +9,7 @@ ) where import Control.Concurrent.MVar+import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader @@ -24,6 +25,8 @@ import Text.Printf +import Script.Expr+ data Output = Output { outState :: MVar OutputState , outConfig :: OutputConfig@@ -47,13 +50,17 @@ deriving (Eq) data OutputType- = OutputChildStdout+ = OutputGlobalInfo+ | OutputGlobalError+ | OutputChildStdout | OutputChildStderr | OutputChildStdin+ | OutputChildExec | OutputChildInfo | OutputChildFail | OutputMatch- | OutputMatchFail+ | OutputMatchFail CallStack+ | OutputIgnored | OutputError | OutputAlways | OutputTestRaw@@ -77,55 +84,79 @@ modifyMVar_ outStartedAt . const $ getTime Monotonic outColor :: OutputType -> Text-outColor OutputChildStdout = T.pack "0"-outColor OutputChildStderr = T.pack "31"-outColor OutputChildStdin = T.pack "0"-outColor OutputChildInfo = T.pack "0"-outColor OutputChildFail = T.pack "31"-outColor OutputMatch = T.pack "32"-outColor OutputMatchFail = T.pack "31"-outColor OutputError = T.pack "31"-outColor OutputAlways = "0"-outColor OutputTestRaw = "0"+outColor = \case+ OutputGlobalInfo -> "0"+ OutputGlobalError -> "31"+ OutputChildStdout -> "0"+ OutputChildStderr -> "31"+ OutputChildStdin -> "0"+ OutputChildExec -> "33"+ OutputChildInfo -> "0"+ OutputChildFail -> "31"+ OutputMatch -> "32"+ OutputMatchFail {} -> "31"+ OutputIgnored -> "90"+ OutputError -> "31"+ OutputAlways -> "0"+ OutputTestRaw -> "0" outSign :: OutputType -> Text-outSign OutputChildStdout = T.empty-outSign OutputChildStderr = T.pack "!"-outSign OutputChildStdin = T.empty-outSign OutputChildInfo = T.pack "."-outSign OutputChildFail = T.pack "!!"-outSign OutputMatch = T.pack "+"-outSign OutputMatchFail = T.pack "/"-outSign OutputError = T.pack "!!"-outSign OutputAlways = T.empty-outSign OutputTestRaw = T.empty+outSign = \case+ OutputGlobalInfo -> ""+ OutputGlobalError -> ""+ OutputChildStdout -> " "+ OutputChildStderr -> "!"+ OutputChildStdin -> T.empty+ OutputChildExec -> "*"+ OutputChildInfo -> "."+ OutputChildFail -> "!!"+ OutputMatch -> "+"+ OutputMatchFail {} -> "/"+ OutputIgnored -> "-"+ OutputError -> "!!"+ OutputAlways -> T.empty+ OutputTestRaw -> T.empty outArr :: OutputType -> Text-outArr OutputChildStdin = "<"-outArr _ = ">"+outArr = \case+ OutputGlobalInfo -> ""+ OutputGlobalError -> ""+ OutputChildStdin -> "<"+ _ -> ">" outTestLabel :: OutputType -> Text outTestLabel = \case+ OutputGlobalInfo -> "global-info"+ OutputGlobalError -> "global-error" OutputChildStdout -> "child-stdout" OutputChildStderr -> "child-stderr" OutputChildStdin -> "child-stdin"+ OutputChildExec -> "child-exec" OutputChildInfo -> "child-info" OutputChildFail -> "child-fail" OutputMatch -> "match"- OutputMatchFail -> "match-fail"+ OutputMatchFail {} -> "match-fail"+ OutputIgnored -> "ignored" OutputError -> "error" OutputAlways -> "other" OutputTestRaw -> "" printWhenQuiet :: OutputType -> Bool printWhenQuiet = \case+ OutputGlobalError -> True OutputChildStderr -> True OutputChildFail -> True- OutputMatchFail -> True+ OutputMatchFail {} -> True OutputError -> True OutputAlways -> True _ -> False +includeTestTime :: OutputType -> Bool+includeTestTime = \case+ OutputGlobalInfo -> False+ OutputGlobalError -> False+ _ -> True+ ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a ioWithOutput act = liftIO . act =<< getOutput @@ -142,27 +173,62 @@ stime <- readMVar (outStartedAt out) nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic withMVar (outState out) $ \st -> do- outPrint st $ TL.fromChunks $ concat- [ [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ]- , if outUseColor (outConfig out)- then [ T.pack "\ESC[", outColor otype, T.pack "m" ]- else []- , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]- , [ line ]- , if outUseColor (outConfig out)- then [ T.pack "\ESC[0m" ]- else []- ]+ forM_ (normalOutputLines otype line) $ \line' -> do+ outPrint st $ TL.fromChunks $ concat+ [ if includeTestTime otype+ then [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ]+ else []+ , if outUseColor (outConfig out)+ then [ T.pack "\ESC[", outColor otype, T.pack "m" ]+ else []+ , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]+ , [ line' ]+ , if outUseColor (outConfig out)+ then [ T.pack "\ESC[0m" ]+ else []+ ] testOutput out = do withMVar (outState out) $ \st -> do- outPrint st $ case otype of- OutputTestRaw -> TL.fromStrict line- _ -> TL.fromChunks- [ outTestLabel otype, " "- , maybe "-" id prompt, " "- , line- ]+ case otype of+ OutputTestRaw -> outPrint st $ TL.fromStrict line+ _ -> forM_ (testOutputLines otype (maybe "-" id prompt) line) $ outPrint st . TL.fromStrict+++normalOutputLines :: OutputType -> Text -> [ Text ]+normalOutputLines (OutputMatchFail (CallStack stack)) msg = concat+ [ msg <> " on " <> textSourceLine stackTopLine : showVars stackTopVars+ , concat $ flip map stackRest $ \( sline, vars ) ->+ " called from " <> textSourceLine sline : showVars vars+ ]+ where+ showVars =+ map $ \(( name, sel ), value ) -> T.concat+ [ " ", textFqVarName name, T.concat (map ("."<>) sel)+ , " = ", textSomeVarValue value+ ]+ (( stackTopLine, stackTopVars ), stackRest ) =+ case stack of+ (stop : srest) -> ( stop, srest )+ [] -> (( SourceLine "unknown", [] ), [] )+normalOutputLines _ msg = [ msg ]+++testOutputLines :: OutputType -> Text -> Text -> [ Text ]+testOutputLines otype@(OutputMatchFail (CallStack stack)) _ msg = concat+ [ [ T.concat [ outTestLabel otype, " ", msg ] ]+ , concat $ flip map stack $ \( sline, vars ) ->+ T.concat [ outTestLabel otype, "-line ", textSourceLine sline ] : showVars vars+ , [ T.concat [ outTestLabel otype, "-done" ] ]+ ]+ where+ showVars =+ map $ \(( name, sel ), value ) -> T.concat+ [ outTestLabel otype, "-var ", textFqVarName name, T.concat (map ("."<>) sel)+ , " ", textSomeVarValue value+ ]+testOutputLines otype prompt msg = [ T.concat [ outTestLabel otype, " ", prompt, " ", msg ] ]+ outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text) outPromptGetLine = outPromptGetLineCompletion noCompletion
src/Parser/Core.hs view
@@ -201,7 +201,8 @@ SomeExpr context <- gets testContext context' <- unifyExpr off atype context return $ Just ( kw, SomeExpr context' )- return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)+ sline <- getSourceLine+ return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) | Just (Refl :: DynamicType :~: b) <- eqT , Undefined msg <- expr@@ -235,7 +236,7 @@ wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s)-operatorChar = satisfy $ (`elem` ['.', '+', '-', '*', '/', '='])+operatorChar = satisfy $ (`elem` [ '.', '+', '-', '*', '/', '=', '<', '>', '|' ]) {-# INLINE operatorChar #-} localState :: TestParser a -> TestParser a
src/Parser/Shell.hs view
@@ -20,17 +20,19 @@ import Script.Expr import Script.Shell -parseArgument :: TestParser (Expr Text)-parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice+parseTextArgument :: TestParser (Expr Text)+parseTextArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice [ doubleQuotedString , singleQuotedString- , escapedChar+ , standaloneEscapedChar , stringExpansion , unquotedString ] where- specialChars = [ '\"', '\\', '$' ]+ specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']'{-, '{', '}' -}, '(', ')'{-, '*', '?', '~', '&', '!' -} ] + stringSpecialChars = [ '"', '\\', '$' ]+ unquotedString :: TestParser (Expr Text) unquotedString = do Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars)@@ -40,8 +42,8 @@ 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@@ -50,32 +52,82 @@ singleQuotedString = do Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'') - escapedChar :: TestParser (Expr Text)- escapedChar = do+ 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 "\\" ] -parseArguments :: TestParser (Expr [ Text ])+ standaloneEscapedChar :: TestParser (Expr Text)+ standaloneEscapedChar = do+ void $ char '\\'+ fmap T.singleton . Pure <$> printChar++parseRedirection :: TestParser (Expr ShellArgument)+parseRedirection = choice+ [ do+ osymbol "<"+ fmap ShellRedirectStdin <$> parseTextArgument+ , do+ osymbol ">"+ fmap (ShellRedirectStdout False) <$> parseTextArgument+ , do+ osymbol ">>"+ fmap (ShellRedirectStdout True) <$> parseTextArgument+ , do+ osymbol "2>"+ fmap (ShellRedirectStderr False) <$> parseTextArgument+ , do+ osymbol "2>>"+ fmap (ShellRedirectStderr True) <$> parseTextArgument+ ]++parseArgument :: TestParser (Expr ShellArgument)+parseArgument = choice+ [ parseRedirection+ , fmap ShellArgument <$> parseTextArgument+ ]++parseArguments :: TestParser (Expr [ ShellArgument ]) 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+ command <- parseTextArgument args <- parseArguments- return $ fmap (: []) $ ShellStatement+ return $ ShellCommand <$> command <*> args <*> pure line +parsePipeline :: Maybe (Expr ShellPipeline) -> TestParser (Expr ShellPipeline)+parsePipeline mbupper = do+ cmd <- parseCommand+ let pipeline =+ case mbupper of+ Nothing -> fmap (\ecmd -> ShellPipeline ecmd Nothing) cmd+ Just upper -> liftA2 (\ecmd eupper -> ShellPipeline ecmd (Just eupper)) cmd upper+ choice+ [ do+ osymbol "|"+ parsePipeline (Just pipeline)++ , do+ return pipeline+ ]++parseStatement :: TestParser (Expr [ ShellStatement ])+parseStatement = do+ line <- getSourceLine+ fmap ((: []) . flip ShellStatement line) <$> parsePipeline Nothing+ shellScript :: TestParser (Expr ShellScript) shellScript = do indent <- L.indentLevel- fmap ShellScript <$> blockOf indent shellStatement+ fmap ShellScript <$> blockOf indent parseStatement
src/Parser/Statement.hs view
@@ -169,19 +169,18 @@ parseParam _ = mzero showParamType _ = "<source line>" +instance ParamType CallStack where+ type ParamRep CallStack = Expr CallStack+ parseParam _ = mzero+ showParamType _ = "<call stack>"+ paramExpr = id+ instance ExprType a => ParamType (TypedVarName a) where parseParam _ = newVarName showParamType _ = "<variable>" paramNewVariables _ var = SomeNewVariables [ var ] paramNewVariablesEmpty _ = SomeNewVariables @a [] -instance ExprType a => ParamType (Expr a) where- parseParam _ = do- off <- stateOffset <$> getParserState- SomeExpr e <- literal <|> between (symbol "(") (symbol ")") someExpr- unifyExpr off Proxy e- showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">"- instance ParamType a => ParamType [a] where type ParamRep [a] = [ParamRep a] parseParam _ = listOf (parseParam @a Proxy)@@ -217,8 +216,8 @@ instance ExprType a => ParamType (Traced a) where type ParamRep (Traced a) = Expr a- parseParam _ = parseParam (Proxy @(Expr a))- showParamType _ = showParamType (Proxy @(Expr a))+ parseParam _ = parseParam (Proxy @(ExprParam a))+ showParamType _ = showParamType (Proxy @(ExprParam a)) paramExpr = Trace data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a))@@ -276,6 +275,9 @@ cmdLine :: CommandDef SourceLine cmdLine = param "" +callStack :: CommandDef CallStack+callStack = param ""+ newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } instance ExprType a => ParamType (InnerBlock a) where@@ -327,6 +329,7 @@ iparams <- forM params $ \case (_, SomeParam (p :: Proxy p) Nothing) | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line+ | Just (Refl :: p :~: CallStack) <- eqT -> return $ SomeParam p $ Identity $ Variable line callStackFqVarName | SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables , Just (Refl :: p :~: InnerBlock a) <- eqT@@ -431,9 +434,11 @@ testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect- <$> cmdLine+ <$> callStack+ <*> cmdLine <*> (fromExprParam <$> paramOrContext "from") <*> param ""+ <*> (maybe 1 fromExprParam <$> param "timeout") <*> param "capture" <*> innerBlockFunList
src/Process.hs view
@@ -1,14 +1,18 @@ module Process ( Process(..),- ProcName(..),- textProcName, unpackProcName,+ ProcessId(..), textProcId,+ ProcName(..), textProcName, unpackProcName, send,- outProc,+ outProc, outProcName, lineReadingLoop,+ startProcessIOLoops, spawnOn, closeProcess, closeTestProcess, withProcess,++ IgnoreProcessOutput(..),+ flushProcessOutput, ) where import Control.Arrow@@ -19,6 +23,8 @@ import Control.Monad.Reader import Data.Function+import Data.List+import Data.Maybe import Data.Scientific import Data.Text (Text) import Data.Text qualified as T@@ -38,13 +44,17 @@ import Network.Ip import Output import Run.Monad+import Script.Expr import Script.Expr.Class+import Script.Object data Process = Process- { procName :: ProcName+ { procId :: ProcessId+ , 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 }@@ -54,18 +64,23 @@ instance ExprType Process where textExprType _ = T.pack "proc"- textExprValue n = T.pack "p:" <> textProcName (procName n)+ textExprValue p = "<process:" <> textProcName (procName p) <> "#" <> textProcId (procId p) <> ">" recordMembers = map (first T.pack) [ ("node", RecordSelector $ procNode) ] +newtype ProcessId = ProcessId Int+ data ProcName = ProcName Text | ProcNameTcpdump | ProcNameGDB deriving (Eq, Ord) +textProcId :: ProcessId -> Text+textProcId (ProcessId pid) = T.pack (show pid)+ textProcName :: ProcName -> Text textProcName (ProcName name) = name textProcName ProcNameTcpdump = T.pack "tcpdump"@@ -80,20 +95,50 @@ hFlush (procStdin p) outProc :: MonadOutput m => OutputType -> Process -> Text -> m ()-outProc otype p line = outLine otype (Just $ textProcName $ procName p) line+outProc otype p line = outProcName otype (procName p) line +outProcName :: MonadOutput m => OutputType -> ProcName -> Text -> m ()+outProcName otype pname line = outLine otype (Just $ textProcName pname) 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+ ignored <- liftIO $ atomically $ do+ ignores <- map snd . snd <$> readTVar procIgnore+ let ignored = any (matches line) ignores+ when (not ignored) $ do+ modifyTVar procOutput (++ [ line ])+ return ignored+ when ignored $ do+ outProc OutputIgnored process line++ void $ forkTest $ lineReadingLoop process herr $ \line -> do+ case procName of+ ProcNameTcpdump -> return ()+ _ -> outProc OutputChildStderr process line++ where+ matches _ Nothing+ = True+ matches line (Just re)+ | Right (Just _) <- regexMatch re line = True+ | otherwise = False+ spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process-spawnOn target pname killWith cmd = do+spawnOn target procName procKillWith cmd = do -- When executing command given with relative path, turn it to absolute one, -- because working directory will be changed for the shell wrapper. cmd' <- liftIO $ do@@ -105,35 +150,30 @@ return (path' ++ rest) _ -> return cmd + procId <- case procName of+ ProcNameTcpdump -> return $ ProcessId (-1)+ _ -> do+ idVar <- asks $ teNextProcId . fst+ liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x ))+ let netns = either getNetns getNetns target currentEnv <- liftIO $ getEnvironment- (Just hin, Just hout, Just herr, handle) <- liftIO $ do+ (Just procStdin, Just hout, Just herr, handle) <- liftIO $ do runInNetworkNamespace netns $ createProcess (shell cmd') { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe , cwd = Just (either netDir nodeDir target) , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv }- pout <- liftIO $ newTVarIO []-- let process = Process- { procName = pname- , procHandle = Left handle- , procStdin = hin- , procOutput = pout- , procKillWith = killWith- , procNode = either (const undefined) id target- }+ let procHandle = Left handle+ procOutput <- liftIO $ newTVarIO []+ procIgnore <- liftIO $ newTVarIO ( 0, [] )+ let procNode = either (const undefined) id target+ let process = Process {..} - void $ forkTest $ lineReadingLoop process hout $ \line -> do- outProc OutputChildStdout process line- liftIO $ atomically $ modifyTVar pout (++[line])- void $ forkTest $ lineReadingLoop process herr $ \line -> do- case pname of- ProcNameTcpdump -> return ()- _ -> outProc OutputChildStderr process line+ startProcessIOLoops process hout herr asks (teGDB . fst) >>= maybe (return Nothing) (liftIO . tryReadMVar) >>= \case- Just gdb | ProcName _ <- pname -> addInferior gdb process+ Just gdb | ProcName _ <- procName -> addInferior gdb process _ -> return () return process@@ -158,7 +198,7 @@ closeTestProcess :: Process -> TestRun () closeTestProcess process = do- timeout <- liftIO . readMVar =<< asks (teTimeout . fst)+ timeout <- getCurrentTimeout closeProcess timeout process withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a@@ -172,3 +212,34 @@ ps <- liftIO $ takeMVar procVar closeTestProcess process `finally` do liftIO $ putMVar procVar $ filter (/=process) ps+++data IgnoreProcessOutput = IgnoreProcessOutput Process Int++instance ObjectType TestRun IgnoreProcessOutput where+ type ConstructorArgs IgnoreProcessOutput = ( Process, Maybe Regex )++ textObjectType _ _ = "IgnoreProcessOutput"+ textObjectValue _ (IgnoreProcessOutput _ _) = "<IgnoreProcessOutput>"++ createObject oid ( process@Process {..}, regex ) = do+ ( obj, flushed ) <- liftIO $ atomically $ do+ flushed <- flushProcessOutput process regex+ ( iid, list ) <- readTVar procIgnore+ writeTVar procIgnore ( iid + 1, ( iid, regex ) : list )+ return ( Object oid $ IgnoreProcessOutput process iid, flushed )+ mapM_ (outProc OutputIgnored process) flushed+ return obj++ destroyObject Object { objImpl = IgnoreProcessOutput Process {..} iid } = do+ liftIO $ atomically $ do+ writeTVar procIgnore . fmap (filter ((iid /=) . fst)) =<< readTVar procIgnore++flushProcessOutput :: Process -> Maybe Regex -> STM [ Text ]+flushProcessOutput p mbre = do+ current <- readTVar (procOutput p)+ let ( ignore, keep ) = case mbre of+ Nothing -> ( current, [] )+ Just re -> partition (either error isJust . regexMatch re) current+ writeTVar (procOutput p) keep+ return ignore
src/Run.hs view
@@ -39,6 +39,7 @@ import Parser import Process import Run.Monad+import Sandbox import Script.Expr import Script.Module import Script.Object@@ -58,8 +59,9 @@ failedVar <- newTVarIO Nothing objIdVar <- newMVar 1+ procIdVar <- newMVar 1 procVar <- newMVar []- timeoutVar <- newMVar $ optTimeout opts+ timeoutVar <- newMVar ( optTimeout opts, 0 ) mgdb <- if optGDB opts then flip runReaderT out $ do@@ -72,19 +74,21 @@ , teFailed = failedVar , teOptions = opts , teNextObjId = objIdVar+ , teNextProcId = procIdVar , teProcesses = procVar , teTimeout = timeoutVar , teGDB = fst <$> mgdb } tstate = TestState { tsGlobals = gdefs- , tsLocals = []+ , tsLocals = [ ( callStackVarName, someConstValue (CallStack []) ) ] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty } - let sigHandler SignalInfo { siginfoSpecific = chld } = do+ let sigHandler SignalInfo { siginfoSpecific = NoSignalSpecificInfo } = return ()+ sigHandler SignalInfo { siginfoSpecific = chld } = do processes <- readMVar procVar forM_ processes $ \p -> do mbpid <- either getPid (\_ -> return Nothing) (procHandle p)@@ -102,12 +106,25 @@ oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing resetOutputTime out- ( res, [] ) <- 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..."+ testRunResult <- newEmptyMVar + flip runReaderT out $ do+ void $ outLine OutputGlobalInfo Nothing $ "Starting test ‘" <> testName test <> "’"++ 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@@ -121,7 +138,7 @@ return True _ -> do flip runReaderT out $ do- void $ outLine OutputError Nothing $ "Test ‘" <> testName test <> "’ failed."+ void $ outLine OutputGlobalError Nothing $ "Test ‘" <> testName test <> "’ failed." return False @@ -177,9 +194,10 @@ opts <- asks $ teOptions . fst let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)- cmd = unwords $ tool : map (T.unpack . escape) args+ cmd = T.unwords $ T.pack tool : map escape args escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''"- withProcess (Right node) pname Nothing cmd $ runStep . inner+ outProcName OutputChildExec pname cmd+ withProcess (Right node) pname Nothing (T.unpack cmd) $ runStep . inner SpawnShell mbname node script inner -> do let tname | Just (TypedVarName (VarName name)) <- mbname = name@@ -191,14 +209,15 @@ outProc OutputChildStdin p line send p line - Expect line p expr captures inner -> do- expect line p expr captures $ runStep . inner+ Expect stack line p expr timeout captures inner -> do+ expect stack line p expr timeout captures $ runStep . inner Flush p regex -> do- flush p regex+ mapM_ (outProc OutputIgnored p) =<<+ atomicallyTest (flushProcessOutput p regex) - Guard line vars expr -> do- testStepGuard line vars expr+ Guard stack expr -> do+ testStepGuard stack expr DisconnectNode node inner -> do withDisconnectedUp (nodeUpstream node) $ runStep inner@@ -222,11 +241,10 @@ withInternet inner = do testDir <- asks $ optTestDir . teOptions . fst inet <- newInternet testDir- res <- withNetwork (inetRoot inet) $ \net -> do- withTypedVar rootNetworkVar net $ do- inner net- delInternet inet- return res+ flip finally (delInternet inet) $ do+ withNetwork (inetRoot inet) $ \net -> do+ withTypedVar rootNetworkVar net $ do+ inner net withSubnet :: Network -> Maybe (TypedVarName Network) -> (Network -> TestRun a) -> TestRun a withSubnet parent tvname inner = do@@ -302,20 +320,16 @@ | otherwise = fmap (x:) <$> tryMatch re xs tryMatch _ [] = Nothing -exprFailed :: Text -> SourceLine -> Maybe ProcName -> EvalTrace -> TestRun ()-exprFailed desc sline pname exprVars = do+exprFailed :: Text -> CallStack -> Maybe ProcName -> TestRun ()+exprFailed desc stack pname = do let prompt = maybe T.empty textProcName pname- outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", textSourceLine sline]- forM_ exprVars $ \((name, sel), value) ->- outLine OutputMatchFail (Just prompt) $ T.concat- [ " ", textFqVarName name, T.concat (map ("."<>) sel)- , " = ", textSomeVarValue sline value- ]+ outLine (OutputMatchFail stack) (Just prompt) $ desc <> " failed" throwError Failed -expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun ()-expect sline p (Traced trace re) tvars inner = do- timeout <- liftIO . readMVar =<< asks (teTimeout . fst)+expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestRun ()) -> TestRun ()+expect (CallStack cs) sline p (Traced trace re) etimeout tvars inner = do+ let stack = CallStack (( sline, trace ) : cs)+ timeout <- (etimeout *) <$> getCurrentTimeout delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do line <- readTVar (procOutput p)@@ -329,21 +343,14 @@ let vars = map (\(TypedVarName n) -> n) tvars when (length vars /= length capture) $ do- outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline+ outProc (OutputMatchFail stack) p $ T.pack "mismatched number of capture variables" throwError Failed outProc OutputMatch p line inner capture - 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)+ Nothing -> exprFailed (T.pack "expect") stack (Just $ procName p) -testStepGuard :: SourceLine -> EvalTrace -> Bool -> TestRun ()-testStepGuard sline vars x = do- when (not x) $ exprFailed (T.pack "guard") sline Nothing vars+testStepGuard :: CallStack -> Bool -> TestRun ()+testStepGuard stack x = do+ when (not x) $ exprFailed (T.pack "guard") stack Nothing
src/Run/Monad.hs view
@@ -8,6 +8,8 @@ finally, forkTest, forkTestUsing,++ getCurrentTimeout, ) where import Control.Concurrent@@ -42,8 +44,9 @@ , teFailed :: TVar (Maybe Failed) , teOptions :: TestOptions , teNextObjId :: MVar Int+ , teNextProcId :: MVar Int , teProcesses :: MVar [ Process ]- , teTimeout :: MVar Scientific+ , teTimeout :: MVar ( Scientific, Integer ) -- ( positive timeout, number of zero multiplications ) , teGDB :: Maybe (MVar GDB) } @@ -130,3 +133,9 @@ case res of Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e) Right () -> return ()++getCurrentTimeout :: TestRun Scientific+getCurrentTimeout = do+ ( timeout, zeros ) <- liftIO . readMVar =<< asks (teTimeout . fst)+ return $ if zeros > 0 then 0+ else timeout
+ src/Sandbox.hs view
@@ -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
src/Script/Expr.hs view
@@ -18,8 +18,9 @@ anull, exprArgs, SomeArgumentType(..), ArgumentType(..), - Traced(..), EvalTrace, VarNameSelectors, gatherVars,+ Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars, AppAnnotation(..),+ callStackVarName, callStackFqVarName, module Script.Var, @@ -28,6 +29,7 @@ ) where import Control.Monad+import Control.Monad.Except import Control.Monad.Reader import Data.Char@@ -58,7 +60,7 @@ ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a) ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a)- FunctionEval :: ExprType a => Expr (FunctionType a) -> Expr a+ FunctionEval :: ExprType a => SourceLine -> Expr (FunctionType a) -> Expr a LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b) Pure :: a -> Expr a App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b@@ -98,7 +100,7 @@ ArgsReq args expr -> f $ ArgsReq args (go expr) ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr) FunctionAbstraction expr -> f $ FunctionAbstraction (go expr)- FunctionEval expr -> f $ FunctionEval (go expr)+ FunctionEval sline expr -> f $ FunctionEval sline (go expr) LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr) e@Pure {} -> f e App ann efun earg -> f $ App ann (go efun) (go earg)@@ -138,45 +140,60 @@ | otherwise = False -newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a)- deriving (Functor, Applicative, Monad) +newtype SimpleEval a = SimpleEval (ReaderT ( GlobalDefs, VariableDictionary ) (Except String) a)+ deriving (Functor, Applicative, Monad, MonadError String)+ runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a-runSimpleEval (SimpleEval x) = curry $ runReader x+runSimpleEval (SimpleEval x) gdefs dict = either error id $ runExcept $ runReaderT x ( gdefs, dict ) +trySimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> Maybe a+trySimpleEval (SimpleEval x) gdefs dict = either (const Nothing) Just $ runExcept $ runReaderT x ( gdefs, dict )+ instance MonadFail SimpleEval where- fail = error . ("eval failed: " <>)+ fail = throwError . ("eval failed: " <>) instance MonadEval SimpleEval where askGlobalDefs = SimpleEval (asks fst) askDictionary = SimpleEval (asks snd) withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner) +callStackVarName :: VarName+callStackVarName = VarName "$STACK"++callStackFqVarName :: FqVarName+callStackFqVarName = LocalVarName callStackVarName+ eval :: forall m a. MonadEval m => Expr a -> m a eval = \case Let _ (TypedVarName name) valExpr expr -> do val <- eval valExpr withVar name val $ eval expr- Variable sline name -> fromSomeVarValue sline name =<< lookupVar name+ Variable _ name -> fromSomeVarValue (CallStack []) name =<< lookupVar name DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’"- FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name+ FunVariable _ _ name -> funFromSomeVarValue name =<< lookupVar name ArgsReq (FunctionArguments req) efun -> do gdefs <- askGlobalDefs dict <- askDictionary- return $ FunctionType $ \(FunctionArguments args) ->+ return $ FunctionType $ \stack (FunctionArguments args) -> let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict)- in fun $ FunctionArguments $ args `M.difference` req+ in fun stack $ FunctionArguments $ args `M.difference` req ArgsApp eargs efun -> do FunctionType fun <- eval efun args <- mapM evalSome eargs- return $ FunctionType $ \args' -> fun (args <> args')+ return $ FunctionType $ \stack args' -> fun stack (args <> args') FunctionAbstraction expr -> do- val <- eval expr- return $ FunctionType $ const val- FunctionEval efun -> do- FunctionType fun <- eval efun- return $ fun mempty+ gdefs <- askGlobalDefs+ dict <- askDictionary+ return $ FunctionType $ \stack _ ->+ runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : filter ((callStackVarName /=) . fst) dict)+ FunctionEval sline efun -> do+ vars <- gatherVars efun+ CallStack cs <- maybe (return $ CallStack []) (fromSomeVarValue (CallStack []) callStackFqVarName) =<< tryLookupVar callStackFqVarName+ let cs' = CallStack (( sline, vars ) : cs)+ FunctionType fun <- withVar callStackVarName cs' $ eval efun+ return $ fun cs' mempty LambdaAbstraction (TypedVarName name) expr -> do gdefs <- askGlobalDefs dict <- askDictionary@@ -205,7 +222,7 @@ VarValue <$> gatherVars expr <*> pure (exprArgs expr)- <*> pure (const fun)+ <*> pure fun evalSome :: MonadEval m => SomeExpr -> m SomeVarValue evalSome (SomeExpr expr)@@ -216,7 +233,7 @@ evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs [] -data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a)+data FunctionType a = FunctionType (CallStack -> FunctionArguments SomeVarValue -> a) instance ExprType a => ExprType (FunctionType a) where textExprType _ = "function type"@@ -289,7 +306,7 @@ data VarValue a = VarValue { vvVariables :: EvalTrace , vvArguments :: FunctionArguments SomeArgumentType- , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a+ , vvFunction :: CallStack -> FunctionArguments SomeVarValue -> a } data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a)@@ -303,27 +320,27 @@ someConstValue :: ExprType a => a -> SomeVarValue someConstValue = SomeVarValue . VarValue [] mempty . const . const -fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> VarValue a -> m a-fromConstValue sline name (VarValue _ args value :: VarValue b) = do+fromConstValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> VarValue a -> m a+fromConstValue stack name (VarValue _ args value :: VarValue b) = do maybe (fail err) return $ do guard $ anull args- cast $ value sline mempty+ cast $ value stack mempty where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", if anull args then textExprType @b Proxy else "function type" ] -fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m a-fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do+fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> SomeVarValue -> m a+fromSomeVarValue stack name (SomeVarValue (VarValue _ args value :: VarValue b)) = do maybe (fail err) return $ do guard $ anull args- cast $ value sline mempty+ cast $ value stack mempty where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", if anull args then textExprType @b Proxy else "function type" ] -textSomeVarValue :: SourceLine -> SomeVarValue -> Text-textSomeVarValue sline (SomeVarValue (VarValue _ args value))- | anull args = textExprValue $ value sline mempty+textSomeVarValue :: SomeVarValue -> Text+textSomeVarValue (SomeVarValue (VarValue _ args value))+ | anull args = textExprValue $ value (CallStack []) mempty | otherwise = "<function>" someVarValueType :: SomeVarValue -> SomeExprType@@ -356,10 +373,10 @@ App {} -> error "exprArgs: app" Undefined {} -> error "exprArgs: undefined" -funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m (FunctionType a)-funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do+funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => FqVarName -> SomeVarValue -> m (FunctionType a)+funFromSomeVarValue name (SomeVarValue (VarValue _ args value :: VarValue b)) = do maybe (fail err) return $ do- FunctionType <$> cast (value sline)+ FunctionType <$> cast value where err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has ", (if anull args then "type " else "function type returting ") <> textExprType @b Proxy ]@@ -377,7 +394,12 @@ type VarNameSelectors = ( FqVarName, [ Text ] ) type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ]+newtype CallStack = CallStack [ ( SourceLine, EvalTrace ) ] +instance ExprType CallStack where+ textExprType _ = T.pack "callstack"+ textExprValue _ = T.pack "<callstack>"+ gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace gatherVars = fmap (uniqOn fst . sortOn fst) . helper where@@ -385,24 +407,33 @@ helper = \case Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr Variable _ var+ | GlobalVarName {} <- var -> return [] | isInternalVar var -> return [] | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var- DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var- FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var+ DynVariable _ _ var+ | GlobalVarName {} <- var -> return []+ | isInternalVar var -> return []+ | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var+ FunVariable _ _ var+ | GlobalVarName {} <- var -> return []+ | isInternalVar var -> return []+ | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr ArgsApp (FunctionArguments args) fun -> do v <- helper fun vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args return $ concat (v : vs) FunctionAbstraction expr -> helper expr- FunctionEval efun -> helper efun+ FunctionEval _ efun -> helper efun LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr Pure _ -> return [] e@(App (AnnRecord sel) _ x) | Just (var, sels) <- gatherSelectors x -> do- val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e- return [ (( var, sels ++ [ sel ] ), val ) ]+ gdefs <- askGlobalDefs+ dict <- askDictionary+ let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval e) gdefs dict+ return $ catMaybes [ (( var, sels ++ [ sel ] ), ) <$> mbVal ] | otherwise -> do helper x App _ f x -> (++) <$> helper f <*> helper x
src/Script/Expr/Class.hs view
@@ -39,6 +39,10 @@ data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) +instance ExprType () where+ textExprType _ = "Unit"+ textExprValue () = "()"+ instance ExprType Integer where textExprType _ = T.pack "integer" textExprValue x = T.pack (show x)@@ -75,3 +79,13 @@ textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy)++instance ExprType a => ExprType (Maybe a) where+ textExprType _ = textExprType @a Proxy <> "?"+ textExprValue (Just x) = textExprValue x+ textExprValue Nothing = "Nothing"++instance (ExprType a, ExprType b) => ExprType (Either a b) where+ textExprType _ = textExprType @a Proxy <> "|" <> textExprType @b Proxy+ textExprValue (Left x) = "Left " <> textExprValue x+ textExprValue (Right x) = "Right " <> textExprValue x
src/Script/Object.hs view
@@ -7,17 +7,28 @@ ) where import Data.Kind+import Data.Text (Text) import Data.Typeable +import Script.Expr.Class + newtype ObjectId = ObjectId Int class Typeable a => ObjectType m a where type ConstructorArgs a :: Type type ConstructorArgs a = () + textObjectType :: proxy (m a) -> proxy a -> Text+ textObjectValue :: proxy (m a) -> a -> Text+ createObject :: ObjectId -> ConstructorArgs a -> m (Object m a) destroyObject :: Object m a -> m ()++instance (Typeable m, ObjectType m a) => ExprType (Object m a) where+ textExprType _ = textObjectType (Proxy @(m a)) (Proxy @a)+ textExprValue = textObjectValue (Proxy @(m a)) . objImpl+ data Object m a = ObjectType m a => Object { objId :: ObjectId
src/Script/Shell.hs view
@@ -1,6 +1,9 @@ module Script.Shell (- ShellStatement(..), ShellScript(..),+ ShellStatement(ShellStatement),+ ShellPipeline(ShellPipeline),+ ShellCommand(ShellCommand),+ ShellArgument(..), withShellProcess, ) where @@ -11,12 +14,21 @@ import Control.Monad.IO.Class import Control.Monad.Reader +import Data.Maybe 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.FilePath import System.IO+import System.Posix.IO qualified as P+import System.Posix.Process+import System.Posix.Types import System.Process hiding (ShellCommand) import Network@@ -24,61 +36,175 @@ import Output import Process import Run.Monad+import Script.Expr.Class 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+ , cmdExtArguments :: [ ShellArgument ]+ , cmdSourceLine :: SourceLine+ } -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- hFlush pstdout- 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)- , env = Just []- }- liftIO (waitForProcess phandle) >>= \case- ExitSuccess -> return ()- status -> do- outLine OutputChildFail (Just $ textProcName pname) $ "failed at: " <> textSourceLine shellSourceLine- liftIO $ putMVar statusVar status- throwError Failed- liftIO $ putMVar statusVar ExitSuccess+data ShellArgument+ = ShellArgument Text+ | ShellRedirectStdin Text+ | ShellRedirectStdout Bool Text+ | ShellRedirectStderr Bool Text +cmdArguments :: ShellCommand -> [ Text ]+cmdArguments = catMaybes . map (\case ShellArgument x -> Just x; _ -> Nothing) . cmdExtArguments++instance ExprType ShellScript where+ textExprType _ = T.pack "ShellScript"+ textExprValue _ = "<shell-script>"++instance ExprType ShellStatement where+ textExprType _ = T.pack "ShellStatement"+ textExprValue _ = "<shell-statement>"++instance ExprType ShellPipeline where+ textExprType _ = T.pack "ShellPipeline"+ textExprValue _ = "<shell-pipeline>"++instance ExprType ShellCommand where+ textExprType _ = T.pack "ShellCommand"+ textExprValue _ = "<shell-command>"++instance ExprType ShellArgument where+ textExprType _ = T.pack "ShellArgument"+ textExprValue _ = "<shell-argument>"+++data ShellExecInfo = ShellExecInfo+ { seiNode :: Node+ , seiProcName :: ProcName+ , seiStatusVar :: MVar ExitCode+ }+++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 scmd@ShellCommand {..} = do+ let args = cmdArguments scmd+ ( pstdin', pstdout', pstderr' ) <- (\f -> foldM f ( pstdin, pstdout, pstderr ) cmdExtArguments) $ \cur@( cin, cout, cerr ) -> \case+ ShellRedirectStdin path -> do+ closeIfRequested cin+ h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) ReadMode+ return ( CloseHandle h, cout, cerr )+ ShellRedirectStdout append path -> do+ closeIfRequested cout+ h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) $ if append then AppendMode else WriteMode+ return ( cin, CloseHandle h, cerr )+ ShellRedirectStderr append path -> do+ closeIfRequested cerr+ h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) $ if append then AppendMode else WriteMode+ return ( cin, cout, CloseHandle h )+ _ -> do+ return cur++ pid <- liftIO $ do+ (_, _, _, phandle) <- createProcess_ "shell"+ (proc (T.unpack cmdCommand) (map T.unpack args))+ { std_in = UseHandle $ handledHandle pstdin'+ , std_out = UseHandle $ handledHandle pstdout'+ , std_err = UseHandle $ handledHandle pstderr'+ , cwd = Just (nodeDir seiNode)+ , env = Just []+ }+ Just pid <- getPid phandle+ return pid++ mapM_ closeIfRequested [ pstdin', pstdout', pstderr' ]+ liftIO (getProcessStatus True False pid) >>= \case+ Just (Exited ExitSuccess) -> do+ return ()+ Just (Exited status) -> do+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "failed at: " <> textSourceLine cmdSourceLine+ liftIO $ putMVar seiStatusVar status+ throwError Failed+ Just (Terminated sig _) -> do+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "killed with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine+ liftIO $ putMVar seiStatusVar (ExitFailure (- fromIntegral sig))+ throwError Failed+ Just (Stopped sig) -> do+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "stopped with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine+ liftIO $ putMVar seiStatusVar (ExitFailure (- fromIntegral sig))+ throwError Failed+ Nothing -> do+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "no exit status"+ liftIO $ putMVar seiStatusVar (ExitFailure (- 1))+ 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+ idVar <- asks $ teNextProcId . fst+ procId <- liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x ))+ procOutput <- liftIO $ newTVarIO []- statusVar <- liftIO $ newEmptyMVar- ( pstdin, procStdin ) <- liftIO $ createPipe- ( hout, pstdout ) <- liftIO $ createPipe- ( herr, pstderr ) <- liftIO $ createPipe- procHandle <- fmap (Right . (, statusVar)) $ forkTestUsing forkOS $ do- executeScript procNode procName statusVar pstdin pstdout pstderr script+ 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@@ -92,3 +218,17 @@ ps <- liftIO $ takeMVar procVar 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"
src/Script/Var.hs view
@@ -9,7 +9,9 @@ import Data.Text (Text) import Data.Text qualified as T +import Script.Expr.Class + newtype VarName = VarName Text deriving (Eq, Ord) @@ -40,7 +42,11 @@ newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName } deriving (Eq, Ord) +instance ExprType a => ExprType (TypedVarName a) where+ textExprType _ = "TypedVarName"+ textExprValue = textVarName . fromTypedVarName + newtype ModuleName = ModuleName [ Text ] deriving (Eq, Ord, Show) @@ -54,3 +60,7 @@ textSourceLine :: SourceLine -> Text textSourceLine (SourceLine text) = text textSourceLine SourceLineBuiltin = "<builtin>"++instance ExprType SourceLine where+ textExprType _ = "SourceLine"+ textExprValue = textSourceLine
src/Test.hs view
@@ -10,8 +10,9 @@ import Control.Monad.Except import Control.Monad.Reader +import Data.Bifunctor import Data.Scientific-import Data.Text (Text)+import Data.Text (Text, pack) import Data.Typeable import Network@@ -47,35 +48,44 @@ 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 ] -> TestStep a) -> TestStep a+ Expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a Flush :: Process -> Maybe Regex -> TestStep ()- Guard :: SourceLine -> EvalTrace -> Bool -> TestStep ()+ Guard :: CallStack -> Bool -> TestStep () 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>"+instance ExprType a => ExprType (TestBlock a) where+ textExprType _ = "TestBlock"+ textExprValue _ = "<test-block>" +instance ExprType a => ExprType (TestStep a) where+ textExprType _ = "TestStep"+ textExprValue _ = "<test-step>" + data MultiplyTimeout = MultiplyTimeout Scientific instance ObjectType TestRun MultiplyTimeout where type ConstructorArgs MultiplyTimeout = Scientific + textObjectType _ _ = "MultiplyTimeout"+ textObjectValue _ (MultiplyTimeout x) = pack (show x) <> "@MultiplyTimeout"+ createObject oid timeout- | timeout > 0 = do+ | timeout >= 0 = do var <- asks (teTimeout . fst)- liftIO $ modifyMVar_ var $ return . (* timeout)+ liftIO $ modifyMVar_ var $ return .+ (if timeout == 0 then second (+ 1) else first (* timeout)) return $ Object oid $ MultiplyTimeout timeout | otherwise = do- outLine OutputError Nothing "timeout must be positive"+ outLine OutputError Nothing "timeout must not be negative" throwError Failed destroyObject Object { objImpl = MultiplyTimeout timeout } = do var <- asks (teTimeout . fst)- liftIO $ modifyMVar_ var $ return . (/ timeout)+ liftIO $ modifyMVar_ var $ return .+ (if timeout == 0 then second (subtract 1) else first (/ timeout))
src/Test/Builtins.hs view
@@ -8,7 +8,7 @@ import Data.Scientific import Data.Text (Text) -import Process (Process)+import Process import Script.Expr import Test @@ -16,6 +16,7 @@ builtins = M.fromList [ fq "send" builtinSend , fq "flush" builtinFlush+ , fq "ignore" builtinIgnore , fq "guard" builtinGuard , fq "multiply_timeout" builtinMultiplyTimeout , fq "wait" builtinWait@@ -28,11 +29,7 @@ getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a getArgMb (FunctionArguments args) kw = do- fromSomeVarValue SourceLineBuiltin (LocalVarName (VarName "")) =<< M.lookup kw args--getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( FqVarName, [ Text ] ), SomeVarValue ) ]-getArgVars (FunctionArguments args) kw = do- maybe [] svvVariables $ M.lookup kw args+ fromSomeVarValue (CallStack []) (LocalVarName (VarName "")) =<< M.lookup kw args builtinSend :: SomeVarValue builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $@@ -52,9 +49,18 @@ , ( 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)+ \stack args -> TestBlockStep EmptyTestBlock $ Guard stack (getArg args Nothing) builtinMultiplyTimeout :: SomeVarValue builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $
src/main.c view
@@ -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 @@ 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,11 +80,117 @@ 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(); hs_exit();++ 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 = umount2( "/run/old_root", MNT_DETACH );+ if( ret < 0 ){+ fprintf( stderr, "failed to detach /run/old_root: %s\n", 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; }
+ src/shell.c view
@@ -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 );+}