erebos-tester 0.2.2 → 0.2.3
raw patch · 13 files changed
+176/−53 lines, 13 files
Files
- CHANGELOG.md +7/−0
- README.md +10/−4
- erebos-tester.cabal +2/−1
- src/Main.hs +17/−4
- src/Network.hs +1/−0
- src/Output.hs +13/−8
- src/Parser.hs +43/−12
- src/Parser/Core.hs +7/−6
- src/Parser/Expr.hs +11/−5
- src/Parser/Statement.hs +14/−8
- src/Run.hs +6/−1
- src/Test.hs +32/−4
- src/Test/Builtins.hs +13/−0
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Revision history for erebos-tester +## 0.2.3 -- 2024-08-10++* Added `network` member to the `node` object+* Use colors by default only on terminal, add `--color`/`--no-color` options to select manually.+* Accept module name declaration+* Report multiple parsing errors in single pass+ ## 0.2.2 -- 2024-05-17 * Fix unshare failing with newer compilers
README.md view
@@ -160,7 +160,7 @@ ``` let str = "." let re1 = /./-let re2 = "$str$re1" # match '.' followed by any character+let re2 = /$str$re1/ # match '.' followed by any character ``` #### boolean@@ -173,19 +173,25 @@ #### node -Represents network node, created by `node` command and used by `spawn` or network configuration commands.+Represents network node, created by `node` command or implicitly by `spawn`,+and used by `spawn` or network configuration commands. Members: -`ip`: string representation of node's IP address.+`ip`+: String representation of node's IP address. +`network`+: The network which the node belogs to.+ #### process Represents running process. Created by `spawn`, used by `send` and `expect` commands. Members: -`node`: node on which the process is running+`node`+: Node on which the process is running. #### list
erebos-tester.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: erebos-tester-version: 0.2.2+version: 0.2.3 synopsis: Test framework with virtual network using Linux namespaces description: This framework is intended mainly for networking libraries/applications and@@ -87,6 +87,7 @@ Run Run.Monad Test+ Test.Builtins Util Version Version.Git
src/Main.hs view
@@ -14,6 +14,8 @@ import System.FilePath import System.FilePath.Glob import System.IO+import System.Posix.Terminal+import System.Posix.Types import Config import Output@@ -28,6 +30,7 @@ { optTest :: TestOptions , optRepeat :: Int , optVerbose :: Bool+ , optColor :: Maybe Bool , optShowHelp :: Bool , optShowVersion :: Bool }@@ -37,6 +40,7 @@ { optTest = defaultTestOptions , optRepeat = 1 , optVerbose = False+ , optColor = Nothing , optShowHelp = False , optShowVersion = False }@@ -52,6 +56,12 @@ , Option ['v'] ["verbose"] (NoArg (\opts -> opts { optVerbose = True })) "show output of processes and successful tests"+ , Option [] [ "color" ]+ (NoArg (\opts -> opts { optColor = Just True }))+ "always use colors for output (default when stdout is tty)"+ , Option [] [ "no-color" ]+ (NoArg (\opts -> opts { optColor = Just False }))+ "never use colors for output (default when stdout is not a tty)" , Option ['t'] ["timeout"] (ReqArg (\str -> to $ \opts -> case readMaybe str of Just timeout -> opts { optTimeout = timeout }@@ -133,13 +143,16 @@ when (null files) $ fail $ "No test files" - out <- startOutput $ optVerbose opts+ useColor <- case optColor opts of+ Just use -> return use+ Nothing -> queryTerminal (Fd 1)+ out <- startOutput (optVerbose opts) useColor tests <- forM files $ \(path, mbTestName) -> do- fileTests <- parseTestFile path+ Module { .. } <- parseTestFile path return $ case mbTestName of- Nothing -> fileTests- Just name -> filter ((==name) . testName) fileTests+ Nothing -> moduleTests+ Just name -> filter ((==name) . testName) moduleTests ok <- allM (runTest out $ optTest opts) $ concat $ replicate (optRepeat opts) $ concat tests
src/Network.hs view
@@ -110,6 +110,7 @@ recordMembers = map (first T.pack) [ ("ip", RecordSelector $ textIpAddress . nodeIp)+ , ("network", RecordSelector $ nodeNetwork) ]
src/Output.hs view
@@ -27,6 +27,7 @@ data OutputConfig = OutputConfig { outVerbose :: Bool+ , outUseColor :: Bool } data OutputState = OutputState@@ -50,10 +51,10 @@ instance MonadIO m => MonadOutput (ReaderT Output m) where getOutput = ask -startOutput :: Bool -> IO Output-startOutput verbose = Output+startOutput :: Bool -> Bool -> IO Output+startOutput outVerbose outUseColor = Output <$> newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }- <*> pure OutputConfig { outVerbose = verbose }+ <*> pure OutputConfig { .. } outColor :: OutputType -> Text outColor OutputChildStdout = T.pack "0"@@ -97,11 +98,15 @@ outLine otype prompt line = ioWithOutput $ \out -> when (outVerbose (outConfig out) || printWhenQuiet otype) $ do withMVar (outState out) $ \st -> do- outPrint st $ TL.fromChunks- [ T.pack "\ESC[", outColor otype, T.pack "m"- , maybe "" (<> outSign otype <> outArr otype <> " ") prompt- , line- , T.pack "\ESC[0m"+ outPrint st $ TL.fromChunks $ concat+ [ if outUseColor (outConfig out)+ then [ T.pack "\ESC[", outColor otype, T.pack "m" ]+ else []+ , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]+ , [ line ]+ , if outUseColor (outConfig out)+ then [ T.pack "\ESC[0m" ]+ else [] ] outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text)
src/Parser.hs view
@@ -5,38 +5,69 @@ ) where import Control.Monad.State+import Control.Monad.Writer -import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.IO as TL+import Data.Maybe+import Data.Set qualified as S+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.IO qualified as TL import Text.Megaparsec hiding (State)+import Text.Megaparsec.Char +import System.Directory import System.Exit+import System.FilePath import Parser.Core+import Parser.Expr import Parser.Statement import Test+import Test.Builtins -parseTestDefinition :: TestParser Test-parseTestDefinition = label "test definition" $ toplevel $ do+parseTestDefinition :: TestParser ()+parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do block (\name steps -> return $ Test name $ concat steps) header testStep where header = do wsymbol "test" lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') -parseTestDefinitions :: TestParser [Test]-parseTestDefinitions = do- tests <- many parseTestDefinition+parseTestModule :: FilePath -> TestParser Module+parseTestModule absPath = do+ moduleName <- choice+ [ label "module declaration" $ do+ wsymbol "module"+ off <- stateOffset <$> getParserState+ x <- identifier+ name <- (x:) <$> many (symbol "." >> identifier)+ when (or (zipWith (/=) (reverse name) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $+ "module name does not match file path"+ eol >> scn+ return name+ , do+ return $ [ T.pack $ takeBaseName absPath ]+ ]+ (_, toplevels) <- listen $ many $ choice+ [ parseTestDefinition+ ]+ let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; {- _ -> Nothing -}) toplevels eof- return tests+ return Module { .. } -parseTestFile :: FilePath -> IO [Test]+parseTestFile :: FilePath -> IO Module parseTestFile path = do content <- TL.readFile path+ absPath <- makeAbsolute path let initState = TestParserState- { testVars = []+ { testVars = concat+ [ map (fmap someVarValueType) builtins+ ] , testContext = SomeExpr RootNetwork }- case evalState (runParserT parseTestDefinitions path content) initState of+ (res, _) = flip evalState initState $ runWriterT $ runParserT (parseTestModule absPath) path content++ case res of Left err -> putStr (errorBundlePretty err) >> exitFailure- Right tests -> return tests+ Right testModule -> return testModule
src/Parser/Core.hs view
@@ -2,6 +2,7 @@ import Control.Monad import Control.Monad.State+import Control.Monad.Writer import Data.Text (Text) import qualified Data.Text.Lazy as TL@@ -15,18 +16,18 @@ import Network () import Test -type TestParser = ParsecT Void TestStream (State TestParserState)+type TestParser = ParsecT Void TestStream (WriterT [ Toplevel ] (State TestParserState)) type TestStream = TL.Text +data Toplevel+ = ToplevelTest Test+ data TestParserState = TestParserState { testVars :: [(VarName, SomeExprType)] , testContext :: SomeExpr } -data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)-data SomeExprType = forall a. ExprType a => SomeExprType (Proxy a)- someEmptyVar :: SomeExprType -> SomeVarValue someEmptyVar (SomeExprType (Proxy :: Proxy a)) = SomeVarValue $ emptyVarValue @a @@ -68,8 +69,8 @@ put s return x -toplevel :: TestParser a -> TestParser a-toplevel = L.nonIndented scn+toplevel :: (a -> Toplevel) -> TestParser a -> TestParser ()+toplevel f = tell . (: []) . f <=< L.nonIndented scn block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c block merge header item = L.indentBlock scn $ do
src/Parser/Expr.hs view
@@ -1,4 +1,6 @@ module Parser.Expr (+ identifier,+ varName, newVarName, addVarName,@@ -46,7 +48,7 @@ addVarName :: forall a. ExprType a => Int -> TypedVarName a -> TestParser () addVarName off (TypedVarName name) = do gets (lookup name . testVars) >>= \case- Just _ -> parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $+ Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.pack "variable '" <> textVarName name <> T.pack "' already exists" Nothing -> return () modify $ \s -> s { testVars = (name, SomeExprType @a Proxy) : testVars s }@@ -65,8 +67,10 @@ stringExpansion tname conv = do off <- stateOffset <$> getParserState SomeExpr e <- someExpansion- let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat- [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ]+ let err = do+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ]+ return $ Pure emptyVarValue maybe err return $ listToMaybe $ catMaybes $ conv e @@ -310,6 +314,8 @@ typedExpr = do off <- stateOffset <$> getParserState SomeExpr e <- someExpr- let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat- [ T.pack "expected '", textExprType @a Proxy, T.pack "', expression has type '", textExprType e, T.pack "'" ]+ let err = do+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat+ [ T.pack "expected '", textExprType @a Proxy, T.pack "', expression has type '", textExprType e, T.pack "'" ]+ return $ Pure emptyVarValue maybe err return $ cast e
src/Parser/Statement.hs view
@@ -75,6 +75,11 @@ body <- testBlock indent return [For line tname (unpack <$> e) body] +exprStatement :: TestParser [ TestStep ]+exprStatement = do+ expr <- typedExpr+ return [ ExprStatement expr ]+ class (Typeable a, Typeable (ParamRep a)) => ParamType a where type ParamRep a :: Type type ParamRep a = a@@ -116,7 +121,13 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where type ParamRep (Either a b) = Either (ParamRep a) (ParamRep b)- parseParam _ = try (Left <$> parseParam @a Proxy) <|> (Right <$> parseParam @b Proxy)+ parseParam _ = try' (Left <$> parseParam @a Proxy) <|> (Right <$> parseParam @b Proxy)+ where+ try' act = try $ do+ x <- act+ (stateParseErrors <$> getParserState) >>= \case+ [] -> return x+ (_ : _) -> fail "" showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy paramFromSomeExpr _ se = (Left <$> paramFromSomeExpr @a Proxy se) <|> (Right <$> paramFromSomeExpr @b Proxy se) @@ -255,7 +266,7 @@ notAllowed <- flip allM expected $ \case SomeExprType (Proxy :: Proxy a) | Just (Refl :: ctxe :~: a) <- eqT -> return False _ -> return True- when notAllowed $ parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $+ when notAllowed $ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "expected " <> T.intercalate ", " (map (("'"<>) . (<>"'") . textSomeExprType) expected) <> ", expression has type '" <> textExprType @ctxe Proxy <> "'" symbol ":"@@ -329,11 +340,6 @@ <*> innerBlock -testWait :: TestParser [TestStep]-testWait = do- wsymbol "wait"- return [Wait]- testBlock :: Pos -> TestParser [TestStep] testBlock indent = concat <$> go where@@ -363,5 +369,5 @@ , testDisconnectNodes , testDisconnectUpstream , testPacketLoss- , testWait+ , exprStatement ]
src/Run.hs view
@@ -32,6 +32,7 @@ import Process import Run.Monad import Test+import Test.Builtins runTest :: Output -> TestOptions -> Test -> IO Bool runTest out opts test = do@@ -60,7 +61,7 @@ } tstate = TestState { tsNetwork = error "network not initialized"- , tsVars = []+ , tsVars = builtins , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty@@ -120,6 +121,10 @@ value <- eval expr forM_ value $ \i -> do withVar name i $ evalSteps inner++ ExprStatement expr -> do+ TestBlock steps <- eval expr+ evalSteps steps Subnet name@(TypedVarName vname) parentExpr inner -> do parent <- eval parentExpr
src/Test.hs view
@@ -1,12 +1,14 @@ module Test (+ Module(..), Test(..), TestStep(..),+ TestBlock(..), SourceLine(..), MonadEval(..), VarName(..), TypedVarName(..), textVarName, unpackVarName,- ExprType(..),- SomeVarValue(..), fromSomeVarValue, textSomeVarValue,+ ExprType(..), SomeExpr(..), SomeExprType(..), someExprType,+ SomeVarValue(..), fromSomeVarValue, textSomeVarValue, someVarValueType, RecordSelector(..), ExprListUnpacker(..), ExprEnumerator(..),@@ -30,13 +32,21 @@ import {-# SOURCE #-} Process import Util +data Module = Module+ { moduleName :: [ Text ]+ , moduleTests :: [ Test ]+ }+ data Test = Test { testName :: Text , testSteps :: [TestStep] } +newtype TestBlock = TestBlock [ TestStep ]+ data TestStep = forall a. ExprType a => Let SourceLine (TypedVarName a) (Expr a) [TestStep] | forall a. ExprType a => For SourceLine (TypedVarName a) (Expr [a]) [TestStep]+ | ExprStatement (Expr TestBlock) | Subnet (TypedVarName Network) (Expr Network) [TestStep] | DeclNode (TypedVarName Node) (Expr Network) [TestStep] | Spawn (TypedVarName Process) (Either (Expr Network) (Expr Node)) [TestStep]@@ -120,16 +130,34 @@ exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) -data SomeVarValue = forall a. ExprType a => SomeVarValue a+instance ExprType TestBlock where+ textExprType _ = "test block"+ textExprValue _ = "<test block>"+ emptyVarValue = TestBlock [] -data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) +data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)++data SomeExprType = forall a. ExprType a => SomeExprType (Proxy a)++someExprType :: SomeExpr -> SomeExprType+someExprType (SomeExpr (_ :: Expr a)) = SomeExprType (Proxy @a)+++data SomeVarValue = forall a. ExprType a => SomeVarValue a+ fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m a fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast value where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", textExprType (Just value) ] textSomeVarValue :: SomeVarValue -> Text textSomeVarValue (SomeVarValue value) = textExprValue value++someVarValueType :: SomeVarValue -> SomeExprType+someVarValueType (SomeVarValue (_ :: a)) = SomeExprType (Proxy @a)+++data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e)
+ src/Test/Builtins.hs view
@@ -0,0 +1,13 @@+module Test.Builtins (+ builtins,+) where++import Test++builtins :: [ ( VarName, SomeVarValue ) ]+builtins =+ [ ( VarName "wait", SomeVarValue builtinWait )+ ]++builtinWait :: TestBlock+builtinWait = TestBlock [ Wait ]