summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Config.hs43
-rw-r--r--src/Main.hs37
-rw-r--r--src/Network/Ip.hs40
-rw-r--r--src/Parser.hs4
-rw-r--r--src/Parser/Expr.hs10
-rw-r--r--src/Parser/Shell.hs8
-rw-r--r--src/Parser/Statement.hs31
-rw-r--r--src/Process.hs33
-rw-r--r--src/Run.hs95
-rw-r--r--src/Run/Monad.hs26
-rw-r--r--src/Script/Object.hs42
-rw-r--r--src/Script/Shell.hs21
-rw-r--r--src/Test.hs51
-rw-r--r--src/Test/Builtins.hs7
-rw-r--r--src/TestMode.hs60
15 files changed, 378 insertions, 130 deletions
diff --git a/src/Config.hs b/src/Config.hs
index 7f5895c..adf0321 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -2,11 +2,13 @@ module Config (
Config(..),
findConfig,
parseConfig,
+ getConfigTestFiles,
) where
import Control.Monad.Combinators
import Data.ByteString.Lazy qualified as BS
+import Data.Scientific
import Data.Text qualified as T
import Data.YAML
@@ -16,31 +18,31 @@ import System.FilePath
import System.FilePath.Glob
data Config = Config
- { configTool :: Maybe FilePath
- , configTests :: [Pattern]
+ { configDir :: FilePath
+ , configTool :: Maybe FilePath
+ , configTests :: [ Pattern ]
+ , configTimeout :: Maybe Scientific
}
deriving (Show)
-instance Semigroup Config where
- a <> b = Config
- { configTool = maybe (configTool b) Just (configTool a)
- , configTests = configTests a ++ configTests b
- }
-
-instance Monoid Config where
- mempty = Config
- { configTool = Nothing
- , configTests = []
- }
-
-instance FromYAML Config where
- parseYAML = withMap "Config" $ \m -> Config
- <$> (fmap T.unpack <$> m .:? "tool")
- <*> (map (compile . T.unpack) <$> foldr1 (<|>)
+instance FromYAML (FilePath -> Config) where
+ parseYAML = withMap "Config" $ \m -> do
+ configTool <- (fmap T.unpack <$> m .:? "tool")
+ configTests <- (map (compile . T.unpack) <$> foldr1 (<|>)
[ fmap (:[]) (m .: "tests") -- single pattern
, m .:? "tests" .!= [] -- list of patterns
]
)
+ configTimeout <- fmap fromNumber <$> m .:! "timeout"
+ return $ \configDir -> Config {..}
+
+newtype Number = Number { fromNumber :: Scientific }
+
+instance FromYAML Number where
+ parseYAML = \case
+ Scalar _ (SFloat x) -> return $ Number $ realToFrac x
+ Scalar _ (SInt x) -> return $ Number $ fromIntegral x
+ node -> typeMismatch "int or float" node
findConfig :: IO (Maybe FilePath)
findConfig = go "."
@@ -63,4 +65,7 @@ parseConfig path = do
Left (pos, err) -> do
putStr $ prettyPosWithSource pos contents err
exitFailure
- Right conf -> return conf
+ Right conf -> return $ conf $ takeDirectory path
+
+getConfigTestFiles :: Config -> IO [ FilePath ]
+getConfigTestFiles config = concat <$> mapM (flip globDir1 $ configDir config) (configTests config)
diff --git a/src/Main.hs b/src/Main.hs
index 48f95df..b3f7a2a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,27 +2,24 @@ module Main (main) where
import Control.Monad
-import Data.Bifunctor
import Data.List
import Data.Maybe
+import Data.Text (Text)
import Data.Text qualified as T
import Text.Read (readMaybe)
-import Text.Megaparsec (errorBundlePretty, showErrorComponent)
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
-import System.FilePath.Glob
import System.IO
import System.Posix.Terminal
import System.Posix.Types
import Config
import Output
-import Parser
import Process
import Run
import Script.Module
@@ -34,6 +31,7 @@ import Version
data CmdlineOptions = CmdlineOptions
{ optTest :: TestOptions
, optRepeat :: Int
+ , optExclude :: [ Text ]
, optVerbose :: Bool
, optColor :: Maybe Bool
, optShowHelp :: Bool
@@ -45,6 +43,7 @@ defaultCmdlineOptions :: CmdlineOptions
defaultCmdlineOptions = CmdlineOptions
{ optTest = defaultTestOptions
, optRepeat = 1
+ , optExclude = []
, optVerbose = False
, optColor = Nothing
, optShowHelp = False
@@ -86,6 +85,9 @@ options =
, Option ['r'] ["repeat"]
(ReqArg (\str opts -> opts { optRepeat = read str }) "<count>")
"number of times to repeat the test(s)"
+ , Option [ 'e' ] [ "exclude" ]
+ (ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test>")
+ "exclude given test from execution"
, Option [] ["wait"]
(NoArg $ to $ \opts -> opts { optWait = True })
"wait at the end of each test"
@@ -108,9 +110,8 @@ hiddenOptions =
main :: IO ()
main = do
- configPath <- findConfig
- config <- mapM parseConfig configPath
- let baseDir = maybe "." dropFileName configPath
+ config <- mapM parseConfig =<< findConfig
+ let baseDir = maybe "." configDir config
envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool ->
return $ fromMaybe (error "No test tool defined") $ mbtool `mplus` (return . (baseDir </>) =<< configTool =<< config)
@@ -119,6 +120,7 @@ main = do
{ optTest = defaultTestOptions
{ optDefaultTool = envtool
, optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions
+ , optTimeout = fromMaybe (optTimeout defaultTestOptions) $ configTimeout =<< config
}
}
@@ -151,7 +153,7 @@ main = do
exitSuccess
when (optTestMode opts) $ do
- testMode
+ testMode config
exitSuccess
case words $ optDefaultTool $ optTest opts of
@@ -165,7 +167,7 @@ main = do
case span (/= ':') ofile of
(path, ':':test) -> (path, Just $ T.pack test)
(path, _) -> (path, Nothing)
- else map (, Nothing) . concat <$> mapM (flip globDir1 baseDir) (maybe [] configTests config)
+ else map (, Nothing) <$> maybe (return []) (getConfigTestFiles) config
when (null files) $ fail $ "No test files"
@@ -177,18 +179,8 @@ main = do
| otherwise = OutputStyleQuiet
out <- startOutput outputStyle useColor
- ( modules, allModules ) <- parseTestFiles (map fst files) >>= \case
- Right res -> do
- return res
- Left err -> do
- case err of
- ImportModuleError bundle ->
- putStr (errorBundlePretty bundle)
- _ -> do
- putStrLn (showErrorComponent err)
- exitFailure
-
- tests <- if null otests
+ ( modules, globalDefs ) <- loadModules (map fst files)
+ tests <- filter ((`notElem` optExclude opts) . testName) <$> if null otests
then fmap concat $ forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do
case mbTestName of
Nothing -> return moduleTests
@@ -207,9 +199,6 @@ main = do
hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found"
exitFailure
-
- let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
-
ok <- allM (runTest out (optTest opts) globalDefs) $
concat $ replicate (optRepeat opts) tests
when (not ok) exitFailure
diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs
index 8f0887a..69a6b43 100644
--- a/src/Network/Ip.hs
+++ b/src/Network/Ip.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
module Network.Ip (
IpPrefix(..),
textIpNetwork,
@@ -17,7 +19,9 @@ module Network.Ip (
NetworkNamespace,
HasNetns(..),
addNetworkNamespace,
+ setNetworkNamespace,
textNetnsName,
+ runInNetworkNamespace,
callOn,
Link(..),
@@ -32,7 +36,9 @@ module Network.Ip (
addRoute,
) where
+import Control.Concurrent
import Control.Concurrent.STM
+import Control.Exception
import Control.Monad
import Control.Monad.Writer
@@ -42,6 +48,11 @@ import Data.Text qualified as T
import Data.Typeable
import Data.Word
+import Foreign.C.Error
+import Foreign.C.Types
+
+import System.Posix.IO
+import System.Posix.Types
import System.Process
newtype IpPrefix = IpPrefix [Word8]
@@ -122,12 +133,37 @@ addNetworkNamespace netnsName = do
netnsRoutesActive <- liftSTM $ newTVar []
return $ NetworkNamespace {..}
+setNetworkNamespace :: MonadIO m => NetworkNamespace -> m ()
+setNetworkNamespace netns = liftIO $ do
+ let path = "/var/run/netns/" <> T.unpack (textNetnsName netns)
+#if MIN_VERSION_unix(2,8,0)
+ open = openFd path ReadOnly defaultFileFlags { cloexec = True }
+#else
+ open = openFd path ReadOnly Nothing defaultFileFlags
+#endif
+ res <- bracket open closeFd $ \(Fd fd) -> do
+ c_setns fd c_CLONE_NEWNET
+ when (res /= 0) $ do
+ throwErrno "setns failed"
+
+foreign import ccall unsafe "sched.h setns" c_setns :: CInt -> CInt -> IO CInt
+c_CLONE_NEWNET :: CInt
+c_CLONE_NEWNET = 0x40000000
+
+runInNetworkNamespace :: NetworkNamespace -> IO a -> IO a
+runInNetworkNamespace netns act = do
+ mvar <- newEmptyMVar
+ void $ forkOS $ do
+ setNetworkNamespace netns
+ putMVar mvar =<< act
+ takeMVar mvar
+
+
textNetnsName :: NetworkNamespace -> Text
textNetnsName = netnsName
callOn :: HasNetns a => a -> Text -> IO ()
-callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> ns <> "\" " <> cmd
- where ns = textNetnsName $ getNetns n
+callOn n cmd = runInNetworkNamespace (getNetns n) $ callCommand $ T.unpack cmd
data Link a = Link
diff --git a/src/Parser.hs b/src/Parser.hs
index 0716457..9f1a0e3 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -43,7 +43,7 @@ parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do
modify $ \s -> s
{ testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar
}
- block (\name steps -> return $ Test name $ mconcat steps) header testStep
+ block (\name steps -> return $ Test name $ Scope <$> mconcat steps) header testStep
where
header = do
wsymbol "test"
@@ -64,7 +64,7 @@ parseDefinition href = label "symbol definition" $ do
osymbol ":"
scn
ref <- L.indentGuard scn GT href
- SomeExpr <$> blockOf ref testStep
+ SomeExpr <$> testBlock ref
, do
osymbol "="
someExpr <* eol
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 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 0f34fee..89595e8 100644
--- a/src/Parser/Shell.hs
+++ b/src/Parser/Shell.hs
@@ -3,6 +3,7 @@ module Parser.Shell (
shellScript,
) where
+import Control.Applicative (liftA2)
import Control.Monad
import Data.Char
@@ -22,6 +23,7 @@ import Script.Shell
parseArgument :: TestParser (Expr Text)
parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice
[ doubleQuotedString
+ , singleQuotedString
, escapedChar
, stringExpansion
, unquotedString
@@ -44,6 +46,10 @@ parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)
]
App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner
+ singleQuotedString :: TestParser (Expr Text)
+ singleQuotedString = do
+ Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'')
+
escapedChar :: TestParser (Expr Text)
escapedChar = do
void $ char '\\'
@@ -61,11 +67,13 @@ parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument
shellStatement :: TestParser (Expr [ ShellStatement ])
shellStatement = label "shell statement" $ do
+ line <- getSourceLine
command <- parseArgument
args <- parseArguments
return $ fmap (: []) $ ShellStatement
<$> command
<*> args
+ <*> pure line
shellScript :: TestParser (Expr ShellScript)
shellScript = do
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 812c559..474fa03 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -1,5 +1,6 @@
module Parser.Statement (
testStep,
+ testBlock,
) where
import Control.Monad
@@ -43,7 +44,7 @@ letStatement = do
addVarName off tname
void $ eol
body <- testBlock indent
- return $ Let line tname e body
+ return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body)
forStatement :: TestParser (Expr (TestBlock ()))
forStatement = do
@@ -68,7 +69,7 @@ forStatement = do
body <- testBlock indent
return $ (\xs f -> mconcat $ map f xs)
<$> (unpack <$> e)
- <*> LambdaAbstraction tname body
+ <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body)
shellStatement :: TestParser (Expr (TestBlock ()))
shellStatement = do
@@ -98,12 +99,6 @@ shellStatement = do
, do
off <- stateOffset <$> getParserState
symbol ":"
- pname <- case mbpname of
- Just pname -> return pname
- Nothing -> do
- registerParseError $ FancyError off $ S.singleton $ ErrorFail $
- "missing parameter with keyword ‘as’"
- return $ TypedVarName (VarName "")
node <- case mbnode of
Just node -> return node
Nothing -> do
@@ -114,9 +109,11 @@ shellStatement = do
void eol
void $ L.indentGuard scn GT ref
script <- shellScript
- cont <- testBlock ref
+ cont <- fmap Scope <$> testBlock ref
+ let expr | Just pname <- mbpname = LambdaAbstraction pname cont
+ | otherwise = const <$> cont
return $ TestBlockStep EmptyTestBlock <$>
- (SpawnShell pname <$> node <*> script <*> LambdaAbstraction pname cont)
+ (SpawnShell mbpname <$> node <*> script <*> expr)
]
exprStatement :: TestParser (Expr (TestBlock ()))
@@ -294,14 +291,14 @@ instance ExprType a => ParamType (InnerBlock a) where
combine f (x : xs) = f x xs
combine _ [] = error "inner block parameter count mismatch"
-innerBlock :: CommandDef (TestBlock ())
+innerBlock :: CommandDef (TestStep ())
innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun
-innerBlockFun :: ExprType a => CommandDef (a -> TestBlock ())
+innerBlockFun :: ExprType a => CommandDef (a -> TestStep ())
innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList
-innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock ())
-innerBlockFunList = fromInnerBlock <$> param ""
+innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ())
+innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param ""
newtype ExprParam a = ExprParam { fromExprParam :: a }
deriving (Functor, Foldable, Traversable)
@@ -384,7 +381,8 @@ testLocal = do
void $ eol
indent <- L.indentGuard scn GT ref
- localState $ testBlock indent
+ localState $ do
+ fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent
testWith :: TestParser (Expr (TestBlock ()))
testWith = do
@@ -410,7 +408,7 @@ testWith = do
indent <- L.indentGuard scn GT ref
localState $ do
modify $ \s -> s { testContext = ctx }
- testBlock indent
+ fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent
testSubnet :: TestParser (Expr (TestBlock ()))
testSubnet = command "subnet" $ Subnet
@@ -428,6 +426,7 @@ testSpawn :: TestParser (Expr (TestBlock ()))
testSpawn = command "spawn" $ Spawn
<$> param "as"
<*> (bimap fromExprParam fromExprParam <$> paramOrContext "on")
+ <*> (maybe [] fromExprParam <$> param "args")
<*> innerBlockFun
testExpect :: TestParser (Expr (TestBlock ()))
diff --git a/src/Process.hs b/src/Process.hs
index 290aedf..31641c9 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -7,6 +7,7 @@ module Process (
lineReadingLoop,
spawnOn,
closeProcess,
+ closeTestProcess,
withProcess,
) where
@@ -18,9 +19,10 @@ import Control.Monad.Except
import Control.Monad.Reader
import Data.Function
+import Data.Scientific
import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
import System.Directory
import System.Environment
@@ -93,7 +95,7 @@ lineReadingLoop process h act =
spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process
spawnOn target pname killWith cmd = do
-- When executing command given with relative path, turn it to absolute one,
- -- because working directory will be changed for the "ip netns exec" wrapper.
+ -- because working directory will be changed for the shell wrapper.
cmd' <- liftIO $ do
case span (/= ' ') cmd of
( path, rest )
@@ -104,13 +106,13 @@ spawnOn target pname killWith cmd = do
_ -> return cmd
let netns = either getNetns getNetns target
- let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" "
currentEnv <- liftIO $ getEnvironment
- (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd')
- { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
- , cwd = Just (either netDir nodeDir target)
- , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv
- }
+ (Just hin, Just hout, Just herr, handle) <- liftIO $ do
+ runInNetworkNamespace netns $ createProcess (shell cmd')
+ { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
+ , cwd = Just (either netDir nodeDir target)
+ , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv
+ }
pout <- liftIO $ newTVarIO []
let process = Process
@@ -136,8 +138,8 @@ spawnOn target pname killWith cmd = do
return process
-closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m ()
-closeProcess p = do
+closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Scientific -> Process -> m ()
+closeProcess timeout p = do
liftIO $ hClose $ procStdin p
case procKillWith p of
Nothing -> return ()
@@ -146,7 +148,7 @@ 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 +156,11 @@ closeProcess p = do
outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code
throwError Failed
+closeTestProcess :: Process -> TestRun ()
+closeTestProcess process = do
+ timeout <- liftIO . readMVar =<< asks (teTimeout . fst)
+ closeProcess timeout process
+
withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a
withProcess target pname killWith cmd inner = do
procVar <- asks $ teProcesses . fst
@@ -163,5 +170,5 @@ 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
diff --git a/src/Run.hs b/src/Run.hs
index b7093f4..d5b0d29 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -1,6 +1,7 @@
module Run (
module Run.Monad,
runTest,
+ loadModules,
evalGlobalDefs,
) where
@@ -11,13 +12,16 @@ import Control.Monad
import Control.Monad.Except
import Control.Monad.Fix
import Control.Monad.Reader
+import Control.Monad.Writer
+import Data.Bifunctor
import Data.Map qualified as M
import Data.Maybe
-import Data.Set qualified as S
+import Data.Proxy
import Data.Scientific
+import Data.Set qualified as S
import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Text qualified as T
import System.Directory
import System.Exit
@@ -26,17 +30,23 @@ import System.Posix.Process
import System.Posix.Signals
import System.Process
+import Text.Megaparsec (errorBundlePretty, showErrorComponent)
+
import GDB
import Network
import Network.Ip
import Output
+import Parser
import Process
import Run.Monad
import Script.Expr
+import Script.Module
+import Script.Object
import Script.Shell
import Test
import Test.Builtins
+
runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool
runTest out opts gdefs test = do
let testDir = optTestDir opts
@@ -47,7 +57,9 @@ runTest out opts gdefs test = do
createDirectoryIfMissing True testDir
failedVar <- newTVarIO Nothing
+ objIdVar <- newMVar 1
procVar <- newMVar []
+ timeoutVar <- newMVar $ optTimeout opts
mgdb <- if optGDB opts
then flip runReaderT out $ do
@@ -59,7 +71,9 @@ runTest out opts gdefs test = do
{ teOutput = out
, teFailed = failedVar
, teOptions = opts
+ , teNextObjId = objIdVar
, teProcesses = procVar
+ , teTimeout = timeoutVar
, teGDB = fst <$> mgdb
}
tstate = TestState
@@ -88,16 +102,16 @@ runTest out opts gdefs test = do
oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing
resetOutputTime out
- res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
+ ( res, [] ) <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
withInternet $ \_ -> do
- evalBlock =<< eval (testSteps test)
+ runStep =<< eval (testSteps test)
when (optWait opts) $ do
void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."
void $ installHandler processStatusChanged oldHandler Nothing
Right () <- runExceptT $ flip runReaderT out $ do
- maybe (return ()) (closeProcess . snd) mgdb
+ maybe (return ()) (closeProcess 1 . snd) mgdb
[] <- readMVar procVar
failed <- atomically $ readTVar (teFailed tenv)
@@ -105,23 +119,56 @@ runTest out opts gdefs test = do
(Right (), Nothing) -> do
when (not $ optKeep opts) $ removeDirectoryRecursive testDir
return True
- _ -> return False
+ _ -> do
+ flip runReaderT out $ do
+ void $ outLine OutputError Nothing $ "Test ‘" <> testName test <> "’ failed."
+ return False
+
+
+loadModules :: [ FilePath ] -> IO ( [ Module ], GlobalDefs )
+loadModules files = do
+ ( modules, allModules ) <- parseTestFiles files >>= \case
+ Right res -> do
+ return res
+ Left err -> do
+ case err of
+ ImportModuleError bundle ->
+ putStr (errorBundlePretty bundle)
+ _ -> do
+ putStrLn (showErrorComponent err)
+ exitFailure
+ let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
+ return ( modules, globalDefs )
evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs
evalGlobalDefs exprs = fix $ \gdefs ->
builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs)
-evalBlock :: TestBlock () -> TestRun ()
-evalBlock EmptyTestBlock = return ()
-evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of
+runBlock :: TestBlock () -> TestRun ()
+runBlock EmptyTestBlock = return ()
+runBlock (TestBlockStep prev step) = runBlock prev >> runStep step
+
+runStep :: TestStep () -> TestRun ()
+runStep = \case
+ Scope block -> do
+ ( x, objs ) <- censor (const []) $ listen $ catchError (Right <$> runBlock block) (return . Left)
+ mapM_ destroySomeObject (reverse objs)
+ either throwError return x
+
+ CreateObject (Proxy :: Proxy o) cargs -> do
+ objIdVar <- asks (teNextObjId . fst)
+ oid <- liftIO $ modifyMVar objIdVar (\x -> return ( x + 1, x ))
+ obj <- createObject @TestRun @o (ObjectId oid) cargs
+ tell [ toSomeObject obj ]
+
Subnet name parent inner -> do
- withSubnet parent (Just name) $ evalBlock . inner
+ withSubnet parent (Just name) $ runStep . inner
DeclNode name net inner -> do
- withNode net (Left name) $ evalBlock . inner
+ withNode net (Left name) $ runStep . inner
- Spawn tvname@(TypedVarName (VarName tname)) target inner -> do
+ Spawn tvname@(TypedVarName (VarName tname)) target args inner -> do
case target of
Left net -> withNode net (Right tvname) go
Right node -> go node
@@ -130,18 +177,22 @@ evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of
opts <- asks $ teOptions . fst
let pname = ProcName tname
tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
- withProcess (Right node) pname Nothing tool $ evalBlock . inner
+ cmd = unwords $ tool : map (T.unpack . escape) args
+ escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''"
+ withProcess (Right node) pname Nothing cmd $ runStep . inner
- SpawnShell (TypedVarName (VarName tname)) node script inner -> do
+ SpawnShell mbname node script inner -> do
+ let tname | Just (TypedVarName (VarName name)) <- mbname = name
+ | otherwise = "shell"
let pname = ProcName tname
- withShellProcess node pname script $ evalBlock . inner
+ withShellProcess node pname script $ runStep . inner
Send p line -> do
outProc OutputChildStdin p line
send p line
Expect line p expr captures inner -> do
- expect line p expr captures $ evalBlock . inner
+ expect line p expr captures $ runStep . inner
Flush p regex -> do
flush p regex
@@ -150,18 +201,18 @@ evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of
testStepGuard line vars expr
DisconnectNode node inner -> do
- withDisconnectedUp (nodeUpstream node) $ evalBlock inner
+ withDisconnectedUp (nodeUpstream node) $ runStep inner
DisconnectNodes net inner -> do
- withDisconnectedBridge (netBridge net) $ evalBlock inner
+ withDisconnectedBridge (netBridge net) $ runStep inner
DisconnectUpstream net inner -> do
case netUpstream net of
- Just link -> withDisconnectedUp link $ evalBlock inner
- Nothing -> evalBlock inner
+ Just link -> withDisconnectedUp link $ runStep inner
+ Nothing -> runStep inner
PacketLoss loss node inner -> do
- withNodePacketLoss node loss $ evalBlock inner
+ withNodePacketLoss node loss $ runStep inner
Wait -> do
void $ outPromptGetLine "Waiting..."
@@ -264,7 +315,7 @@ exprFailed desc sline pname exprVars = do
expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun ()
expect sline p (Traced trace re) tvars inner = do
- timeout <- asks $ optTimeout . teOptions . fst
+ timeout <- liftIO . readMVar =<< asks (teTimeout . fst)
delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
line <- readTVar (procOutput p)
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index e107017..f681e99 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -7,6 +7,7 @@ module Run.Monad (
finally,
forkTest,
+ forkTestUsing,
) where
import Control.Concurrent
@@ -14,6 +15,7 @@ import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
+import Control.Monad.Writer
import Data.Map (Map)
import Data.Scientific
@@ -25,15 +27,23 @@ import Network.Ip
import Output
import {-# SOURCE #-} Process
import Script.Expr
+import Script.Object
-newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a }
- deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO)
+newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed (WriterT [ SomeObject TestRun ] IO)) a }
+ deriving
+ ( Functor, Applicative, Monad
+ , MonadReader ( TestEnv, TestState )
+ , MonadWriter [ SomeObject TestRun ]
+ , MonadIO
+ )
data TestEnv = TestEnv
{ teOutput :: Output
, teFailed :: TVar (Maybe Failed)
, teOptions :: TestOptions
- , teProcesses :: MVar [Process]
+ , teNextObjId :: MVar Int
+ , teProcesses :: MVar [ Process ]
+ , teTimeout :: MVar Scientific
, teGDB :: Maybe (MVar GDB)
}
@@ -110,9 +120,13 @@ finally act handler = do
return x
forkTest :: TestRun () -> TestRun ThreadId
-forkTest act = do
+forkTest = forkTestUsing forkIO
+
+forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId
+forkTestUsing fork act = do
tenv <- ask
- liftIO $ forkIO $ do
- runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
+ liftIO $ fork $ do
+ ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act)
+ case res of
Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)
Right () -> return ()
diff --git a/src/Script/Object.hs b/src/Script/Object.hs
new file mode 100644
index 0000000..9232b21
--- /dev/null
+++ b/src/Script/Object.hs
@@ -0,0 +1,42 @@
+module Script.Object (
+ ObjectId(..),
+ ObjectType(..),
+ Object(..), SomeObject(..),
+ toSomeObject, fromSomeObject,
+ destroySomeObject,
+) where
+
+import Data.Kind
+import Data.Typeable
+
+
+newtype ObjectId = ObjectId Int
+
+class Typeable a => ObjectType m a where
+ type ConstructorArgs a :: Type
+ type ConstructorArgs a = ()
+
+ createObject :: ObjectId -> ConstructorArgs a -> m (Object m a)
+ destroyObject :: Object m a -> m ()
+
+data Object m a = ObjectType m a => Object
+ { objId :: ObjectId
+ , objImpl :: a
+ }
+
+data SomeObject m = forall a. ObjectType m a => SomeObject
+ { sobjId :: ObjectId
+ , sobjImpl :: a
+ }
+
+toSomeObject :: Object m a -> SomeObject m
+toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl }
+
+fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a)
+fromSomeObject SomeObject {..} = do
+ let objId = sobjId
+ objImpl <- cast sobjImpl
+ return Object {..}
+
+destroySomeObject :: SomeObject m -> m ()
+destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl)
diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs
index 60ec929..9bbf06c 100644
--- a/src/Script/Shell.hs
+++ b/src/Script/Shell.hs
@@ -20,21 +20,25 @@ import System.IO
import System.Process hiding (ShellCommand)
import Network
+import Network.Ip
import Output
import Process
import Run.Monad
+import Script.Var
data ShellStatement = ShellStatement
{ shellCommand :: Text
, shellArguments :: [ Text ]
+ , shellSourceLine :: SourceLine
}
newtype ShellScript = ShellScript [ ShellStatement ]
-executeScript :: Node -> ProcName -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()
-executeScript node pname pstdin pstdout pstderr (ShellScript statements) = do
+executeScript :: Node -> ProcName -> MVar ExitCode -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()
+executeScript node pname statusVar pstdin pstdout pstderr (ShellScript statements) = do
+ setNetworkNamespace $ getNetns node
forM_ statements $ \ShellStatement {..} -> case shellCommand of
"echo" -> liftIO $ do
T.hPutStrLn pstdout $ T.intercalate " " shellArguments
@@ -50,9 +54,11 @@ executeScript node pname pstdin pstdout pstderr (ShellScript statements) = do
}
liftIO (waitForProcess phandle) >>= \case
ExitSuccess -> return ()
- ExitFailure code -> do
- outLine OutputChildFail (Just $ textProcName pname) $ T.pack $ "exit code: " ++ show code
+ status -> do
+ outLine OutputChildFail (Just $ textProcName pname) $ "failed at: " <> textSourceLine shellSourceLine
+ liftIO $ putMVar statusVar status
throwError Failed
+ liftIO $ putMVar statusVar ExitSuccess
spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process
spawnShell procNode procName script = do
@@ -61,9 +67,8 @@ spawnShell procNode procName script = do
( pstdin, procStdin ) <- liftIO $ createPipe
( hout, pstdout ) <- liftIO $ createPipe
( herr, pstderr ) <- liftIO $ createPipe
- procHandle <- fmap (Right . (, statusVar)) $ forkTest $ do
- executeScript procNode procName pstdin pstdout pstderr script
- liftIO $ putMVar statusVar ExitSuccess
+ procHandle <- fmap (Right . (, statusVar)) $ forkTestUsing forkOS $ do
+ executeScript procNode procName statusVar pstdin pstdout pstderr script
let procKillWith = Nothing
let process = Process {..}
@@ -85,5 +90,5 @@ 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
diff --git a/src/Test.hs b/src/Test.hs
index b8c5049..3e98efa 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -2,20 +2,29 @@ module Test (
Test(..),
TestStep(..),
TestBlock(..),
+
+ MultiplyTimeout(..),
) where
+import Control.Concurrent.MVar
+import Control.Monad.Except
+import Control.Monad.Reader
+
import Data.Scientific
import Data.Text (Text)
import Data.Typeable
import Network
+import Output
import Process
+import Run.Monad
import Script.Expr
+import Script.Object
import Script.Shell
data Test = Test
{ testName :: Text
- , testSteps :: Expr (TestBlock ())
+ , testSteps :: Expr (TestStep ())
}
data TestBlock a where
@@ -31,20 +40,42 @@ instance Monoid (TestBlock ()) where
mempty = EmptyTestBlock
data TestStep a where
- Subnet :: TypedVarName Network -> Network -> (Network -> TestBlock a) -> TestStep a
- DeclNode :: TypedVarName Node -> Network -> (Node -> TestBlock a) -> TestStep a
- Spawn :: TypedVarName Process -> Either Network Node -> (Process -> TestBlock a) -> TestStep a
- SpawnShell :: TypedVarName Process -> Node -> ShellScript -> (Process -> TestBlock a) -> TestStep a
+ Scope :: TestBlock a -> TestStep a
+ CreateObject :: forall o. ObjectType TestRun o => Proxy o -> ConstructorArgs o -> TestStep ()
+ Subnet :: TypedVarName Network -> Network -> (Network -> TestStep a) -> TestStep a
+ DeclNode :: TypedVarName Node -> Network -> (Node -> TestStep a) -> TestStep a
+ Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> (Process -> TestStep a) -> TestStep a
+ SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a
Send :: Process -> Text -> TestStep ()
- Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestBlock a) -> TestStep a
+ Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a
Flush :: Process -> Maybe Regex -> TestStep ()
Guard :: SourceLine -> EvalTrace -> Bool -> TestStep ()
- DisconnectNode :: Node -> TestBlock a -> TestStep a
- DisconnectNodes :: Network -> TestBlock a -> TestStep a
- DisconnectUpstream :: Network -> TestBlock a -> TestStep a
- PacketLoss :: Scientific -> Node -> TestBlock a -> TestStep a
+ DisconnectNode :: Node -> TestStep a -> TestStep a
+ DisconnectNodes :: Network -> TestStep a -> TestStep a
+ DisconnectUpstream :: Network -> TestStep a -> TestStep a
+ PacketLoss :: Scientific -> Node -> TestStep a -> TestStep a
Wait :: TestStep ()
instance Typeable a => ExprType (TestBlock a) where
textExprType _ = "test block"
textExprValue _ = "<test block>"
+
+
+data MultiplyTimeout = MultiplyTimeout Scientific
+
+instance ObjectType TestRun MultiplyTimeout where
+ type ConstructorArgs MultiplyTimeout = Scientific
+
+ createObject oid timeout
+ | timeout > 0 = do
+ var <- asks (teTimeout . fst)
+ liftIO $ modifyMVar_ var $ return . (* timeout)
+ return $ Object oid $ MultiplyTimeout timeout
+
+ | otherwise = do
+ outLine OutputError Nothing "timeout must be positive"
+ throwError Failed
+
+ destroyObject Object { objImpl = MultiplyTimeout timeout } = do
+ var <- asks (teTimeout . fst)
+ liftIO $ modifyMVar_ var $ return . (/ timeout)
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 69579bc..6dba707 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -4,6 +4,8 @@ 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)
@@ -15,6 +17,7 @@ builtins = M.fromList
[ fq "send" builtinSend
, fq "flush" builtinFlush
, fq "guard" builtinGuard
+ , fq "multiply_timeout" builtinMultiplyTimeout
, fq "wait" builtinWait
]
where
@@ -53,5 +56,9 @@ builtinGuard :: SomeVarValue
builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
\sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing)
+builtinMultiplyTimeout :: SomeVarValue
+builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $
+ \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @MultiplyTimeout) (getArg args (Just "by"))
+
builtinWait :: SomeVarValue
builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait
diff --git a/src/TestMode.hs b/src/TestMode.hs
index ab938e6..c052fb9 100644
--- a/src/TestMode.hs
+++ b/src/TestMode.hs
@@ -4,12 +4,14 @@ module TestMode (
testMode,
) where
+import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Bifunctor
import Data.List
+import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
@@ -19,6 +21,7 @@ import System.IO.Error
import Text.Megaparsec.Error
import Text.Megaparsec.Pos
+import Config
import Output
import Parser
import Run
@@ -29,29 +32,32 @@ import Test
data TestModeInput = TestModeInput
{ tmiOutput :: Output
+ , tmiConfig :: Maybe Config
, tmiParams :: [ Text ]
}
data TestModeState = TestModeState
{ tmsModules :: [ Module ]
, tmsGlobals :: GlobalDefs
+ , tmsNextTestNumber :: Int
}
initTestModeState :: TestModeState
initTestModeState = TestModeState
{ tmsModules = mempty
, tmsGlobals = mempty
+ , tmsNextTestNumber = 1
}
-testMode :: IO ()
-testMode = do
- out <- startOutput OutputStyleTest False
+testMode :: Maybe Config -> IO ()
+testMode tmiConfig = do
+ tmiOutput <- startOutput OutputStyleTest False
let testLoop = getLineMb >>= \case
Just line -> do
case T.words line of
- cname : params
+ cname : tmiParams
| Just (CommandM cmd) <- lookup cname commands -> do
- runReaderT cmd $ TestModeInput out params
+ runReaderT cmd $ TestModeInput {..}
| otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'"
[] -> return ()
testLoop
@@ -59,7 +65,7 @@ testMode = do
Nothing -> return ()
runExceptT (evalStateT testLoop initTestModeState) >>= \case
- Left err -> flip runReaderT out $ outLine OutputError Nothing $ T.pack err
+ Left err -> flip runReaderT tmiOutput $ outLine OutputError Nothing $ T.pack err
Right () -> return ()
getLineMb :: MonadIO m => m (Maybe Text)
@@ -70,6 +76,25 @@ cmdOut line = do
out <- asks tmiOutput
flip runReaderT out $ outLine OutputTestRaw Nothing line
+getNextTestNumber :: CommandM Int
+getNextTestNumber = do
+ num <- gets tmsNextTestNumber
+ modify $ \s -> s { tmsNextTestNumber = num + 1 }
+ return num
+
+runSingleTest :: Test -> CommandM Bool
+runSingleTest test = do
+ out <- asks tmiOutput
+ num <- getNextTestNumber
+ globals <- gets tmsGlobals
+ mbconfig <- asks tmiConfig
+ let opts = defaultTestOptions
+ { optDefaultTool = fromMaybe "" $ configTool =<< mbconfig
+ , optTestDir = ".test" <> show num
+ , optKeep = True
+ }
+ liftIO (runTest out opts globals test)
+
newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a)
deriving
@@ -85,7 +110,9 @@ type Command = CommandM ()
commands :: [ ( Text, Command ) ]
commands =
[ ( "load", cmdLoad )
+ , ( "load-config", cmdLoadConfig )
, ( "run", cmdRun )
+ , ( "run-all", cmdRunAll )
]
cmdLoad :: Command
@@ -117,6 +144,16 @@ cmdLoad = do
, ":", show $ unPos sourceColumn
]
+cmdLoadConfig :: Command
+cmdLoadConfig = do
+ Just config <- asks tmiConfig
+ ( modules, globalDefs ) <- liftIO $ loadModules =<< getConfigTestFiles config
+ modify $ \s -> s
+ { tmsModules = modules
+ , tmsGlobals = globalDefs
+ }
+ cmdOut "load-config-done"
+
cmdRun :: Command
cmdRun = do
[ name ] <- asks tmiParams
@@ -124,7 +161,14 @@ cmdRun = do
case find ((name ==) . testName) $ concatMap moduleTests tmsModules of
Nothing -> cmdOut "run-not-found"
Just test -> do
- out <- asks tmiOutput
- liftIO (runTest out defaultTestOptions tmsGlobals test) >>= \case
+ runSingleTest test >>= \case
True -> cmdOut "run-done"
False -> cmdOut "run-failed"
+
+cmdRunAll :: Command
+cmdRunAll = do
+ TestModeState {..} <- get
+ forM_ (concatMap moduleTests tmsModules) $ \test -> do
+ res <- runSingleTest test
+ cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed")
+ cmdOut "run-all-done"
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-14 19:12:02 +0000