summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GDB.hs2
-rw-r--r--src/Main.hs8
-rw-r--r--src/Network/Ip.hs6
-rw-r--r--src/Output.hs81
-rw-r--r--src/Parser/Core.hs5
-rw-r--r--src/Parser/Expr.hs10
-rw-r--r--src/Parser/Shell.hs90
-rw-r--r--src/Parser/Statement.hs12
-rw-r--r--src/Process.hs113
-rw-r--r--src/Run.hs96
-rw-r--r--src/Run/Monad.hs26
-rw-r--r--src/Sandbox.hs16
-rw-r--r--src/Script/Expr.hs90
-rw-r--r--src/Script/Expr/Class.hs14
-rw-r--r--src/Script/Object.hs53
-rw-r--r--src/Script/Shell.hs219
-rw-r--r--src/Script/Var.hs10
-rw-r--r--src/Test.hs52
-rw-r--r--src/Test/Builtins.hs27
-rw-r--r--src/main.c112
-rw-r--r--src/shell.c8
21 files changed, 827 insertions, 223 deletions
diff --git a/src/GDB.hs b/src/GDB.hs
index 0819600..8d50d7f 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -72,12 +72,14 @@ gdbStart onCrash = do
{ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
}
pout <- liftIO $ newTVarIO []
+ ignore <- liftIO $ newTVarIO ( 0, [] )
let process = Process
{ procName = ProcNameGDB
, procHandle = Left handle
, procStdin = hin
, procOutput = pout
+ , procIgnore = ignore
, procKillWith = Nothing
, procNode = undefined
}
diff --git a/src/Main.hs b/src/Main.hs
index 2f4a0fe..b3f7a2a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,6 +4,7 @@ import Control.Monad
import Data.List
import Data.Maybe
+import Data.Text (Text)
import Data.Text qualified as T
import Text.Read (readMaybe)
@@ -30,6 +31,7 @@ import Version
data CmdlineOptions = CmdlineOptions
{ optTest :: TestOptions
, optRepeat :: Int
+ , optExclude :: [ Text ]
, optVerbose :: Bool
, optColor :: Maybe Bool
, optShowHelp :: Bool
@@ -41,6 +43,7 @@ defaultCmdlineOptions :: CmdlineOptions
defaultCmdlineOptions = CmdlineOptions
{ optTest = defaultTestOptions
, optRepeat = 1
+ , optExclude = []
, optVerbose = False
, optColor = Nothing
, optShowHelp = False
@@ -82,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"
@@ -174,7 +180,7 @@ main = do
out <- startOutput outputStyle useColor
( modules, globalDefs ) <- loadModules (map fst files)
- tests <- if null otests
+ 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
diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs
index 3750793..69a6b43 100644
--- a/src/Network/Ip.hs
+++ b/src/Network/Ip.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
module Network.Ip (
IpPrefix(..),
textIpNetwork,
@@ -134,7 +136,11 @@ addNetworkNamespace netnsName = do
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
diff --git a/src/Output.hs b/src/Output.hs
index 7c4a8a5..0ad1f12 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -9,6 +9,7 @@ module Output (
) where
import Control.Concurrent.MVar
+import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
@@ -24,6 +25,8 @@ import System.IO
import Text.Printf
+import Script.Expr
+
data Output = Output
{ outState :: MVar OutputState
, outConfig :: OutputConfig
@@ -53,7 +56,7 @@ data OutputType
| OutputChildInfo
| OutputChildFail
| OutputMatch
- | OutputMatchFail
+ | OutputMatchFail CallStack
| OutputError
| OutputAlways
| OutputTestRaw
@@ -83,7 +86,7 @@ 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 OutputMatchFail {} = T.pack "31"
outColor OutputError = T.pack "31"
outColor OutputAlways = "0"
outColor OutputTestRaw = "0"
@@ -95,7 +98,7 @@ outSign OutputChildStdin = T.empty
outSign OutputChildInfo = T.pack "."
outSign OutputChildFail = T.pack "!!"
outSign OutputMatch = T.pack "+"
-outSign OutputMatchFail = T.pack "/"
+outSign OutputMatchFail {} = T.pack "/"
outSign OutputError = T.pack "!!"
outSign OutputAlways = T.empty
outSign OutputTestRaw = T.empty
@@ -112,7 +115,7 @@ outTestLabel = \case
OutputChildInfo -> "child-info"
OutputChildFail -> "child-fail"
OutputMatch -> "match"
- OutputMatchFail -> "match-fail"
+ OutputMatchFail {} -> "match-fail"
OutputError -> "error"
OutputAlways -> "other"
OutputTestRaw -> ""
@@ -121,7 +124,7 @@ printWhenQuiet :: OutputType -> Bool
printWhenQuiet = \case
OutputChildStderr -> True
OutputChildFail -> True
- OutputMatchFail -> True
+ OutputMatchFail {} -> True
OutputError -> True
OutputAlways -> True
_ -> False
@@ -142,27 +145,59 @@ outLine otype prompt line = ioWithOutput $ \out ->
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
+ [ [ 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 []
+ ]
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
+ ]
+ 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
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 132dbc8..786fb2e 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -201,7 +201,8 @@ unifyExpr off pa expr = if
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 @@ osymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy operatorChar)
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
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 079cfba..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
diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs
index 89595e8..105edfa 100644
--- a/src/Parser/Shell.hs
+++ b/src/Parser/Shell.hs
@@ -20,16 +20,18 @@ import Parser.Expr
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
@@ -40,8 +42,8 @@ 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
@@ -50,32 +52,82 @@ parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)
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
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 474fa03..9b02770 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -175,13 +175,6 @@ instance ExprType a => ParamType (TypedVarName a) where
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 +210,8 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where
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))
@@ -434,6 +427,7 @@ testExpect = command "expect" $ Expect
<$> cmdLine
<*> (fromExprParam <$> paramOrContext "from")
<*> param ""
+ <*> (maybe 1 fromExprParam <$> param "timeout")
<*> param "capture"
<*> innerBlockFunList
diff --git a/src/Process.hs b/src/Process.hs
index 61a9fe8..1389987 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,15 +93,38 @@ 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 shell wrapper.
cmd' <- liftIO $ do
@@ -105,39 +138,28 @@ spawnOn target pname killWith cmd = do
let netns = either getNetns getNetns target
currentEnv <- liftIO $ getEnvironment
- (Just hin, Just hout, Just herr, handle) <- liftIO $ do
+ (Just procStdin, Just hout, Just herr, handle) <- liftIO $ do
runInNetworkNamespace netns $ createProcess (shell cmd')
{ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
, cwd = Just (either netDir nodeDir target)
, env = Just $ ( "EREBOS_DIR", "." ) : currentEnv
}
- pout <- liftIO $ newTVarIO []
-
- let process = Process
- { procName = pname
- , procHandle = Left handle
- , procStdin = hin
- , procOutput = pout
- , procKillWith = killWith
- , procNode = either (const undefined) id target
- }
+ let procHandle = Left handle
+ procOutput <- liftIO $ newTVarIO []
+ procIgnore <- liftIO $ newTVarIO ( 0, [] )
+ let procNode = either (const undefined) id target
+ let process = Process {..}
- void $ forkTest $ lineReadingLoop process hout $ \line -> do
- outProc OutputChildStdout process line
- liftIO $ atomically $ modifyTVar pout (++[line])
- void $ forkTest $ lineReadingLoop process herr $ \line -> do
- case pname of
- ProcNameTcpdump -> return ()
- _ -> outProc OutputChildStderr process line
+ startProcessIOLoops process hout herr
asks (teGDB . fst) >>= maybe (return Nothing) (liftIO . tryReadMVar) >>= \case
- Just gdb | ProcName _ <- pname -> addInferior gdb process
+ Just gdb | ProcName _ <- procName -> addInferior gdb process
_ -> return ()
return process
-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 <- getCurrentTimeout
+ 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,31 @@ 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 )
+
+ textObjectType _ _ = "IgnoreProcessOutput"
+ textObjectValue _ (IgnoreProcessOutput _ _) = "<IgnoreProcessOutput>"
+
+ createObject oid ( process@Process {..}, regex ) = do
+ liftIO $ atomically $ do
+ flushProcessOutput process regex
+ ( iid, list ) <- readTVar procIgnore
+ writeTVar procIgnore ( iid + 1, ( iid, regex ) : list )
+ return $ Object oid $ IgnoreProcessOutput process iid
+
+ destroyObject Object { objImpl = IgnoreProcessOutput Process {..} iid } = do
+ liftIO $ atomically $ do
+ writeTVar procIgnore . fmap (filter ((iid /=) . fst)) =<< readTVar procIgnore
+
+flushProcessOutput :: Process -> Maybe Regex -> STM ()
+flushProcessOutput p mbre = do
+ writeTVar (procOutput p) =<< case mbre of
+ Nothing -> return []
+ Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p)
diff --git a/src/Run.hs b/src/Run.hs
index 32b04c6..1a1dea0 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -12,15 +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.Proxy
import Data.Scientific
import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
-import Text.Megaparsec (errorBundlePretty, showErrorComponent)
import System.Directory
import System.Exit
@@ -29,6 +30,8 @@ import System.Posix.Process
import System.Posix.Signals
import System.Process
+import Text.Megaparsec (errorBundlePretty, showErrorComponent)
+
import GDB
import Network
import Network.Ip
@@ -36,8 +39,10 @@ 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
@@ -53,7 +58,9 @@ runTest out opts gdefs test = do
createDirectoryIfMissing True testDir
failedVar <- newTVarIO Nothing
+ objIdVar <- newMVar 1
procVar <- newMVar []
+ timeoutVar <- newMVar ( optTimeout opts, 0 )
mgdb <- if optGDB opts
then flip runReaderT out $ do
@@ -65,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
@@ -94,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
- runStep =<< 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)
@@ -144,7 +163,15 @@ runBlock (TestBlockStep prev step) = runBlock prev >> runStep step
runStep :: TestStep () -> TestRun ()
runStep = \case
Scope block -> do
- runBlock block
+ ( 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) $ runStep . inner
@@ -175,14 +202,14 @@ runStep = \case
outProc OutputChildStdin p line
send p line
- Expect line p expr captures inner -> do
- expect line p expr captures $ runStep . inner
+ Expect line p expr timeout captures inner -> do
+ expect line p expr timeout captures $ runStep . inner
Flush p regex -> do
- flush p regex
+ 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
@@ -206,11 +233,10 @@ withInternet :: (Network -> TestRun a) -> TestRun a
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
@@ -286,20 +312,15 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just (
| 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 <- asks $ optTimeout . teOptions . fst
+expect :: SourceLine -> Process -> Traced Regex -> Scientific -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun ()
+expect sline p (Traced trace re) etimeout tvars inner = do
+ timeout <- (etimeout *) <$> getCurrentTimeout
delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
line <- readTVar (procOutput p)
@@ -313,21 +334,14 @@ expect sline p (Traced trace re) tvars inner = do
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 (CallStack [ ( sline, [] ) ])) p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline
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") (CallStack [ ( sline, trace ) ]) (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
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index abef32d..c742987 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -8,6 +8,8 @@ module Run.Monad (
finally,
forkTest,
forkTestUsing,
+
+ getCurrentTimeout,
) where
import Control.Concurrent
@@ -15,6 +17,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
@@ -26,15 +29,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, Integer ) -- ( positive timeout, number of zero multiplications )
, teGDB :: Maybe (MVar GDB)
}
@@ -117,6 +128,13 @@ forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId
forkTestUsing fork act = do
tenv <- ask
liftIO $ fork $ do
- runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
+ ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act)
+ 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
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/Expr.hs b/src/Script/Expr.hs
index ced807c..7a446c5 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -18,7 +18,7 @@ module Script.Expr (
anull, exprArgs,
SomeArgumentType(..), ArgumentType(..),
- Traced(..), EvalTrace, VarNameSelectors, gatherVars,
+ Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars,
AppAnnotation(..),
module Script.Var,
@@ -58,7 +58,7 @@ data Expr a where
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 +98,7 @@ mapExpr f = go
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)
@@ -131,12 +131,6 @@ withVar name value = withDictionary (( name, someConstValue value ) : )
withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a
withTypedVar (TypedVarName name) = withVar name
-isInternalVar :: FqVarName -> Bool
-isInternalVar (GlobalVarName {}) = False
-isInternalVar (LocalVarName (VarName name))
- | Just ( '$', _ ) <- T.uncons name = True
- | otherwise = False
-
newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a)
deriving (Functor, Applicative, Monad)
@@ -152,31 +146,42 @@ instance MonadEval SimpleEval where
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 ) : 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 +210,7 @@ evalFunToVarValue expr = do
VarValue
<$> gatherVars expr
<*> pure (exprArgs expr)
- <*> pure (const fun)
+ <*> pure fun
evalSome :: MonadEval m => SomeExpr -> m SomeVarValue
evalSome (SomeExpr expr)
@@ -216,7 +221,7 @@ evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue
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 +294,7 @@ asFunType = \case
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 +308,27 @@ svvArguments (SomeVarValue vv) = vvArguments vv
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 +361,10 @@ exprArgs = \case
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,6 +382,11 @@ data Traced a = Traced EvalTrace a
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
@@ -385,17 +395,21 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
helper = \case
Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
Variable _ var
- | isInternalVar var -> return []
+ | GlobalVarName {} <- var -> return []
+ | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
+ DynVariable _ _ var
+ | GlobalVarName {} <- var -> return []
+ | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
+ FunVariable _ _ var
+ | GlobalVarName {} <- 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
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)
diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs
index 20a92b4..810b0c8 100644
--- a/src/Script/Expr/Class.hs
+++ b/src/Script/Expr/Class.hs
@@ -39,6 +39,10 @@ data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (P
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 @@ instance ExprType a => ExprType [a] where
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
diff --git a/src/Script/Object.hs b/src/Script/Object.hs
new file mode 100644
index 0000000..7e60f80
--- /dev/null
+++ b/src/Script/Object.hs
@@ -0,0 +1,53 @@
+module Script.Object (
+ ObjectId(..),
+ ObjectType(..),
+ Object(..), SomeObject(..),
+ toSomeObject, fromSomeObject,
+ destroySomeObject,
+) 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
+ , 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 5c70f2a..15c0c2c 100644
--- a/src/Script/Shell.hs
+++ b/src/Script/Shell.hs
@@ -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.Except
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,172 @@ import Network.Ip
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
+ }
+
+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>"
-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
+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
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
@@ -90,5 +213,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/Script/Var.hs b/src/Script/Var.hs
index 668060c..2c50101 100644
--- a/src/Script/Var.hs
+++ b/src/Script/Var.hs
@@ -9,6 +9,8 @@ module Script.Var (
import Data.Text (Text)
import Data.Text qualified as T
+import Script.Expr.Class
+
newtype VarName = VarName Text
deriving (Eq, Ord)
@@ -40,6 +42,10 @@ unqualifyName (LocalVarName name) = name
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 @@ data SourceLine
textSourceLine :: SourceLine -> Text
textSourceLine (SourceLine text) = text
textSourceLine SourceLineBuiltin = "<builtin>"
+
+instance ExprType SourceLine where
+ textExprType _ = "SourceLine"
+ textExprValue = textSourceLine
diff --git a/src/Test.hs b/src/Test.hs
index a9a2cdb..5530081 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -2,15 +2,25 @@ module Test (
Test(..),
TestStep(..),
TestBlock(..),
+
+ MultiplyTimeout(..),
) where
+import Control.Concurrent.MVar
+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
+import Output
import Process
+import Run.Monad
import Script.Expr
+import Script.Object
import Script.Shell
data Test = Test
@@ -32,20 +42,50 @@ instance Monoid (TestBlock ()) where
data TestStep a where
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 ] -> TestStep a) -> TestStep a
+ Expect :: 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
+ var <- asks (teTimeout . fst)
+ 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 not be negative"
+ throwError Failed
+
+ destroyObject Object { objImpl = MultiplyTimeout timeout } = do
+ var <- asks (teTimeout . fst)
+ liftIO $ modifyMVar_ var $ return .
+ (if timeout == 0 then second (subtract 1) else first (/ timeout))
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 69579bc..5f9f890 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
@@ -25,11 +29,7 @@ getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
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) $
@@ -49,9 +49,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)
+ \stack args -> TestBlockStep EmptyTestBlock $ Guard stack (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/main.c b/src/main.c
index 98daf2c..f609cfa 100644
--- a/src/main.c
+++ b/src/main.c
@@ -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 );
+}
generated by cgit v1.2.3 (git 2.25.1) at 2025-12-15 14:15:48 +0000