diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Config.hs | 43 | ||||
-rw-r--r-- | src/Main.hs | 37 | ||||
-rw-r--r-- | src/Network/Ip.hs | 40 | ||||
-rw-r--r-- | src/Parser.hs | 4 | ||||
-rw-r--r-- | src/Parser/Expr.hs | 10 | ||||
-rw-r--r-- | src/Parser/Shell.hs | 8 | ||||
-rw-r--r-- | src/Parser/Statement.hs | 31 | ||||
-rw-r--r-- | src/Process.hs | 33 | ||||
-rw-r--r-- | src/Run.hs | 95 | ||||
-rw-r--r-- | src/Run/Monad.hs | 26 | ||||
-rw-r--r-- | src/Script/Object.hs | 42 | ||||
-rw-r--r-- | src/Script/Shell.hs | 21 | ||||
-rw-r--r-- | src/Test.hs | 51 | ||||
-rw-r--r-- | src/Test/Builtins.hs | 7 | ||||
-rw-r--r-- | src/TestMode.hs | 60 |
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 @@ -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" |