summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--README.md3
-rw-r--r--erebos-tester.cabal78
-rw-r--r--src/Main.hs10
-rw-r--r--src/Parser.hs30
-rw-r--r--src/Parser/Core.hs20
-rw-r--r--src/Run.hs6
-rw-r--r--src/Test.hs1
-rw-r--r--src/Test/Builtins.hs4
-rw-r--r--src/Wrapper.hs45
-rw-r--r--src/main.c81
10 files changed, 165 insertions, 113 deletions
diff --git a/README.md b/README.md
index 0cf5f21..f189df0 100644
--- a/README.md
+++ b/README.md
@@ -248,10 +248,11 @@ In that case the expect command has to have the `capture` clause with matching n
Results of the captures are then assigned to the newly created variables as strings.
```
-flush [from <proc>]
+flush [from <proc>] [matching <regex>]
```
Flush memory of `<proc>` output, so no following `expect` command will match anything produced up to this point.
+If the `matching` clause is used, discard only output lines matching `<regex>`.
```
guard <expr>
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index c3a49e6..f900823 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -30,10 +30,12 @@ source-repository head
type: git
location: git://erebosprotocol.net/tester
-common common
+executable erebos-tester
ghc-options:
-Wall
-fdefer-typed-holes
+ -threaded
+ -no-hs-main
if flag(ci)
ghc-options:
@@ -41,36 +43,6 @@ common common
-- sometimes needed for backward/forward compatibility:
-Wno-error=unused-imports
- build-depends:
- base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 },
-
-executable erebos-tester
- import: common
- ghc-options:
- -- disable interval timer to avoid spawing thread that breaks unshare(CLONE_NEWUSER)
- -with-rtsopts=-V0
- if impl(ghc >= 9.8)
- ghc-options:
- -- no multithreading is allowed for unshare(CLONE_NEWUSER)
- -single-threaded
-
- main-is: Wrapper.hs
- -- other-modules:
- -- other-extensions:
- build-depends:
- directory >=1.3 && <1.4,
- filepath ^>= { 1.4.2.1, 1.5.2 },
- linux-namespaces^>=0.1.3,
- process ^>=1.6.9,
- unix >=2.7 && <2.9,
- hs-source-dirs: src
- default-language: Haskell2010
-
-executable erebos-tester-core
- import: common
- ghc-options:
- -threaded
-
main-is: Main.hs
other-modules: Config
@@ -94,25 +66,33 @@ executable erebos-tester-core
autogen-modules: Paths_erebos_tester
- other-extensions: TemplateHaskell
- default-extensions: ExistentialQuantification
- FlexibleContexts
- FlexibleInstances
- GADTs
- GeneralizedNewtypeDeriving
- ImportQualifiedPost
- LambdaCase
- MultiParamTypeClasses
- MultiWayIf
- OverloadedStrings
- RankNTypes
- RecordWildCards
- ScopedTypeVariables
- TupleSections
- TypeApplications
- TypeFamilies
- TypeOperators
+ c-sources:
+ src/main.c
+
+ other-extensions:
+ TemplateHaskell
+ default-extensions:
+ DeriveTraversable
+ ExistentialQuantification
+ FlexibleContexts
+ FlexibleInstances
+ GADTs
+ GeneralizedNewtypeDeriving
+ ImportQualifiedPost
+ LambdaCase
+ MultiParamTypeClasses
+ MultiWayIf
+ OverloadedStrings
+ RankNTypes
+ RecordWildCards
+ ScopedTypeVariables
+ TupleSections
+ TypeApplications
+ TypeFamilies
+ TypeOperators
+
build-depends:
+ base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 },
bytestring ^>= { 0.10, 0.11, 0.12 },
containers ^>= { 0.6.2.1, 0.7 },
directory ^>=1.3.6.0,
diff --git a/src/Main.hs b/src/Main.hs
index 61afbd8..01bb766 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -149,11 +149,15 @@ main = do
out <- startOutput (optVerbose opts) useColor
tests <- forM files $ \(path, mbTestName) -> do
- Module { .. } <- parseTestFile path
- return $ case mbTestName of
+ Module {..} <- parseTestFile path
+ return $ map ( , moduleDefinitions ) $ case mbTestName of
Nothing -> moduleTests
Just name -> filter ((==name) . testName) moduleTests
- ok <- allM (runTest out $ optTest opts) $
+ ok <- allM (uncurry $ runTest out $ optTest opts) $
concat $ replicate (optRepeat opts) $ concat tests
when (not ok) exitFailure
+
+foreign export ccall testerMain :: IO ()
+testerMain :: IO ()
+testerMain = main
diff --git a/src/Parser.hs b/src/Parser.hs
index 6d6809b..e63f854 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -6,7 +6,6 @@ module Parser (
import Control.Monad
import Control.Monad.State
-import Control.Monad.Writer
import Data.Map qualified as M
import Data.Maybe
@@ -17,6 +16,7 @@ import Data.Text.Lazy.IO qualified as TL
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer qualified as L
import System.Directory
import System.Exit
@@ -28,13 +28,29 @@ import Parser.Statement
import Test
import Test.Builtins
-parseTestDefinition :: TestParser ()
+parseTestDefinition :: TestParser Toplevel
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") (/=':')
+parseDefinition :: TestParser Toplevel
+parseDefinition = label "symbol definition" $ toplevel ToplevelDefinition $ do
+ def <- localState $ L.indentBlock scn $ do
+ wsymbol "def"
+ name <- varName
+ choice
+ [ do
+ symbol ":"
+ let finish steps = do
+ return $ ( name, ) $ SomeVarValue mempty $ \_ _ -> TestBlock $
+ concat steps
+ return $ L.IndentSome Nothing finish testStep
+ ]
+ modify $ \s -> s { testVars = fmap someVarValueType def : testVars s }
+ return def
+
parseTestModule :: FilePath -> TestParser Module
parseTestModule absPath = do
moduleName <- choice
@@ -51,12 +67,14 @@ parseTestModule absPath = do
, do
return $ [ T.pack $ takeBaseName absPath ]
]
- (_, toplevels) <- listen $ many $ choice
+ toplevels <- many $ choice
[ parseTestDefinition
+ , parseDefinition
]
- let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; {- _ -> Nothing -}) toplevels
+ let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; _ -> Nothing) toplevels
+ moduleDefinitions = catMaybes $ map (\case ToplevelDefinition x -> Just x; _ -> Nothing) toplevels
eof
- return Module { .. }
+ return Module {..}
parseTestFile :: FilePath -> IO Module
parseTestFile path = do
@@ -70,7 +88,7 @@ parseTestFile path = do
, testNextTypeVar = 0
, testTypeUnif = M.empty
}
- (res, _) = runWriter $ flip (flip runParserT path) content $ flip evalStateT initState $ parseTestModule absPath
+ res = runTestParser path content initState $ parseTestModule absPath
case res of
Left err -> putStr (errorBundlePretty err) >> exitFailure
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index cb66529..10a572b 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -1,8 +1,9 @@
module Parser.Core where
+import Control.Applicative
import Control.Monad
+import Control.Monad.Identity
import Control.Monad.State
-import Control.Monad.Writer
import Data.Map (Map)
import Data.Map qualified as M
@@ -20,14 +21,25 @@ import qualified Text.Megaparsec.Char.Lexer as L
import Network ()
import Test
-type TestParser = StateT TestParserState (ParsecT Void TestStream (Writer [ Toplevel ]))
+newtype TestParser a = TestParser (StateT TestParserState (ParsecT Void TestStream Identity) a)
+ deriving
+ ( Functor, Applicative, Alternative, Monad
+ , MonadState TestParserState
+ , MonadPlus
+ , MonadFail
+ , MonadParsec Void TestStream
+ )
type TestStream = TL.Text
type TestParseError = ParseError TestStream Void
+runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> Either (ParseErrorBundle TestStream Void) a
+runTestParser path content initState (TestParser parser) = runIdentity . flip (flip runParserT path) content . flip evalStateT initState $ parser
+
data Toplevel
= ToplevelTest Test
+ | ToplevelDefinition ( VarName, SomeVarValue )
data TestParserState = TestParserState
{ testVars :: [ ( VarName, SomeExprType ) ]
@@ -191,8 +203,8 @@ localState inner = do
put s
return x
-toplevel :: (a -> Toplevel) -> TestParser a -> TestParser ()
-toplevel f = tell . (: []) . f <=< L.nonIndented scn
+toplevel :: (a -> Toplevel) -> TestParser a -> TestParser Toplevel
+toplevel f = return . f <=< L.nonIndented scn
block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c
block merge header item = L.indentBlock scn $ do
diff --git a/src/Run.hs b/src/Run.hs
index b67c287..1cb04bb 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -33,8 +33,8 @@ import Run.Monad
import Test
import Test.Builtins
-runTest :: Output -> TestOptions -> Test -> IO Bool
-runTest out opts test = do
+runTest :: Output -> TestOptions -> Test -> [ ( VarName, SomeVarValue ) ] -> IO Bool
+runTest out opts test variables = do
let testDir = optTestDir opts
when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e ->
if isDoesNotExistError e then return () else ioError e
@@ -60,7 +60,7 @@ runTest out opts test = do
}
tstate = TestState
{ tsNetwork = error "network not initialized"
- , tsVars = builtins
+ , tsVars = builtins ++ variables
, tsNodePacketLoss = M.empty
, tsDisconnectedUp = S.empty
, tsDisconnectedBridge = S.empty
diff --git a/src/Test.hs b/src/Test.hs
index 719e3e2..24a4c72 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -46,6 +46,7 @@ import Util
data Module = Module
{ moduleName :: [ Text ]
, moduleTests :: [ Test ]
+ , moduleDefinitions :: [ ( VarName, SomeVarValue ) ]
}
data Test = Test
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 6c6c2f0..9babb9e 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -37,11 +37,11 @@ builtinSend = SomeVarValue (FunctionArguments $ M.fromList atypes) $
builtinFlush :: SomeVarValue
builtinFlush = SomeVarValue (FunctionArguments $ M.fromList atypes) $
- \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args Nothing) ]
+ \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ]
where
atypes =
[ ( Just "from", SomeArgumentType (ContextDefault @Process) )
- , ( Nothing, SomeArgumentType (OptionalArgument @Regex) )
+ , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )
]
builtinGuard :: SomeVarValue
diff --git a/src/Wrapper.hs b/src/Wrapper.hs
deleted file mode 100644
index 544e37c..0000000
--- a/src/Wrapper.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Main where
-
-import Control.Monad
-
-import GHC.Environment
-
-import System.Directory
-import System.Environment
-import System.FilePath
-import System.Linux.Namespaces
-import System.Posix.Process
-import System.Posix.User
-import System.Process
-
-main :: IO ()
-main = do
- -- we must get uid/gid before unshare
- uid <- getEffectiveUserID
- gid <- getEffectiveGroupID
-
- unshare [User, Network, Mount]
- writeUserMappings Nothing [UserMapping 0 uid 1]
- writeGroupMappings Nothing [GroupMapping 0 gid 1] True
-
- -- needed for creating /run/netns
- callCommand "mount -t tmpfs tmpfs /run"
-
- epath <- takeDirectory <$> getExecutablePath -- directory containing executable
- fpath <- map takeDirectory . filter (any isPathSeparator) . take 1 <$> getFullArgs
- -- directory used for invocation, can differ from above for symlinked executable
-
- let dirs = concat
- [ [ epath ]
- , [ epath </> "../../../erebos-tester-core/build/erebos-tester-core" ]
- , fpath
- ]
-
- args <- getArgs
- mapM_ (\file -> executeFile file False args Nothing) =<<
- findExecutablesInDirectories dirs "erebos-tester-core"
- when (null fpath) $
- mapM_ (\file -> executeFile file False args Nothing) =<<
- findExecutables "erebos-tester-core"
-
- fail "core binary not found"
diff --git a/src/main.c b/src/main.c
new file mode 100644
index 0000000..98daf2c
--- /dev/null
+++ b/src/main.c
@@ -0,0 +1,81 @@
+#include "HsFFI.h"
+
+#if defined(__GLASGOW_HASKELL__)
+#include "Main_stub.h"
+#endif
+
+#include <errno.h>
+#include <fcntl.h>
+#include <sched.h>
+#include <stdbool.h>
+#include <stdio.h>
+#include <string.h>
+#include <sys/mount.h>
+#include <unistd.h>
+
+/*
+ * The unshare call with CLONE_NEWUSER needs to happen before starting
+ * additional threads, which means before initializing the Haskell RTS.
+ * To achieve that, replace Haskell main with a custom one here that does
+ * the unshare work and then executes the Haskell code.
+ */
+
+static bool writeProcSelfFile( const char * file, const char * data, size_t size )
+{
+ char path[ 256 ];
+ if( snprintf( path, sizeof( path ), "/proc/self/%s", file )
+ >= sizeof( path ) ){
+ fprintf( stderr, "buffer too small\n" );
+ return false;
+ }
+
+ int fd = open( path, O_WRONLY );
+ if( fd < 0 ){
+ fprintf( stderr, "failed to open %s: %s", path, strerror( errno ));
+ return false;
+ }
+
+ ssize_t written = write( fd, data, size );
+ if( written < 0 )
+ fprintf( stderr, "failed to write to %s: %s\n", path, strerror( errno ));
+
+ close( fd );
+ return written == size;
+}
+
+int main( int argc, char * argv[] )
+{
+ uid_t uid = geteuid();
+ gid_t gid = getegid();
+ unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS );
+
+ char buf[ 256 ];
+ int len;
+
+ len = snprintf( buf, sizeof( buf ), "%d %d %d\n", 0, uid, 1 );
+ if( len >= sizeof( buf ) ){
+ fprintf( stderr, "buffer too small\n" );
+ return 1;
+ }
+ if ( ! writeProcSelfFile( "uid_map", buf, len ) )
+ return 1;
+
+ if ( ! writeProcSelfFile( "setgroups", "deny\n", 5 ) )
+ return 1;
+
+ len = snprintf( buf, sizeof( buf ), "%d %d %d\n", 0, gid, 1 );
+ if( len >= sizeof( buf ) ){
+ fprintf( stderr, "buffer too small\n" );
+ return 1;
+ }
+ if ( ! writeProcSelfFile( "gid_map", buf, len ) )
+ return 1;
+
+ mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" );
+
+ hs_init( &argc, &argv );
+ testerMain();
+ hs_exit();
+
+ return 0;
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-14 04:04:41 +0000