summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--erebos-tester.cabal2
-rw-r--r--src/GDB.hs4
-rw-r--r--src/Parser/Core.hs12
-rw-r--r--src/Parser/Expr.hs21
-rw-r--r--src/Parser/Shell.hs73
-rw-r--r--src/Parser/Statement.hs30
-rw-r--r--src/Process.hs14
-rw-r--r--src/Run.hs7
-rw-r--r--src/Run/Monad.hs4
-rw-r--r--src/Script/Shell.hs89
-rw-r--r--src/Test.hs2
11 files changed, 226 insertions, 32 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index 7c5f107..7f25169 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -55,6 +55,7 @@ executable erebos-tester
Parser
Parser.Core
Parser.Expr
+ Parser.Shell
Parser.Statement
Paths_erebos_tester
Process
@@ -63,6 +64,7 @@ executable erebos-tester
Script.Expr
Script.Expr.Class
Script.Module
+ Script.Shell
Script.Var
Test
Test.Builtins
diff --git a/src/GDB.hs b/src/GDB.hs
index 2862065..0819600 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -75,7 +75,7 @@ gdbStart onCrash = do
let process = Process
{ procName = ProcNameGDB
- , procHandle = handle
+ , procHandle = Left handle
, procStdin = hin
, procOutput = pout
, procKillWith = Nothing
@@ -144,7 +144,7 @@ gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . erro
addInferior :: MonadOutput m => GDB -> Process -> m ()
addInferior gdb process = do
- liftIO (getPid $ procHandle process) >>= \case
+ liftIO (either getPid (\_ -> return Nothing) $ procHandle process) >>= \case
Nothing -> outProc OutputError process $ "failed to get PID"
Just pid -> do
tgid <- liftIO (atomically $ tryReadTChan $ gdbThreadGroups gdb) >>= \case
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index abd8b96..d90f227 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -255,6 +255,18 @@ listOf item = do
x <- item
(x:) <$> choice [ symbol "," >> listOf item, return [] ]
+blockOf :: Monoid a => Pos -> TestParser a -> TestParser a
+blockOf indent step = go
+ where
+ go = do
+ scn
+ pos <- L.indentLevel
+ optional eof >>= \case
+ Just _ -> return mempty
+ _ | pos < indent -> return mempty
+ | pos == indent -> mappend <$> step <*> go
+ | otherwise -> L.incorrectIndent EQ indent pos
+
getSourceLine :: TestParser SourceLine
getSourceLine = do
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 5d60973..54f2757 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -11,6 +11,8 @@ module Parser.Expr (
literal,
variable,
+ stringExpansion,
+
checkFunctionArguments,
functionArguments,
) where
@@ -94,8 +96,8 @@ someExpansion = do
, between (char '{') (char '}') someExpr
]
-stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a)
-stringExpansion tname conv = do
+expressionExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [ Maybe (Expr a) ]) -> TestParser (Expr a)
+expressionExpansion tname conv = do
off <- stateOffset <$> getParserState
SomeExpr e <- someExpansion
let err = do
@@ -105,6 +107,13 @@ stringExpansion tname conv = do
maybe err return $ listToMaybe $ catMaybes $ conv e
+stringExpansion :: TestParser (Expr Text)
+stringExpansion = expressionExpansion (T.pack "string") $ \e ->
+ [ cast e
+ , fmap (T.pack . show @Integer) <$> cast e
+ , fmap (T.pack . show @Scientific) <$> cast e
+ ]
+
numberLiteral :: TestParser SomeExpr
numberLiteral = label "number" $ lexeme $ do
x <- L.scientific
@@ -131,11 +140,7 @@ quotedString = label "string" $ lexeme $ do
, char 't' >> return '\t'
]
(Pure (T.singleton c) :) <$> inner
- ,do e <- stringExpansion (T.pack "string") $ \e ->
- [ cast e
- , fmap (T.pack . show @Integer) <$> cast e
- , fmap (T.pack . show @Scientific) <$> cast e
- ]
+ ,do e <- stringExpansion
(e:) <$> inner
]
Concat <$> inner
@@ -153,7 +158,7 @@ regex = label "regular expression" $ lexeme $ do
, anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c])
]
(s:) <$> inner
- ,do e <- stringExpansion (T.pack "regex") $ \e ->
+ ,do e <- expressionExpansion (T.pack "regex") $ \e ->
[ cast e
, fmap RegexString <$> cast e
, fmap (RegexString . T.pack . show @Integer) <$> cast e
diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs
new file mode 100644
index 0000000..0f34fee
--- /dev/null
+++ b/src/Parser/Shell.hs
@@ -0,0 +1,73 @@
+module Parser.Shell (
+ ShellScript,
+ shellScript,
+) where
+
+import Control.Monad
+
+import Data.Char
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as TL
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer qualified as L
+
+import Parser.Core
+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
+ [ doubleQuotedString
+ , escapedChar
+ , stringExpansion
+ , unquotedString
+ ]
+ where
+ specialChars = [ '\"', '\\', '$' ]
+
+ unquotedString :: TestParser (Expr Text)
+ unquotedString = do
+ Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars)
+
+ doubleQuotedString :: TestParser (Expr Text)
+ doubleQuotedString = do
+ void $ char '"'
+ let inner = choice
+ [ char '"' >> return []
+ , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner
+ , (:) <$> escapedChar <*> inner
+ , (:) <$> stringExpansion <*> inner
+ ]
+ App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner
+
+ escapedChar :: TestParser (Expr Text)
+ escapedChar = do
+ void $ char '\\'
+ Pure <$> choice
+ [ char '\\' >> return "\\"
+ , char '"' >> return "\""
+ , char '$' >> return "$"
+ , char 'n' >> return "\n"
+ , char 'r' >> return "\r"
+ , char 't' >> return "\t"
+ ]
+
+parseArguments :: TestParser (Expr [ Text ])
+parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument
+
+shellStatement :: TestParser (Expr [ ShellStatement ])
+shellStatement = label "shell statement" $ do
+ command <- parseArgument
+ args <- parseArguments
+ return $ fmap (: []) $ ShellStatement
+ <$> command
+ <*> args
+
+shellScript :: TestParser (Expr ShellScript)
+shellScript = do
+ indent <- L.indentLevel
+ fmap ShellScript <$> blockOf indent shellStatement
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 1846fdb..7c2977d 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -21,6 +21,7 @@ import qualified Text.Megaparsec.Char.Lexer as L
import Network (Network, Node)
import Parser.Core
import Parser.Expr
+import Parser.Shell
import Process (Process)
import Script.Expr
import Script.Expr.Class
@@ -69,6 +70,22 @@ forStatement = do
<$> (unpack <$> e)
<*> LambdaAbstraction tname body
+shellStatement :: TestParser (Expr (TestBlock ()))
+shellStatement = do
+ ref <- L.indentLevel
+ wsymbol "shell"
+ wsymbol "as"
+ pname <- newVarName
+ wsymbol "on"
+ node <- typedExpr
+ symbol ":"
+ void eol
+ void $ L.indentGuard scn GT ref
+ script <- shellScript
+ cont <- testBlock ref
+ return $ TestBlockStep EmptyTestBlock <$>
+ (SpawnShell pname <$> node <*> script <*> LambdaAbstraction pname cont)
+
exprStatement :: TestParser (Expr (TestBlock ()))
exprStatement = do
ref <- L.indentLevel
@@ -413,22 +430,11 @@ testPacketLoss = command "packet_loss" $ PacketLoss
testBlock :: Pos -> TestParser (Expr (TestBlock ()))
testBlock indent = blockOf indent testStep
-blockOf :: Monoid a => Pos -> TestParser a -> TestParser a
-blockOf indent step = go
- where
- go = do
- scn
- pos <- L.indentLevel
- optional eof >>= \case
- Just _ -> return mempty
- _ | pos < indent -> return mempty
- | pos == indent -> mappend <$> step <*> go
- | otherwise -> L.incorrectIndent EQ indent pos
-
testStep :: TestParser (Expr (TestBlock ()))
testStep = choice
[ letStatement
, forStatement
+ , shellStatement
, testLocal
, testWith
, testSubnet
diff --git a/src/Process.hs b/src/Process.hs
index a65fb4a..92bbab1 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -39,7 +39,7 @@ import Script.Expr.Class
data Process = Process
{ procName :: ProcName
- , procHandle :: ProcessHandle
+ , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode )
, procStdin :: Handle
, procOutput :: TVar [Text]
, procKillWith :: Maybe Signal
@@ -113,17 +113,17 @@ spawnOn target pname killWith cmd = do
let process = Process
{ procName = pname
- , procHandle = handle
+ , procHandle = Left handle
, procStdin = hin
, procOutput = pout
, procKillWith = killWith
, procNode = either (const undefined) id target
}
- forkTest $ lineReadingLoop process hout $ \line -> do
+ void $ forkTest $ lineReadingLoop process hout $ \line -> do
outProc OutputChildStdout process line
liftIO $ atomically $ modifyTVar pout (++[line])
- forkTest $ lineReadingLoop process herr $ \line -> do
+ void $ forkTest $ lineReadingLoop process herr $ \line -> do
case pname of
ProcNameTcpdump -> return ()
_ -> outProc OutputChildStderr process line
@@ -139,14 +139,14 @@ closeProcess p = do
liftIO $ hClose $ procStdin p
case procKillWith p of
Nothing -> return ()
- Just sig -> liftIO $ getPid (procHandle p) >>= \case
+ Just sig -> liftIO $ either getPid (\_ -> return Nothing) (procHandle p) >>= \case
Nothing -> return ()
Just pid -> signalProcess sig pid
liftIO $ void $ forkIO $ do
threadDelay 1000000
- terminateProcess $ procHandle p
- liftIO (waitForProcess (procHandle p)) >>= \case
+ either terminateProcess (killThread . fst) $ procHandle p
+ liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) >>= \case
ExitSuccess -> return ()
ExitFailure code -> do
outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code
diff --git a/src/Run.hs b/src/Run.hs
index ed91936..b7093f4 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -33,6 +33,7 @@ import Output
import Process
import Run.Monad
import Script.Expr
+import Script.Shell
import Test
import Test.Builtins
@@ -72,7 +73,7 @@ runTest out opts gdefs test = do
let sigHandler SignalInfo { siginfoSpecific = chld } = do
processes <- readMVar procVar
forM_ processes $ \p -> do
- mbpid <- getPid (procHandle p)
+ mbpid <- either getPid (\_ -> return Nothing) (procHandle p)
when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do
let err detail = outProc OutputChildFail p detail
case siginfoStatus chld of
@@ -131,6 +132,10 @@ evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of
tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
withProcess (Right node) pname Nothing tool $ evalBlock . inner
+ SpawnShell (TypedVarName (VarName tname)) node script inner -> do
+ let pname = ProcName tname
+ withShellProcess node pname script $ evalBlock . inner
+
Send p line -> do
outProc OutputChildStdin p line
send p line
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index 1c96c90..e107017 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -109,10 +109,10 @@ finally act handler = do
void handler
return x
-forkTest :: TestRun () -> TestRun ()
+forkTest :: TestRun () -> TestRun ThreadId
forkTest act = do
tenv <- ask
- void $ liftIO $ forkIO $ do
+ liftIO $ forkIO $ do
runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)
Right () -> return ()
diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs
new file mode 100644
index 0000000..60ec929
--- /dev/null
+++ b/src/Script/Shell.hs
@@ -0,0 +1,89 @@
+module Script.Shell (
+ ShellStatement(..),
+ ShellScript(..),
+ withShellProcess,
+) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import System.Exit
+import System.IO
+import System.Process hiding (ShellCommand)
+
+import Network
+import Output
+import Process
+import Run.Monad
+
+
+data ShellStatement = ShellStatement
+ { shellCommand :: Text
+ , shellArguments :: [ Text ]
+ }
+
+newtype ShellScript = ShellScript [ ShellStatement ]
+
+
+executeScript :: Node -> ProcName -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()
+executeScript node pname pstdin pstdout pstderr (ShellScript statements) = do
+ 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 ()
+ ExitFailure code -> do
+ outLine OutputChildFail (Just $ textProcName pname) $ T.pack $ "exit code: " ++ show code
+ throwError Failed
+
+spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process
+spawnShell procNode procName script = do
+ procOutput <- liftIO $ newTVarIO []
+ statusVar <- liftIO $ newEmptyMVar
+ ( pstdin, procStdin ) <- liftIO $ createPipe
+ ( hout, pstdout ) <- liftIO $ createPipe
+ ( herr, pstderr ) <- liftIO $ createPipe
+ procHandle <- fmap (Right . (, statusVar)) $ forkTest $ do
+ executeScript procNode procName pstdin pstdout pstderr script
+ liftIO $ putMVar statusVar ExitSuccess
+
+ 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
+
+ return process
+
+withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a
+withShellProcess node pname script inner = do
+ procVar <- asks $ teProcesses . fst
+
+ process <- spawnShell node pname script
+ liftIO $ modifyMVar_ procVar $ return . (process:)
+
+ inner process `finally` do
+ ps <- liftIO $ takeMVar procVar
+ closeProcess process `finally` do
+ liftIO $ putMVar procVar $ filter (/=process) ps
diff --git a/src/Test.hs b/src/Test.hs
index c2a35e8..b8c5049 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -11,6 +11,7 @@ import Data.Typeable
import Network
import Process
import Script.Expr
+import Script.Shell
data Test = Test
{ testName :: Text
@@ -33,6 +34,7 @@ data TestStep a where
Subnet :: TypedVarName Network -> Network -> (Network -> TestBlock a) -> TestStep a
DeclNode :: TypedVarName Node -> Network -> (Node -> TestBlock a) -> TestStep a
Spawn :: TypedVarName Process -> Either Network Node -> (Process -> TestBlock a) -> TestStep a
+ SpawnShell :: TypedVarName Process -> Node -> ShellScript -> (Process -> TestBlock a) -> TestStep a
Send :: Process -> Text -> TestStep ()
Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestBlock a) -> TestStep a
Flush :: Process -> Maybe Regex -> TestStep ()
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-24 10:25:35 +0000