erebos-tester 0.3.1 → 0.3.2
raw patch · 21 files changed
+767/−168 lines, 21 files
Files
- CHANGELOG.md +7/−0
- README.md +51/−4
- erebos-tester.cabal +6/−1
- src/Asset.hs +33/−0
- src/GDB.hs +2/−2
- src/Main.hs +61/−16
- src/Output.hs +57/−16
- src/Parser.hs +58/−32
- src/Parser/Core.hs +24/−4
- src/Parser/Expr.hs +12/−18
- src/Parser/Shell.hs +78/−0
- src/Parser/Statement.hs +74/−38
- src/Process.hs +10/−8
- src/Run.hs +15/−5
- src/Run/Monad.hs +2/−2
- src/Script/Expr.hs +10/−1
- src/Script/Expr/Class.hs +15/−0
- src/Script/Shell.hs +89/−0
- src/Test.hs +29/−17
- src/Test/Builtins.hs +4/−4
- src/TestMode.hs +130/−0
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Revision history for erebos-tester +## 0.3.2 -- 2025-05-16++* Asset files and directories for use during tests+* Select tests from project configuration using only test name on command line without script path+* Added `args` parameter to `spawn` command to pass extra command-line arguments to the spawned tool+* Experimental shell interpreter+ ## 0.3.1 -- 2025-03-03 * Fix executing test tool given with relative path
README.md view
@@ -56,14 +56,26 @@ erebos-tester --verbose ``` -To run tests from a given test file, pass it as command-line argument:+To run all tests from project configuration (see below), run the tester without any argument: ```-erebos-tester path/to/script.test+erebos-tester ``` +To run only some named tests, list the names on command line:+```+erebos-tester FirstTest SecondTest+```++To run tests from a given test file, pass it as command-line argument (the path+must contain a slash, so use e.g. `./script.et` for script in the current+directory):+```+erebos-tester path/to/script.et+```+ To select single test from a file, use `:` separator: ```-erebos-tester path/to/script.test:TestName+erebos-tester path/to/script.et:TestName ``` Configuration@@ -196,6 +208,15 @@ `node` : Node on which the process is running. +#### asset++Represents an asset (file or directory), which can be used during test execution.++Members:++`path`+: Path to the asset valid during the test execution.+ #### list Lists are written using bracket notation:@@ -222,11 +243,12 @@ Create a node on network `<network>` (or context network if omitted) and assign the new node to the variable `<name>`. ```-spawn as <name> [on (<node> | <network>)]+spawn as <name> [on (<node> | <network>)] [args <arguments>] ``` Spawn a new test process on `<node>` or `<network>` (or one from context) and assign the new process to variable `<name>`. When spawning on network, create a new node for this process.+Extra `<arguments>` to the tool can be given as a list of strings using the `args` keyword. The process is terminated when the variable `<name>` goes out of scope (at the end of the block in which it was created) by closing its stdin. When the process fails to terminate successfully within a timeout, the test fails.@@ -422,6 +444,31 @@ import foo ```++### Assets++To provide the used test tool with access to auxiliary files needed for the+test execution, asset objects can be defined. The definition is done on the+toplevel using the `asset` keyword, giving the asset object name and a path to+the asset on the filesystem, relative to the directory containing the test+script:++```+asset my_asset:+ path: ../path/to/file+```++Such defined asset object can then be used in expressions within tests or function definitions:++```+test:+ spawn p+ send to p "use-asset ${my_asset.path}"+```++The `my_asset.path` expression expands to a strict containing path to the asset+that can be used by the spawn process `p`. The process should not try to modify+the file. Optional dependencies
erebos-tester.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: erebos-tester-version: 0.3.1+version: 0.3.2 synopsis: Test framework with virtual network using Linux namespaces description: This framework is intended mainly for networking libraries/applications and@@ -47,6 +47,7 @@ Main.hs other-modules:+ Asset Config GDB Network@@ -55,6 +56,7 @@ Parser Parser.Core Parser.Expr+ Parser.Shell Parser.Statement Paths_erebos_tester Process@@ -63,9 +65,11 @@ Script.Expr Script.Expr.Class Script.Module+ Script.Shell Script.Var Test Test.Builtins+ TestMode Util Version Version.Git@@ -77,6 +81,7 @@ src/main.c other-extensions:+ CPP TemplateHaskell default-extensions: DefaultSignatures
+ src/Asset.hs view
@@ -0,0 +1,33 @@+module Asset (+ Asset(..),+ AssetPath(..),+) where++import Data.Text (Text)+import Data.Text qualified as T+import Data.Typeable++import Script.Expr.Class++data Asset = Asset+ { assetPath :: AssetPath+ }++newtype AssetPath = AssetPath FilePath++textAssetPath :: AssetPath -> Text+textAssetPath (AssetPath path) = T.pack path++instance ExprType Asset where+ textExprType _ = "asset"+ textExprValue asset = "asset:" <> textAssetPath (assetPath asset)++ recordMembers =+ [ ( "path", RecordSelector $ assetPath )+ ]++instance ExprType AssetPath where+ textExprType _ = "filepath"+ textExprValue = ("filepath:" <>) . textAssetPath++ exprExpansionConvTo = cast textAssetPath
src/GDB.hs view
@@ -75,7 +75,7 @@ let process = Process { procName = ProcNameGDB- , procHandle = handle+ , procHandle = Left handle , procStdin = hin , procOutput = pout , procKillWith = Nothing@@ -144,7 +144,7 @@ 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
src/Main.hs view
@@ -8,6 +8,7 @@ import Data.Text qualified as T import Text.Read (readMaybe)+import Text.Megaparsec (errorBundlePretty, showErrorComponent) import System.Console.GetOpt import System.Directory@@ -26,6 +27,7 @@ import Run import Script.Module import Test+import TestMode import Util import Version @@ -36,6 +38,7 @@ , optColor :: Maybe Bool , optShowHelp :: Bool , optShowVersion :: Bool+ , optTestMode :: Bool } defaultCmdlineOptions :: CmdlineOptions@@ -46,9 +49,10 @@ , optColor = Nothing , optShowHelp = False , optShowVersion = False+ , optTestMode = False } -options :: [OptDescr (CmdlineOptions -> CmdlineOptions)]+options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] options = [ Option ['T'] ["tool"] (ReqArg (\str -> to $ \opts -> case break (==':') str of@@ -95,6 +99,13 @@ where to f opts = opts { optTest = f (optTest opts) } +hiddenOptions :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ]+hiddenOptions =+ [ Option [] [ "test-mode" ]+ (NoArg (\opts -> opts { optTestMode = True }))+ "test mode"+ ]+ main :: IO () main = do configPath <- findConfig@@ -112,15 +123,21 @@ } args <- getArgs- (opts, ofiles) <- case getOpt Permute options args of+ (opts, oselection) <- case getOpt Permute (options ++ hiddenOptions) args of (o, files, []) -> return (foldl (flip id) initOpts o, files) (_, _, errs) -> do hPutStrLn stderr $ concat errs <> "Try `erebos-tester --help' for more information." exitFailure + let ( ofiles, otests )+ | any (any isPathSeparator) oselection = ( oselection, [] )+ | otherwise = ( [], map T.pack oselection )+ when (optShowHelp opts) $ do let header = unlines- [ "Usage: erebos-tester [<option>...] [<script>[:<test>]...]"+ [ "Usage: erebos-tester [<option>...] [<test-name>...]"+ , " or: erebos-tester [<option>...] <script>[:<test>]..."+ , " <test-name> name of a test from project configuration" , " <script> path to test script file" , " <test> name of the test to run" , ""@@ -133,10 +150,16 @@ putStrLn versionLine exitSuccess - getPermissions (head $ words $ optDefaultTool $ optTest opts) >>= \perms -> do- when (not $ executable perms) $ do- fail $ optDefaultTool (optTest opts) <> " is not executable"+ when (optTestMode opts) $ do+ testMode+ exitSuccess + case words $ optDefaultTool $ optTest opts of+ (path : _) -> getPermissions path >>= \perms -> do+ when (not $ executable perms) $ do+ fail $ "‘" <> path <> "’ is not executable"+ _ -> fail $ "invalid tool argument: ‘" <> optDefaultTool (optTest opts) <> "’"+ files <- if not (null ofiles) then return $ flip map ofiles $ \ofile -> case span (/= ':') ofile of@@ -149,24 +172,46 @@ useColor <- case optColor opts of Just use -> return use Nothing -> queryTerminal (Fd 1)- out <- startOutput (optVerbose opts) useColor+ let outputStyle+ | optVerbose opts = OutputStyleVerbose+ | otherwise = OutputStyleQuiet+ out <- startOutput outputStyle useColor - ( modules, allModules ) <- parseTestFiles $ map fst files- tests <- forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do- case mbTestName of- Nothing -> return moduleTests- Just name- | Just test <- find ((==name) . testName) moduleTests- -> return [ test ]+ ( 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+ then fmap concat $ forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do+ case mbTestName of+ Nothing -> return moduleTests+ Just name+ | Just test <- find ((name ==) . testName) moduleTests+ -> return [ test ]+ | otherwise+ -> do+ hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found in ‘" <> filePath <> "’"+ exitFailure+ else forM otests $ \name -> if+ | Just test <- find ((name ==) . testName) $ concatMap moduleTests modules+ -> return test | otherwise -> do- hPutStrLn stderr $ "Test `" <> T.unpack name <> "' not found in `" <> filePath <> "'"+ 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) $ concat tests+ concat $ replicate (optRepeat opts) tests when (not ok) exitFailure foreign export ccall testerMain :: IO ()
src/Output.hs view
@@ -1,5 +1,5 @@ module Output (- Output, OutputType(..),+ Output, OutputStyle(..), OutputType(..), MonadOutput(..), startOutput, resetOutputTime,@@ -9,7 +9,6 @@ ) where import Control.Concurrent.MVar-import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader @@ -18,9 +17,10 @@ import Data.Text.Lazy qualified as TL import Data.Text.Lazy.IO qualified as TL +import System.Clock import System.Console.Haskeline import System.Console.Haskeline.History-import System.Clock+import System.IO import Text.Printf @@ -31,7 +31,7 @@ } data OutputConfig = OutputConfig- { outVerbose :: Bool+ { outStyle :: OutputStyle , outUseColor :: Bool } @@ -40,27 +40,36 @@ , outHistory :: History } -data OutputType = OutputChildStdout- | OutputChildStderr- | OutputChildStdin- | OutputChildInfo- | OutputChildFail- | OutputMatch- | OutputMatchFail- | OutputError- | OutputAlways+data OutputStyle+ = OutputStyleQuiet+ | OutputStyleVerbose+ | OutputStyleTest+ deriving (Eq) +data OutputType+ = OutputChildStdout+ | OutputChildStderr+ | OutputChildStdin+ | OutputChildInfo+ | OutputChildFail+ | OutputMatch+ | OutputMatchFail+ | OutputError+ | OutputAlways+ | OutputTestRaw+ class MonadIO m => MonadOutput m where getOutput :: m Output instance MonadIO m => MonadOutput (ReaderT Output m) where getOutput = ask -startOutput :: Bool -> Bool -> IO Output-startOutput outVerbose outUseColor = do+startOutput :: OutputStyle -> Bool -> IO Output+startOutput outStyle outUseColor = do outState <- newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory } outConfig <- pure OutputConfig {..} outStartedAt <- newMVar =<< getTime Monotonic+ hSetBuffering stdout LineBuffering return Output {..} resetOutputTime :: Output -> IO ()@@ -77,6 +86,7 @@ outColor OutputMatchFail = T.pack "31" outColor OutputError = T.pack "31" outColor OutputAlways = "0"+outColor OutputTestRaw = "0" outSign :: OutputType -> Text outSign OutputChildStdout = T.empty@@ -88,11 +98,25 @@ outSign OutputMatchFail = T.pack "/" outSign OutputError = T.pack "!!" outSign OutputAlways = T.empty+outSign OutputTestRaw = T.empty outArr :: OutputType -> Text outArr OutputChildStdin = "<" outArr _ = ">" +outTestLabel :: OutputType -> Text+outTestLabel = \case+ OutputChildStdout -> "child-stdout"+ OutputChildStderr -> "child-stderr"+ OutputChildStdin -> "child-stdin"+ OutputChildInfo -> "child-info"+ OutputChildFail -> "child-fail"+ OutputMatch -> "match"+ OutputMatchFail -> "match-fail"+ OutputError -> "error"+ OutputAlways -> "other"+ OutputTestRaw -> ""+ printWhenQuiet :: OutputType -> Bool printWhenQuiet = \case OutputChildStderr -> True@@ -107,7 +131,14 @@ outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m () outLine otype prompt line = ioWithOutput $ \out ->- when (outVerbose (outConfig out) || printWhenQuiet otype) $ do+ case outStyle (outConfig out) of+ OutputStyleQuiet+ | printWhenQuiet otype -> normalOutput out+ | otherwise -> return ()+ OutputStyleVerbose -> normalOutput out+ OutputStyleTest -> testOutput out+ where+ normalOutput out = do stime <- readMVar (outStartedAt out) nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic withMVar (outState out) $ \st -> do@@ -122,6 +153,16 @@ then [ T.pack "\ESC[0m" ] else [] ]++ testOutput out = do+ withMVar (outState out) $ \st -> do+ outPrint st $ case otype of+ OutputTestRaw -> TL.fromStrict line+ _ -> TL.fromChunks+ [ outTestLabel otype, " "+ , maybe "-" id prompt, " "+ , line+ ] outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text) outPromptGetLine = outPromptGetLineCompletion noCompletion
src/Parser.hs view
@@ -2,9 +2,11 @@ module Parser ( parseTestFiles,+ CustomTestError(..), ) where import Control.Monad+import Control.Monad.Except import Control.Monad.State import Data.IORef@@ -22,10 +24,10 @@ import Text.Megaparsec.Char.Lexer qualified as L import System.Directory-import System.Exit import System.FilePath import System.IO.Error +import Asset import Network import Parser.Core import Parser.Expr@@ -47,9 +49,9 @@ wsymbol "test" lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') -parseDefinition :: TestParser ( VarName, SomeExpr )-parseDefinition = label "symbol definition" $ do- def@( name, expr ) <- localState $ L.indentBlock scn $ do+parseDefinition :: Pos -> TestParser ( VarName, SomeExpr )+parseDefinition href = label "symbol definition" $ do+ def@( name, expr ) <- localState $ do wsymbol "def" name <- varName argsDecl <- functionArguments (\off _ -> return . ( off, )) varName mzero (\_ -> return . VarName)@@ -57,19 +59,20 @@ tvar <- newTypeVar modify $ \s -> s { testVars = ( vname, ( LocalVarName vname, ExprTypeVar tvar )) : testVars s } return ( off, vname, tvar )- choice+ SomeExpr expr <- choice [ do osymbol ":"- let finish steps = do- atypes' <- getInferredTypes atypes- ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs (mconcat steps)- return $ L.IndentSome Nothing finish testStep+ scn+ ref <- L.indentGuard scn GT href+ SomeExpr <$> blockOf ref testStep , do osymbol "="- SomeExpr (expr :: Expr e) <- someExpr- atypes' <- getInferredTypes atypes- L.IndentNone . ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr+ someExpr <* eol ]+ scn+ atypes' <- getInferredTypes atypes+ sexpr <- SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr+ return ( name, sexpr ) modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } return def where@@ -98,12 +101,37 @@ replaceArgs (SomeExpr e) = SomeExpr (go unif e) e -> e +parseAsset :: Pos -> TestParser ( VarName, SomeExpr )+parseAsset href = label "asset definition" $ do+ wsymbol "asset"+ name <- varName+ osymbol ":"+ void eol+ ref <- L.indentGuard scn GT href++ wsymbol "path"+ osymbol ":"+ off <- stateOffset <$> getParserState+ path <- TL.unpack <$> takeWhile1P Nothing (/= '\n')+ dir <- takeDirectory <$> gets testSourcePath+ absPath <- liftIO (makeAbsolute $ dir </> path)+ let assetPath = AssetPath absPath+ liftIO (doesPathExist absPath) >>= \case+ True -> return ()+ False -> registerParseError $ FancyError off $ S.singleton $ ErrorCustom $ FileNotFound absPath++ void $ L.indentGuard scn LT ref+ let expr = SomeExpr $ Pure Asset {..}+ modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s }+ return ( name, expr )+ parseExport :: TestParser [ Toplevel ] parseExport = label "export declaration" $ toplevel id $ do+ ref <- L.indentLevel wsymbol "export" choice [ do- def@( name, _ ) <- parseDefinition+ def@( name, _ ) <- parseDefinition ref <|> parseAsset ref return [ ToplevelDefinition def, ToplevelExport name ] , do names <- listOf varName@@ -138,7 +166,8 @@ modify $ \s -> s { testCurrentModuleName = moduleName } toplevels <- fmap concat $ many $ choice [ (: []) <$> parseTestDefinition- , (: []) <$> toplevel ToplevelDefinition parseDefinition+ , (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1)+ , (: []) <$> toplevel ToplevelDefinition (parseAsset pos1) , parseExport , parseImport ]@@ -148,51 +177,48 @@ eof return Module {..} -parseTestFiles :: [ FilePath ] -> IO ( [ Module ], [ Module ] )+parseTestFiles :: [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] )) parseTestFiles paths = do parsedModules <- newIORef []- requestedModules <- reverse <$> foldM (go parsedModules) [] paths- allModules <- map snd <$> readIORef parsedModules- return ( requestedModules, allModules )+ runExceptT $ do+ requestedModules <- reverse <$> foldM (go parsedModules) [] paths+ allModules <- map snd <$> liftIO (readIORef parsedModules)+ return ( requestedModules, allModules ) where go parsedModules res path = do- let moduleName = error "current module name should be set at the beginning of parseTestModule"- parseTestFile parsedModules moduleName path >>= \case- Left (ImportModuleError bundle) -> do- putStr (errorBundlePretty bundle)- exitFailure+ liftIO (parseTestFile parsedModules Nothing path) >>= \case Left err -> do- putStr (showErrorComponent err)- exitFailure+ throwError err Right cur -> do return $ cur : res -parseTestFile :: IORef [ ( FilePath, Module ) ] -> ModuleName -> FilePath -> IO (Either CustomTestError Module)-parseTestFile parsedModules moduleName path = do+parseTestFile :: IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module)+parseTestFile parsedModules mbModuleName path = do absPath <- makeAbsolute path (lookup absPath <$> readIORef parsedModules) >>= \case Just found -> return $ Right found Nothing -> do let initState = TestParserState- { testVars = concat+ { testSourcePath = path+ , testVars = concat [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins ] , testContext = SomeExpr (Undefined "void" :: Expr Void) , testNextTypeVar = 0 , testTypeUnif = M.empty- , testCurrentModuleName = moduleName+ , testCurrentModuleName = fromMaybe (error "current module name should be set at the beginning of parseTestModule") mbModuleName , testParseModule = \(ModuleName current) mname@(ModuleName imported) -> do let projectRoot = iterate takeDirectory absPath !! length current- parseTestFile parsedModules mname $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath+ parseTestFile parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath } mbContent <- (Just <$> TL.readFile path) `catchIOError` \e -> if isDoesNotExistError e then return Nothing else ioError e case mbContent of Just content -> do- runTestParser path content initState (parseTestModule absPath) >>= \case+ runTestParser content initState (parseTestModule absPath) >>= \case Left bundle -> do return $ Left $ ImportModuleError bundle Right testModule -> do modifyIORef parsedModules (( absPath, testModule ) : ) return $ Right testModule- Nothing -> return $ Left $ ModuleNotFound moduleName+ Nothing -> return $ Left $ maybe (FileNotFound path) ModuleNotFound mbModuleName
src/Parser/Core.hs view
@@ -27,6 +27,7 @@ , MonadState TestParserState , MonadPlus , MonadFail+ , MonadIO , MonadParsec CustomTestError TestStream ) @@ -36,6 +37,7 @@ data CustomTestError = ModuleNotFound ModuleName+ | FileNotFound FilePath | ImportModuleError (ParseErrorBundle TestStream CustomTestError) deriving (Eq) @@ -44,17 +46,22 @@ compare (ModuleNotFound _) _ = LT compare _ (ModuleNotFound _) = GT + compare (FileNotFound a) (FileNotFound b) = compare a b+ compare (FileNotFound _) _ = LT+ compare _ (FileNotFound _) = GT+ -- Ord instance is required to store errors in Set, but there shouldn't be -- two ImportModuleErrors at the same possition, so "dummy" comparison -- should be ok. compare (ImportModuleError _) (ImportModuleError _) = EQ instance ShowErrorComponent CustomTestError where- showErrorComponent (ModuleNotFound name) = "module `" <> T.unpack (textModuleName name) <> "' not found"+ showErrorComponent (ModuleNotFound name) = "module ‘" <> T.unpack (textModuleName name) <> "’ not found"+ showErrorComponent (FileNotFound path) = "file ‘" <> path <> "’ not found" showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle -runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a)-runTestParser path content initState (TestParser parser) = flip (flip runParserT path) content . flip evalStateT initState $ parser+runTestParser :: TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a)+runTestParser content initState (TestParser parser) = flip (flip runParserT (testSourcePath initState)) content . flip evalStateT initState $ parser data Toplevel = ToplevelTest Test@@ -63,7 +70,8 @@ | ToplevelImport ( ModuleName, VarName ) data TestParserState = TestParserState- { testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ]+ { testSourcePath :: FilePath+ , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ] , testContext :: SomeExpr , testNextTypeVar :: Int , testTypeUnif :: Map TypeVar SomeExprType@@ -254,6 +262,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
src/Parser/Expr.hs view
@@ -11,6 +11,8 @@ literal, variable, + stringExpansion,+ checkFunctionArguments, functionArguments, ) where@@ -35,8 +37,6 @@ import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L import Text.Megaparsec.Error.Builder qualified as Err-import Text.Regex.TDFA qualified as RE-import Text.Regex.TDFA.Text qualified as RE import Parser.Core import Script.Expr@@ -94,8 +94,8 @@ , 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 :: forall a. ExprType a => Text -> TestParser (Expr a)+expressionExpansion tname = do off <- stateOffset <$> getParserState SomeExpr e <- someExpansion let err = do@@ -103,8 +103,11 @@ [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ] return $ Undefined "expansion not defined for type" - maybe err return $ listToMaybe $ catMaybes $ conv e+ maybe err (return . (<$> e)) $ listToMaybe $ catMaybes [ cast (id :: a -> a), exprExpansionConvTo, exprExpansionConvFrom ] +stringExpansion :: TestParser (Expr Text)+stringExpansion = expressionExpansion "string"+ numberLiteral :: TestParser SomeExpr numberLiteral = label "number" $ lexeme $ do x <- L.scientific@@ -131,11 +134,7 @@ , 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,19 +152,14 @@ , anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c]) ] (s:) <$> inner- ,do e <- stringExpansion (T.pack "regex") $ \e ->- [ cast e- , fmap RegexString <$> cast e- , fmap (RegexString . T.pack . show @Integer) <$> cast e- , fmap (RegexString . T.pack . show @Scientific) <$> cast e- ]+ ,do e <- expressionExpansion (T.pack "regex") (e:) <$> inner ] parts <- inner let testEval = \case Pure (RegexPart p) -> p _ -> ""- case RE.compile RE.defaultCompOpt RE.defaultExecOpt $ T.concat $ map testEval parts of+ case regexCompile $ T.concat $ map testEval parts of Left err -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [ "failed to parse regular expression: ", T.pack err ] Right _ -> return ()@@ -400,7 +394,7 @@ Nothing -> do registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $ case kw of- Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword `" <> tkw <> "'"+ Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’" Nothing -> "unexpected parameter" return sexpr
+ src/Parser/Shell.hs view
@@ -0,0 +1,78 @@+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+ , singleQuotedString+ , 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++ singleQuotedString :: TestParser (Expr Text)+ singleQuotedString = do+ Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'')++ 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
src/Parser/Statement.hs view
@@ -21,13 +21,14 @@ import Network (Network, Node) import Parser.Core import Parser.Expr+import Parser.Shell import Process (Process) import Script.Expr import Script.Expr.Class import Test import Util -letStatement :: TestParser (Expr TestBlock)+letStatement :: TestParser (Expr (TestBlock ())) letStatement = do line <- getSourceLine indent <- L.indentLevel@@ -44,7 +45,7 @@ body <- testBlock indent return $ Let line tname e body -forStatement :: TestParser (Expr TestBlock)+forStatement :: TestParser (Expr (TestBlock ())) forStatement = do ref <- L.indentLevel wsymbol "for"@@ -69,7 +70,52 @@ <$> (unpack <$> e) <*> LambdaAbstraction tname body -exprStatement :: TestParser (Expr TestBlock)+shellStatement :: TestParser (Expr (TestBlock ()))+shellStatement = do+ ref <- L.indentLevel+ wsymbol "shell"+ parseParams ref Nothing Nothing++ where+ parseParamKeyword kw prev = do+ off <- stateOffset <$> getParserState+ wsymbol kw+ when (isJust prev) $ do+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $+ "unexpected parameter with keyword ‘" <> kw <> "’"++ parseParams ref mbpname mbnode = choice+ [ do+ parseParamKeyword "as" mbpname+ pname <- newVarName+ parseParams ref (Just pname) mbnode++ , do+ parseParamKeyword "on" mbnode+ node <- typedExpr+ parseParams ref mbpname (Just node)++ , do+ off <- stateOffset <$> getParserState+ symbol ":"+ node <- case mbnode of+ Just node -> return node+ Nothing -> do+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $+ "missing parameter with keyword ‘on’"+ return $ Undefined ""++ void eol+ void $ L.indentGuard scn GT ref+ script <- shellScript+ cont <- testBlock ref+ let expr | Just pname <- mbpname = LambdaAbstraction pname cont+ | otherwise = const <$> cont+ return $ TestBlockStep EmptyTestBlock <$>+ (SpawnShell mbpname <$> node <*> script <*> expr)+ ]++exprStatement :: TestParser (Expr (TestBlock ())) exprStatement = do ref <- L.indentLevel off <- stateOffset <$> getParserState@@ -79,11 +125,11 @@ , unifyExpr off Proxy expr ] where- continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr TestBlock)+ continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr (TestBlock ())) continuePartial off ref expr = do symbol ":" void eol- (fun :: Expr (FunctionType TestBlock)) <- unifyExpr off Proxy expr+ (fun :: Expr (FunctionType (TestBlock ()))) <- unifyExpr off Proxy expr scn indent <- L.indentGuard scn GT ref blockOf indent $ do@@ -229,10 +275,10 @@ cmdLine :: CommandDef SourceLine cmdLine = param "" -newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock }+newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } instance ExprType a => ParamType (InnerBlock a) where- type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr TestBlock )+ type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr (TestBlock ()) ) parseParam _ = mzero showParamType _ = "<code block>" paramExpr ( vars, expr ) = fmap InnerBlock $ helper vars $ const <$> expr@@ -244,13 +290,13 @@ combine f (x : xs) = f x xs combine _ [] = error "inner block parameter count mismatch" -innerBlock :: CommandDef TestBlock+innerBlock :: CommandDef (TestBlock ()) innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun -innerBlockFun :: ExprType a => CommandDef (a -> TestBlock)+innerBlockFun :: ExprType a => CommandDef (a -> TestBlock ()) innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList -innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock)+innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock ()) innerBlockFunList = fromInnerBlock <$> param "" newtype ExprParam a = ExprParam { fromExprParam :: a }@@ -265,7 +311,7 @@ showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" paramExpr = fmap ExprParam -command :: String -> CommandDef TestStep -> TestParser (Expr TestBlock)+command :: String -> CommandDef (TestStep ()) -> TestParser (Expr (TestBlock ())) command name (CommandDef types ctor) = do indent <- L.indentLevel line <- getSourceLine@@ -273,7 +319,7 @@ localState $ do restOfLine indent [] line $ map (fmap $ \(SomeParam p@(_ :: Proxy p) Proxy) -> SomeParam p $ Nothing @(ParamRep p)) types where- restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr TestBlock)+ restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr (TestBlock ())) restOfLine cmdi partials line params = choice [do void $ lookAhead eol let definedVariables = mconcat $ map (someParamVars . snd) params@@ -290,7 +336,7 @@ , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p ] (_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x- return $ (TestBlock . (: [])) <$> ctor iparams+ return $ (TestBlockStep EmptyTestBlock) <$> ctor iparams ,do symbol ":" scn@@ -300,7 +346,7 @@ ,do tryParams cmdi partials line [] params ] - restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr TestBlock)+ restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr (TestBlock ())) restOfParts cmdi [] = testBlock cmdi restOfParts cmdi partials@((partIndent, params) : rest) = do scn@@ -326,7 +372,7 @@ ] tryParams _ _ _ _ [] = mzero -testLocal :: TestParser (Expr TestBlock)+testLocal :: TestParser (Expr (TestBlock ())) testLocal = do ref <- L.indentLevel wsymbol "local"@@ -336,7 +382,7 @@ indent <- L.indentGuard scn GT ref localState $ testBlock indent -testWith :: TestParser (Expr TestBlock)+testWith :: TestParser (Expr (TestBlock ())) testWith = do ref <- L.indentLevel wsymbol "with"@@ -362,25 +408,26 @@ modify $ \s -> s { testContext = ctx } testBlock indent -testSubnet :: TestParser (Expr TestBlock)+testSubnet :: TestParser (Expr (TestBlock ())) testSubnet = command "subnet" $ Subnet <$> param "" <*> (fromExprParam <$> paramOrContext "of") <*> innerBlockFun -testNode :: TestParser (Expr TestBlock)+testNode :: TestParser (Expr (TestBlock ())) testNode = command "node" $ DeclNode <$> param "" <*> (fromExprParam <$> paramOrContext "on") <*> innerBlockFun -testSpawn :: TestParser (Expr TestBlock)+testSpawn :: TestParser (Expr (TestBlock ())) testSpawn = command "spawn" $ Spawn <$> param "as" <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on")+ <*> (maybe [] fromExprParam <$> param "args") <*> innerBlockFun -testExpect :: TestParser (Expr TestBlock)+testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect <$> cmdLine <*> (fromExprParam <$> paramOrContext "from")@@ -388,47 +435,36 @@ <*> param "capture" <*> innerBlockFunList -testDisconnectNode :: TestParser (Expr TestBlock)+testDisconnectNode :: TestParser (Expr (TestBlock ())) testDisconnectNode = command "disconnect_node" $ DisconnectNode <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectNodes :: TestParser (Expr TestBlock)+testDisconnectNodes :: TestParser (Expr (TestBlock ())) testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectUpstream :: TestParser (Expr TestBlock)+testDisconnectUpstream :: TestParser (Expr (TestBlock ())) testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testPacketLoss :: TestParser (Expr TestBlock)+testPacketLoss :: TestParser (Expr (TestBlock ())) testPacketLoss = command "packet_loss" $ PacketLoss <$> (fromExprParam <$> paramOrContext "") <*> (fromExprParam <$> paramOrContext "on") <*> innerBlock -testBlock :: Pos -> TestParser (Expr TestBlock)+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 :: TestParser (Expr (TestBlock ())) testStep = choice [ letStatement , forStatement+ , shellStatement , testLocal , testWith , testSubnet
src/Process.hs view
@@ -23,6 +23,7 @@ import qualified Data.Text.IO as T import System.Directory+import System.Environment import System.Exit import System.FilePath import System.IO@@ -39,7 +40,7 @@ data Process = Process { procName :: ProcName- , procHandle :: ProcessHandle+ , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode ) , procStdin :: Handle , procOutput :: TVar [Text] , procKillWith :: Maybe Signal@@ -104,26 +105,27 @@ 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", "." ) ]+ , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv } pout <- liftIO $ newTVarIO [] 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 +141,14 @@ 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
src/Run.hs view
@@ -33,6 +33,7 @@ import Process import Run.Monad import Script.Expr+import Script.Shell import Test import Test.Builtins @@ -72,7 +73,7 @@ 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@@ -111,15 +112,16 @@ evalGlobalDefs exprs = fix $ \gdefs -> builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs) -evalBlock :: TestBlock -> TestRun ()-evalBlock (TestBlock steps) = forM_ steps $ \case+evalBlock :: TestBlock () -> TestRun ()+evalBlock EmptyTestBlock = return ()+evalBlock (TestBlockStep prev step) = evalBlock prev >> case step of Subnet name parent inner -> do withSubnet parent (Just name) $ evalBlock . inner DeclNode name net inner -> do withNode net (Left name) $ evalBlock . 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@@ -128,7 +130,15 @@ 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 $ evalBlock . inner++ 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 Send p line -> do outProc OutputChildStdin p line
src/Run/Monad.hs view
@@ -109,10 +109,10 @@ 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 ()
src/Script/Expr.hs view
@@ -23,7 +23,8 @@ module Script.Var, - Regex(RegexPart, RegexString), regexMatch,+ Regex(RegexPart, RegexString),+ regexCompile, regexMatch, ) where import Control.Monad@@ -34,6 +35,8 @@ import Data.List import Data.Map (Map) import Data.Map qualified as M+import Data.Maybe+import Data.Scientific import Data.String import Data.Text (Text) import Data.Text qualified as T@@ -424,6 +427,12 @@ instance ExprType Regex where textExprType _ = T.pack "regex" textExprValue _ = T.pack "<regex>"++ exprExpansionConvFrom = listToMaybe $ catMaybes+ [ cast (RegexString)+ , cast (RegexString . T.pack . show @Integer)+ , cast (RegexString . T.pack . show @Scientific)+ ] regexCompile :: Text -> Either String Regex regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $
src/Script/Expr/Class.hs view
@@ -5,6 +5,7 @@ ExprEnumerator(..), ) where +import Data.Maybe import Data.Scientific import Data.Text (Text) import Data.Text qualified as T@@ -18,6 +19,12 @@ recordMembers :: [(Text, RecordSelector a)] recordMembers = [] + exprExpansionConvTo :: ExprType b => Maybe (a -> b)+ exprExpansionConvTo = Nothing++ exprExpansionConvFrom :: ExprType b => Maybe (b -> a)+ exprExpansionConvFrom = Nothing+ exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a) exprListUnpacker _ = Nothing @@ -36,11 +43,19 @@ textExprType _ = T.pack "integer" textExprValue x = T.pack (show x) + exprExpansionConvTo = listToMaybe $ catMaybes+ [ cast (T.pack . show :: Integer -> Text)+ ]+ exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo instance ExprType Scientific where textExprType _ = T.pack "number" textExprValue x = T.pack (show x)++ exprExpansionConvTo = listToMaybe $ catMaybes+ [ cast (T.pack . show :: Scientific -> Text)+ ] instance ExprType Bool where textExprType _ = T.pack "bool"
+ src/Script/Shell.hs view
@@ -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
src/Test.hs view
@@ -6,33 +6,45 @@ import Data.Scientific import Data.Text (Text)+import Data.Typeable import Network import Process import Script.Expr+import Script.Shell data Test = Test { testName :: Text- , testSteps :: Expr TestBlock+ , testSteps :: Expr (TestBlock ()) } -newtype TestBlock = TestBlock [ TestStep ]- deriving (Semigroup, Monoid)+data TestBlock a where+ EmptyTestBlock :: TestBlock ()+ TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a -data TestStep- = Subnet (TypedVarName Network) Network (Network -> TestBlock)- | DeclNode (TypedVarName Node) Network (Node -> TestBlock)- | Spawn (TypedVarName Process) (Either Network Node) (Process -> TestBlock)- | Send Process Text- | Expect SourceLine Process (Traced Regex) [ TypedVarName Text ] ([ Text ] -> TestBlock)- | Flush Process (Maybe Regex)- | Guard SourceLine EvalTrace Bool- | DisconnectNode Node TestBlock- | DisconnectNodes Network TestBlock- | DisconnectUpstream Network TestBlock- | PacketLoss Scientific Node TestBlock- | Wait+instance Semigroup (TestBlock ()) where+ EmptyTestBlock <> block = block+ block <> EmptyTestBlock = block+ block <> TestBlockStep block' step = TestBlockStep (block <> block') step -instance ExprType TestBlock where+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 -> [ Text ] -> (Process -> TestBlock a) -> TestStep a+ SpawnShell :: Maybe (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 ()+ 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+ Wait :: TestStep ()++instance Typeable a => ExprType (TestBlock a) where textExprType _ = "test block" textExprValue _ = "<test block>"
src/Test/Builtins.hs view
@@ -33,7 +33,7 @@ builtinSend :: SomeVarValue builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $- \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ]+ \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing) where atypes = [ ( Just "to", SomeArgumentType (ContextDefault @Process) )@@ -42,7 +42,7 @@ builtinFlush :: SomeVarValue builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $- \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ]+ \_ args -> TestBlockStep EmptyTestBlock $ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) where atypes = [ ( Just "from", SomeArgumentType (ContextDefault @Process) )@@ -51,7 +51,7 @@ builtinGuard :: SomeVarValue builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $- \sline args -> TestBlock [ Guard sline (getArgVars args Nothing) (getArg args Nothing) ]+ \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing) builtinWait :: SomeVarValue-builtinWait = someConstValue $ TestBlock [ Wait ]+builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait
+ src/TestMode.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE CPP #-}++module TestMode (+ testMode,+) where++import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State++import Data.Bifunctor+import Data.List+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as T++import System.IO.Error++import Text.Megaparsec.Error+import Text.Megaparsec.Pos++import Output+import Parser+import Run+import Script.Expr+import Script.Module+import Test+++data TestModeInput = TestModeInput+ { tmiOutput :: Output+ , tmiParams :: [ Text ]+ }++data TestModeState = TestModeState+ { tmsModules :: [ Module ]+ , tmsGlobals :: GlobalDefs+ }++initTestModeState :: TestModeState+initTestModeState = TestModeState+ { tmsModules = mempty+ , tmsGlobals = mempty+ }++testMode :: IO ()+testMode = do+ out <- startOutput OutputStyleTest False+ let testLoop = getLineMb >>= \case+ Just line -> do+ case T.words line of+ cname : params+ | Just (CommandM cmd) <- lookup cname commands -> do+ runReaderT cmd $ TestModeInput out params+ | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'"+ [] -> return ()+ testLoop++ Nothing -> return ()++ runExceptT (evalStateT testLoop initTestModeState) >>= \case+ Left err -> flip runReaderT out $ outLine OutputError Nothing $ T.pack err+ Right () -> return ()++getLineMb :: MonadIO m => m (Maybe Text)+getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e)++cmdOut :: Text -> Command+cmdOut line = do+ out <- asks tmiOutput+ flip runReaderT out $ outLine OutputTestRaw Nothing line+++newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a)+ deriving+ ( Functor, Applicative, Monad, MonadIO+ , MonadReader TestModeInput, MonadState TestModeState, MonadError String+ )++instance MonadFail CommandM where+ fail = throwError++type Command = CommandM ()++commands :: [ ( Text, Command ) ]+commands =+ [ ( "load", cmdLoad )+ , ( "run", cmdRun )+ ]++cmdLoad :: Command+cmdLoad = do+ [ path ] <- asks tmiParams+ liftIO (parseTestFiles [ T.unpack path ]) >>= \case+ Right ( modules, allModules ) -> do+ let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules+ modify $ \s -> s+ { tmsModules = modules+ , tmsGlobals = globalDefs+ }+ cmdOut "load-done"++ Left (ModuleNotFound moduleName) -> do+ cmdOut $ "load-failed module-not-found" <> textModuleName moduleName+ Left (FileNotFound notFoundPath) -> do+ cmdOut $ "load-failed file-not-found " <> T.pack notFoundPath+ Left (ImportModuleError bundle) -> do+#if MIN_VERSION_megaparsec(9,7,0)+ mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle+#endif+ cmdOut $ "load-failed parse-error"+ where+ showParseError _ SourcePos {..} _ = concat+ [ "parse-error"+ , " ", sourceName+ , ":", show $ unPos sourceLine+ , ":", show $ unPos sourceColumn+ ]++cmdRun :: Command+cmdRun = do+ [ name ] <- asks tmiParams+ TestModeState {..} <- get+ 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+ True -> cmdOut "run-done"+ False -> cmdOut "run-failed"