diff options
54 files changed, 2603 insertions, 548 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index d7872ef..85027e3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,32 @@ # Revision history for erebos-tester +## 0.3.4 -- 2026-01-15 + +* Show call stack in error messages. +* Verbose output now includes test names, command and arguments for spawned processes, and marks flushed/ignored output lines. +* Added `ignore` builtin command. +* Added `timeout` argument for the `expect` command. +* Support zero as a timeout multiplier. +* Make host filesystems read-only for the test process (except for test dir). +* Implemented pipes and input/output redirection in shell scripts. +* Support for GHC up to 9.14. + +## 0.3.3 -- 2025-06-25 + +* Added optional `timeout` setting to config file +* Added `multiply_timeout` command +* Added `True` and `False` literals, and comparison operators for boolean values +* Added `--exclude` command-line option to exclude tests +* Execute shell commands in appropriate network namespace +* Show name of failed test in output + +## 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 @@ -56,14 +56,26 @@ cmake --build build 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 @@ -76,6 +88,7 @@ This is a YAML file with following fields: * `tool`: path to the test tool, which may be overridden by the `--tool` command-line option. * `tests`: glob pattern that expands to all the test script files that should be used. +* `timeout`: initial timeout for test steps like `expect`, given as `int` or `float`; defaults to `1` if not specified. Script language --------------- @@ -166,6 +179,7 @@ let re2 = /$str$re1/ # match '.' followed by any character #### boolean Result of comparison operators `==` and `/=`. +Values are `True` and `False`. #### network @@ -196,6 +210,9 @@ Members: `node` : Node on which the process is running. +`pid` +: PID of the corresponding system process, `0` if there is none. + #### asset Represents an asset (file or directory), which can be used during test execution. @@ -205,6 +222,10 @@ Members: `path` : Path to the asset valid during the test execution. +#### `Signal` + +Type representing unix signals sent to processes. Values are `SIGINT`, `SIGTERM`, etc. + #### list Lists are written using bracket notation: @@ -231,13 +252,15 @@ node <name> [on <network>] 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>] [killwith <signal>] ``` 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. +If the `killwith` clause is present, it is also sent the given `<signal>` at that point. When the process fails to terminate successfully within a timeout, the test fails. ``` @@ -246,7 +269,7 @@ send <string> to <process> Send line with `<string>` to the standard input of `<process>`. ``` -expect <regex> from <process> [capture <var1> [, <var2> ... ]] +expect <regex> from <process> [timeout <timeout>] [capture <var1> [, <var2> ... ]] ``` Check whether `<process>` produces line matching `<regex>` on standard output, and if this does not happen within current timeout, the test fails. Output lines produced before starting this command and not matched by some previous `expect` are accepted as well. @@ -259,6 +282,9 @@ The regular expression can contain capture groups – parts enclosed in parenthe In that case the expect command has to have the `capture` clause with matching number of variable names. Results of the captures are then assigned to the newly created variables as strings. +If the `timeout` clause is used, the current timeout value is multiplied by the given `<timeout>` for this `expect` call. +Timeout of zero can be used to expect a matching output line to have been already produced in the past. + ``` flush [from <proc>] [matching <regex>] ``` @@ -267,6 +293,15 @@ Flush memory of `<proc>` output, so no following `expect` command will match any If the `matching` clause is used, discard only output lines matching `<regex>`. ``` +ignore [from <proc>] [matching <regex>] +``` + +Ignore output lines from `<proc>` (or context process) that match the given +`<regex>` (or all lines if the `matching` clause is not used). Affects both +past and future output of the process; the effect lasts until the end of +the block. + +``` guard <expr> ``` @@ -322,12 +357,52 @@ with <expr>: Execute `<test block>` with `<expr>` as context. ``` +multiply_timeout by <multiplier> +``` + +Modify the timeout used for commands like `expect` by multiplying it with `<multiplier>`. +The effect lasts until the end of the block. + +``` wait ``` Wait for user input before continuing. Useful mostly for debugging or test development. +### Shell interpreter + +**Experimental feature**: Functionality is not fully implemented and behavior may change in incompatible ways between releases. + +Using the `shell` expression, it's possible to embed a shell script inside a test script. +The shell script is not passed to an external interpreter, but rather executed by the tester itself, +which allows the use of variables from the rest of the test script: + +``` +test: + node some_node + let x = "abc" + shell as sh on some_node: + echo $x > some_file + echo ${some_node.ip} >> some_file + cat some_file | sed 's/a/A/' > other_file +``` + +The syntax is intended to be generally similar to the classic Bourne shell, +however, only limited functionality is implemented so far (that includes executing commands, pipelines or input/output redirection). + +The general form of the `shell` expression is: + +``` +shell [as <name>] on <node>: + <shell commands> +``` + +Where `<node>` is the network node on which to run the script (it will be run in the network namespace of the node, and with working directory set to the node root), +and `<name>`, if given, is the name of the variable that will refer to the shell process (this can be used e.g. in the `expect` command to check the standard output of the script). +As with the `spawn` command, the resulting process is terminated at the end of the current scope. + + ### Functions When calling a function, parameters are usually passed using argument keywords @@ -453,9 +528,17 @@ test: 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. +The `my_asset.path` expression expands to a string containing path to the asset +that can be used by the spawned process `p`. The process should not try to +modify the file. + +Assets can be exported for use in other modules using the `export` keyword, +just like other definitions: + +``` +export asset my_asset: + path: ../path/to/file +``` Optional dependencies diff --git a/erebos-tester.cabal b/erebos-tester.cabal index 6661f8b..32f1934 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: erebos-tester -version: 0.3.1 +version: 0.3.4 synopsis: Test framework with virtual network using Linux namespaces description: This framework is intended mainly for networking libraries/applications and @@ -60,11 +60,14 @@ executable erebos-tester Parser.Statement Paths_erebos_tester Process + Process.Signal Run Run.Monad + Sandbox Script.Expr Script.Expr.Class Script.Module + Script.Object Script.Shell Script.Var Test @@ -79,6 +82,7 @@ executable erebos-tester c-sources: src/main.c + src/shell.c other-extensions: CPP @@ -96,6 +100,7 @@ executable erebos-tester MultiParamTypeClasses MultiWayIf OverloadedStrings + QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables @@ -105,9 +110,9 @@ executable erebos-tester TypeOperators build-depends: - base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 }, + base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21, 4.22 }, bytestring ^>= { 0.10, 0.11, 0.12 }, - containers ^>= { 0.6.2.1, 0.7 }, + containers ^>= { 0.6.2.1, 0.7, 0.8 }, clock ^>= { 0.8.3 }, directory ^>=1.3.6.0, filepath ^>= { 1.4.2.1, 1.5.2 }, @@ -121,7 +126,7 @@ executable erebos-tester regex-tdfa ^>=1.3.1.0, scientific >=0.3 && < 0.4, stm ^>= { 2.5.0 }, - template-haskell^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 }, + template-haskell^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23, 2.24 }, text ^>= { 1.2, 2.0, 2.1 }, th-compat >=0.1 && <0.2, unix >=2.7 && <2.9, diff --git a/minici.yaml b/minici.yaml index 95dc61d..0813962 100644 --- a/minici.yaml +++ b/minici.yaml @@ -1,3 +1,13 @@ job build: shell: - cabal build -fci --constraint='megaparsec >= 9.7.0' + - mkdir build + - cp $(cabal list-bin erebos-tester) build/erebos-tester + artifact bin: + path: build/erebos-tester + +job test: + uses: + - build.bin + shell: + - EREBOS_TEST_TOOL='build/erebos-tester --test-mode' erebos-tester --verbose 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) @@ -72,14 +72,19 @@ gdbStart onCrash = do { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } pout <- liftIO $ newTVarIO [] + ignore <- liftIO $ newTVarIO ( 0, [] ) + pid <- liftIO $ getPid handle let process = Process - { procName = ProcNameGDB + { procId = ProcessId (-2) + , procName = ProcNameGDB , procHandle = Left handle , procStdin = hin , procOutput = pout + , procIgnore = ignore , procKillWith = Nothing , procNode = undefined + , procPid = pid } gdb <- GDB <$> pure process diff --git a/src/Main.hs b/src/Main.hs index abc96ac..3285bee 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,24 +31,34 @@ import Version data CmdlineOptions = CmdlineOptions { optTest :: TestOptions , optRepeat :: Int + , optExclude :: [ Text ] , optVerbose :: Bool , optColor :: Maybe Bool , optShowHelp :: Bool , optShowVersion :: Bool , optTestMode :: Bool + , optCmdlineTcpdump :: TcpdumpOption } defaultCmdlineOptions :: CmdlineOptions defaultCmdlineOptions = CmdlineOptions { optTest = defaultTestOptions , optRepeat = 1 + , optExclude = [] , optVerbose = False , optColor = Nothing , optShowHelp = False , optShowVersion = False , optTestMode = False + , optCmdlineTcpdump = TcpdumpAuto } +data TcpdumpOption + = TcpdumpAuto + | TcpdumpManual FilePath + | TcpdumpOff + + options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] options = [ Option ['T'] ["tool"] @@ -86,9 +93,18 @@ 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" + , Option [] [ "no-tcpdump" ] + (NoArg (\opts -> opts { optCmdlineTcpdump = TcpdumpOff })) + "do not run tcpdump to capture network traffic" + , Option [] [ "tcpdump" ] + (OptArg (\str opts -> opts { optCmdlineTcpdump = maybe TcpdumpAuto TcpdumpManual str }) "<path>") + "use tcpdump to capture network traffic, at given <path> or found in PATH" , Option ['h'] ["help"] (NoArg $ \opts -> opts { optShowHelp = True }) "show this help and exit" @@ -108,9 +124,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,19 +134,26 @@ main = do { optTest = defaultTestOptions { optDefaultTool = envtool , optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions + , optTimeout = fromMaybe (optTimeout defaultTestOptions) $ configTimeout =<< config } } args <- getArgs - (opts, ofiles) <- case getOpt Permute (options ++ hiddenOptions) 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" , "" @@ -145,7 +167,7 @@ main = do exitSuccess when (optTestMode opts) $ do - testMode + testMode config exitSuccess case words $ optDefaultTool $ optTest opts of @@ -159,7 +181,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" @@ -171,32 +193,36 @@ 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 <- 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, 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 + 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 + tcpdump <- case optCmdlineTcpdump opts of + TcpdumpAuto -> findExecutable "tcpdump" + TcpdumpManual path -> return (Just path) + TcpdumpOff -> return Nothing - ok <- allM (runTest out (optTest opts) globalDefs) $ - concat $ replicate (optRepeat opts) $ concat tests + let topts = (optTest opts) + { optTcpdump = tcpdump + } + ok <- allM (runTest out topts globalDefs) $ + concat $ replicate (optRepeat opts) tests when (not ok) exitFailure foreign export ccall testerMain :: IO () diff --git a/src/Network.hs b/src/Network.hs index e12231d..fdc83c6 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -102,11 +102,11 @@ instance HasNetns Node where getNetns = nodeNetns instance ExprType Network where textExprType _ = T.pack "network" - textExprValue n = "s:" <> textNetworkName (netPrefix n) + textExprValue n = "<network:" <> textNetworkName (netPrefix n) <> ">" instance ExprType Node where textExprType _ = T.pack "node" - textExprValue n = T.pack "n:" <> textNodeName (nodeName n) + textExprValue n = T.pack "<node:" <> textNodeName (nodeName n) <> ">" recordMembers = map (first T.pack) [ ( "ifname", RecordSelector $ const ("veth0" :: Text) ) 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/Output.hs b/src/Output.hs index 7c4a8a5..1201d72 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -9,6 +9,7 @@ module Output ( ) where import Control.Concurrent.MVar +import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader @@ -24,6 +25,8 @@ import System.IO import Text.Printf +import Script.Expr + data Output = Output { outState :: MVar OutputState , outConfig :: OutputConfig @@ -47,13 +50,17 @@ data OutputStyle deriving (Eq) data OutputType - = OutputChildStdout + = OutputGlobalInfo + | OutputGlobalError + | OutputChildStdout | OutputChildStderr | OutputChildStdin + | OutputChildExec | OutputChildInfo | OutputChildFail | OutputMatch - | OutputMatchFail + | OutputMatchFail CallStack + | OutputIgnored | OutputError | OutputAlways | OutputTestRaw @@ -77,55 +84,79 @@ resetOutputTime Output {..} = do modifyMVar_ outStartedAt . const $ getTime Monotonic outColor :: OutputType -> Text -outColor OutputChildStdout = T.pack "0" -outColor OutputChildStderr = T.pack "31" -outColor OutputChildStdin = T.pack "0" -outColor OutputChildInfo = T.pack "0" -outColor OutputChildFail = T.pack "31" -outColor OutputMatch = T.pack "32" -outColor OutputMatchFail = T.pack "31" -outColor OutputError = T.pack "31" -outColor OutputAlways = "0" -outColor OutputTestRaw = "0" +outColor = \case + OutputGlobalInfo -> "0" + OutputGlobalError -> "31" + OutputChildStdout -> "0" + OutputChildStderr -> "31" + OutputChildStdin -> "0" + OutputChildExec -> "33" + OutputChildInfo -> "0" + OutputChildFail -> "31" + OutputMatch -> "32" + OutputMatchFail {} -> "31" + OutputIgnored -> "90" + OutputError -> "31" + OutputAlways -> "0" + OutputTestRaw -> "0" outSign :: OutputType -> Text -outSign OutputChildStdout = T.empty -outSign OutputChildStderr = T.pack "!" -outSign OutputChildStdin = T.empty -outSign OutputChildInfo = T.pack "." -outSign OutputChildFail = T.pack "!!" -outSign OutputMatch = T.pack "+" -outSign OutputMatchFail = T.pack "/" -outSign OutputError = T.pack "!!" -outSign OutputAlways = T.empty -outSign OutputTestRaw = T.empty +outSign = \case + OutputGlobalInfo -> "" + OutputGlobalError -> "" + OutputChildStdout -> " " + OutputChildStderr -> "!" + OutputChildStdin -> T.empty + OutputChildExec -> "*" + OutputChildInfo -> "." + OutputChildFail -> "!!" + OutputMatch -> "+" + OutputMatchFail {} -> "/" + OutputIgnored -> "-" + OutputError -> "!!" + OutputAlways -> T.empty + OutputTestRaw -> T.empty outArr :: OutputType -> Text -outArr OutputChildStdin = "<" -outArr _ = ">" +outArr = \case + OutputGlobalInfo -> "" + OutputGlobalError -> "" + OutputChildStdin -> "<" + _ -> ">" outTestLabel :: OutputType -> Text outTestLabel = \case + OutputGlobalInfo -> "global-info" + OutputGlobalError -> "global-error" OutputChildStdout -> "child-stdout" OutputChildStderr -> "child-stderr" OutputChildStdin -> "child-stdin" + OutputChildExec -> "child-exec" OutputChildInfo -> "child-info" OutputChildFail -> "child-fail" OutputMatch -> "match" - OutputMatchFail -> "match-fail" + OutputMatchFail {} -> "match-fail" + OutputIgnored -> "ignored" OutputError -> "error" OutputAlways -> "other" OutputTestRaw -> "" printWhenQuiet :: OutputType -> Bool printWhenQuiet = \case + OutputGlobalError -> True OutputChildStderr -> True OutputChildFail -> True - OutputMatchFail -> True + OutputMatchFail {} -> True OutputError -> True OutputAlways -> True _ -> False +includeTestTime :: OutputType -> Bool +includeTestTime = \case + OutputGlobalInfo -> False + OutputGlobalError -> False + _ -> True + ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a ioWithOutput act = liftIO . act =<< getOutput @@ -142,27 +173,62 @@ outLine otype prompt line = ioWithOutput $ \out -> stime <- readMVar (outStartedAt out) nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic withMVar (outState out) $ \st -> do - outPrint st $ TL.fromChunks $ concat - [ [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ] - , 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 [] - ] + forM_ (normalOutputLines otype line) $ \line' -> do + outPrint st $ TL.fromChunks $ concat + [ if includeTestTime otype + then [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ] + else [] + , 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 [] + ] 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 - ] + case otype of + OutputTestRaw -> outPrint st $ TL.fromStrict line + _ -> forM_ (testOutputLines otype (maybe "-" id prompt) line) $ outPrint st . TL.fromStrict + + +normalOutputLines :: OutputType -> Text -> [ Text ] +normalOutputLines (OutputMatchFail (CallStack stack)) msg = concat + [ msg <> " on " <> textSourceLine stackTopLine : showVars stackTopVars + , concat $ flip map stackRest $ \( sline, vars ) -> + " called from " <> textSourceLine sline : showVars vars + ] + where + showVars = + map $ \(( name, sel ), value ) -> T.concat + [ " ", textFqVarName name, T.concat (map ("."<>) sel) + , " = ", textSomeVarValue value + ] + (( stackTopLine, stackTopVars ), stackRest ) = + case stack of + (stop : srest) -> ( stop, srest ) + [] -> (( SourceLine "unknown", [] ), [] ) +normalOutputLines _ msg = [ msg ] + + +testOutputLines :: OutputType -> Text -> Text -> [ Text ] +testOutputLines otype@(OutputMatchFail (CallStack stack)) _ msg = concat + [ [ T.concat [ outTestLabel otype, " ", msg ] ] + , concat $ flip map stack $ \( sline, vars ) -> + T.concat [ outTestLabel otype, "-line ", textSourceLine sline ] : showVars vars + , [ T.concat [ outTestLabel otype, "-done" ] ] + ] + where + showVars = + map $ \(( name, sel ), value ) -> T.concat + [ outTestLabel otype, "-var ", textFqVarName name, T.concat (map ("."<>) sel) + , " ", textSomeVarValue value + ] +testOutputLines otype prompt msg = [ T.concat [ outTestLabel otype, " ", prompt, " ", msg ] ] + outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text) outPromptGetLine = outPromptGetLineCompletion noCompletion diff --git a/src/Parser.hs b/src/Parser.hs index 0716457..619543f 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -43,12 +43,34 @@ 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 + href <- L.indentLevel + testName <- header + osymbol ":" <* eol <* scn + + ref <- L.indentGuard scn GT href + testTags <- preamble ref + testSteps <- fmap Scope <$> testBlock ref + return Test {..} + where header = do wsymbol "test" lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') + preamble :: Pos -> TestParser [ Expr Tag ] + preamble ref = fmap catMaybes $ many $ do + void $ L.indentGuard scn EQ ref + off <- stateOffset <$> getParserState + name <- try $ identifier <* osymbol ":" + case name of + "tag" -> do + Just <$> typedExpr FunctionTerm <* eol <* scn + _ -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "unexpected test metadata ‘" <> T.unpack name <> "’" + takeWhileP Nothing (/= '\n') *> eol *> scn *> return Nothing + + parseDefinition :: Pos -> TestParser ( VarName, SomeExpr ) parseDefinition href = label "symbol definition" $ do def@( name, expr ) <- localState $ do @@ -64,10 +86,10 @@ 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 + someExpr FunctionTerm <* eol ] scn atypes' <- getInferredTypes atypes @@ -79,11 +101,9 @@ parseDefinition href = label "symbol definition" $ do getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do let err msg = do registerParseError . FancyError off . S.singleton . ErrorFail $ T.unpack msg - return ( vname, SomeArgumentType (OptionalArgument @DynamicType) ) + return ( vname, SomeArgumentType OptionalArgument (ExprTypeForall (TypeVar "a") (ExprTypeVar (TypeVar "a"))) ) gets (M.lookup tvar . testTypeUnif) >>= \case - Just (ExprTypePrim (_ :: Proxy a)) -> return ( vname, SomeArgumentType (RequiredArgument @a) ) - Just (ExprTypeVar (TypeVar tvar')) -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvar' <> "’" - Just (ExprTypeFunction {}) -> err $ "unsupported function type of ‘" <> textVarName vname <> "’" + Just t -> return ( vname, SomeArgumentType RequiredArgument t ) Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’" replaceDynArgs :: forall a. Expr a -> TestParser (Expr a) @@ -95,7 +115,7 @@ parseDefinition href = label "symbol definition" $ do go unif = \case ArgsApp args body -> ArgsApp (fmap replaceArgs args) body where - replaceArgs (SomeExpr (DynVariable tvar sline vname)) + replaceArgs (SomeExpr (DynVariable (ExprTypeVar tvar) sline vname)) | Just (ExprTypePrim (Proxy :: Proxy v)) <- M.lookup tvar unif = SomeExpr (Variable sline vname :: Expr v) replaceArgs (SomeExpr e) = SomeExpr (go unif e) @@ -125,13 +145,23 @@ parseAsset href = label "asset definition" $ do modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } return ( name, expr ) +parseTag :: Pos -> TestParser ( VarName, SomeExpr ) +parseTag _ = label "tag definition" $ do + wsymbol "tag" + name <- constrName + void eol + cmn <- gets testCurrentModuleName + let expr = SomeExpr $ Pure $ Tag cmn name + modify $ \s -> s { testVars = ( name, ( GlobalVarName cmn 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 ref <|> parseAsset ref + def@( name, _ ) <- parseDefinition ref <|> parseAsset ref <|> parseTag ref return [ ToplevelDefinition def, ToplevelExport name ] , do names <- listOf varName @@ -168,6 +198,7 @@ parseTestModule absPath = do [ (: []) <$> parseTestDefinition , (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1) , (: []) <$> toplevel ToplevelDefinition (parseAsset pos1) + , (: []) <$> toplevel ToplevelDefinition (parseTag pos1) , parseExport , parseImport ] @@ -201,7 +232,7 @@ parseTestFile parsedModules mbModuleName path = do let initState = TestParserState { testSourcePath = path , testVars = concat - [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins + [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someExprType value ))) $ M.toList builtins ] , testContext = SomeExpr (Undefined "void" :: Expr Void) , testNextTypeVar = 0 diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index 132dbc8..c12afdd 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -18,6 +18,7 @@ import qualified Text.Megaparsec.Char.Lexer as L import Network () import Script.Expr +import Script.Expr.Class import Script.Module import Test @@ -104,17 +105,19 @@ lookupVarExpr off sline name = do ( fqn, etype ) <- lookupVarType off name case etype of ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a) - ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn - ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a)) + ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType) + ExprTypeFunction args (ExprTypePrim (_ :: Proxy a)) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a)) + stype -> return $ SomeExpr $ DynVariable stype sline fqn lookupScalarVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr lookupScalarVarExpr off sline name = do ( fqn, etype ) <- lookupVarType off name case etype of ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a) - ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn - ExprTypeFunction args (pa :: Proxy a) -> do + ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType) + ExprTypeFunction args (ExprTypePrim (pa :: Proxy a)) -> do SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a)) + stype -> return $ SomeExpr $ DynVariable stype sline fqn unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do @@ -171,6 +174,28 @@ unify _ res@(ExprTypePrim (Proxy :: Proxy a)) (ExprTypePrim (Proxy :: Proxy b)) | Just (Refl :: a :~: b) <- eqT = return res +unify _ res@(ExprTypeConstr1 (Proxy :: Proxy a)) (ExprTypeConstr1 (Proxy :: Proxy b)) + | Just (Refl :: a :~: b) <- eqT + = return res + +unify off (ExprTypeApp ac aparams) (ExprTypeApp bc bparams) + | length aparams == length bparams + = do + c <- unify off ac bc + params <- zipWithM (unify off) aparams bparams + return $ case ( c, params ) of + ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] ) + -> ExprTypePrim (Proxy :: Proxy (c' p')) + _ -> ExprTypeApp c params + +unify off a@(ExprTypeApp {}) (ExprTypePrim bproxy) + | TypeDeconstructor1 c p <- matchTypeConstructor bproxy + = unify off a (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ]) + +unify off (ExprTypePrim aproxy) b@(ExprTypeApp {}) + | TypeDeconstructor1 c p <- matchTypeConstructor aproxy + = unify off (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ]) b + unify off a b = do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "couldn't match expected type `" <> textSomeExprType a <> "' with actual type `" <> textSomeExprType b <> "'" @@ -181,27 +206,48 @@ unifyExpr off pa expr = if | Just (Refl :: a :~: b) <- eqT -> return expr - | DynVariable tvar sline name <- expr + | DynVariable stype sline name <- expr + , ExprTypeForall qvar itype <- stype -> do - _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar) + tvar <- newTypeVar + _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) $ renameVarInType qvar tvar itype + rtype <- M.lookup tvar <$> gets testTypeUnif + return $ TypeApp (Variable sline name) $ fromMaybe (ExprTypeVar tvar) rtype + + | DynVariable stype sline name <- expr + -> do + _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) stype return $ Variable sline name + | HideType (ExprTypePrim (_ :: Proxy b'')) (expr' :: Expr b') <- expr + , Just (Refl :: b'' :~: b') <- eqT + -> do + unifyExpr off pa expr' + + | TypeLambda tvar t f <- expr + -> do + _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) t + Just (ExprTypePrim pt) <- M.lookup tvar <$> gets testTypeUnif + unifyExpr off pa (f $ ExprTypePrim pt) + | Just (Refl :: FunctionType a :~: b) <- eqT -> do let FunctionArguments remaining = exprArgs expr - showType ( Nothing, SomeArgumentType atype ) = "`<" <> textExprType atype <> ">'" - showType ( Just (ArgumentKeyword kw), SomeArgumentType atype ) = "`" <> kw <> " <" <> textExprType atype <> ">'" + showType ( Nothing, SomeArgumentType _ stype ) = "‘<" <> textSomeExprType stype <> ">’" + showType ( Just (ArgumentKeyword kw), SomeArgumentType _ stype ) = "‘" <> kw <> " <" <> textSomeExprType stype <> ">’" err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case - arg@(_, SomeArgumentType RequiredArgument) -> err $ "missing " <> showType arg <> " argument" - (_, SomeArgumentType OptionalArgument) -> return Nothing - (kw, SomeArgumentType (ExprDefault def)) -> return $ Just ( kw, SomeExpr def ) - (kw, SomeArgumentType atype@ContextDefault) -> do + arg@( _, SomeArgumentType RequiredArgument _ ) -> err $ "missing " <> showType arg <> " argument" + ( _, SomeArgumentType OptionalArgument _ ) -> return Nothing + ( kw, SomeArgumentType (ExprDefault def) _ ) -> return $ Just ( kw, def ) + ( kw, SomeArgumentType ContextDefault (ExprTypePrim atype) ) -> do SomeExpr context <- gets testContext context' <- unifyExpr off atype context return $ Just ( kw, SomeExpr context' ) - return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) + ( _, SomeArgumentType ContextDefault _ ) -> err "non-primitive context requirement" + sline <- getSourceLine + return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) | Just (Refl :: DynamicType :~: b) <- eqT , Undefined msg <- expr @@ -211,7 +257,37 @@ unifyExpr off pa expr = if | otherwise -> do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'" + "couldn't match expected type ‘" <> textExprType pa <> "’ with actual type ‘" <> textExprType expr <> "’" + + +unifySomeExpr :: Int -> SomeExprType -> SomeExpr -> TestParser SomeExpr +unifySomeExpr off stype sexpr@(SomeExpr expr) + | ExprTypePrim pa <- stype + = SomeExpr <$> unifyExpr off pa expr + + | ExprTypeConstr1 {} <- stype + = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "unification with incomplete type" + + | ExprTypeVar tvar <- stype + = do + _ <- unify off (ExprTypeVar tvar) (someExprType sexpr) + return sexpr + + | ExprTypeFunction args res <- stype + = case someExprType sexpr of + ExprTypeFunction args' res' -> do + _ <- unify off args args' + _ <- unify off res res' + return sexpr + _ -> do + _ <- unify off args (ExprTypeArguments mempty) + SomeExpr expr' <- unifySomeExpr off res sexpr + return $ SomeExpr $ FunctionAbstraction expr' + + | otherwise + = do + parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ + "couldn't match expected type ‘" <> textSomeExprType stype <> "’ with actual type ‘" <> textSomeExprType (someExprType sexpr) <> "’" skipLineComment :: TestParser () @@ -235,7 +311,7 @@ osymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy operatorChar) wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) -operatorChar = satisfy $ (`elem` ['.', '+', '-', '*', '/', '=']) +operatorChar = satisfy $ (`elem` [ '.', '+', '-', '*', '/', '=', '<', '>', '|' ]) {-# INLINE operatorChar #-} localState :: TestParser a -> TestParser a @@ -249,15 +325,6 @@ localState inner = do toplevel :: (a -> b) -> TestParser a -> TestParser b 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 - h <- header - choice - [ do symbol ":" - return $ L.IndentSome Nothing (merge h) item - , L.IndentNone <$> merge h [] - ] - listOf :: TestParser a -> TestParser [a] listOf item = do x <- item diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index 3700602..16c2b45 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -4,12 +4,15 @@ module Parser.Expr ( varName, newVarName, - addVarName, + addVarName, addVarNameType, + constrName, + TermComplexity(..), someExpr, typedExpr, literal, variable, + constructor, stringExpansion, @@ -76,12 +79,22 @@ newVarName = do return name addVarName :: forall a. ExprType a => Int -> TypedVarName a -> TestParser () -addVarName off (TypedVarName name) = do +addVarName off tname = addVarNameType off tname (ExprTypePrim @a Proxy) + +addVarNameType :: forall a. ExprType a => Int -> TypedVarName a -> SomeExprType -> TestParser () +addVarNameType off (TypedVarName name) stype = do gets (lookup name . testVars) >>= \case 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, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s } + modify $ \s -> s { testVars = ( name, ( LocalVarName name, stype )) : testVars s } + +constrName :: TestParser VarName +constrName = label "contructor name" $ do + lexeme $ try $ do + lead <- upperChar + rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_') + return $ VarName $ TL.toStrict $ TL.fromChunks $ T.singleton lead : TL.toChunks rest someExpansion :: TestParser SomeExpr someExpansion = do @@ -91,7 +104,7 @@ someExpansion = do sline <- getSourceLine name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') lookupScalarVarExpr off sline name - , between (char '{') (char '}') someExpr + , between (char '{') (char '}') (someExpr FunctionTerm) ] expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a) @@ -118,6 +131,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 '"' @@ -142,7 +162,7 @@ quotedString = label "string" $ lexeme $ do regex :: TestParser (Expr Regex) regex = label "regular expression" $ lexeme $ do off <- stateOffset <$> getParserState - void $ char '/' + void $ try $ char '/' <* notFollowedBy (char '=') -- TODO: better parsing rules for regexes let inner = choice [ char '/' >> return [] , takeWhile1P Nothing (`notElem` ['/', '\\', '$']) >>= \s -> (Pure (RegexPart (TL.toStrict s)) :) <$> inner @@ -168,40 +188,51 @@ regex = label "regular expression" $ lexeme $ do list :: TestParser SomeExpr list = label "list" $ do symbol "[" - SomeExpr x <- someExpr - let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "list range enumeration not defined for '" <> textExprType x <> "'" - let exprList = foldr (liftA2 (:)) (Pure []) - SomeExpr <$> choice + choice [do symbol "]" - return $ exprList [x] - - ,do off <- stateOffset <$> getParserState - osymbol ".." - ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x - y <- typedExpr - symbol "]" - return $ fromTo <$> x <*> y - - ,do symbol "," - y <- typedExpr - - choice + tvar <- newTypeVar + return $ SomeExpr $ + TypeLambda tvar (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) $ + \case + (ExprTypePrim (Proxy :: Proxy a)) -> HideType (ExprTypePrim (Proxy @[ a ])) $ Pure ([] :: [ a ]) + _ -> Undefined "incomplete type" + + ,do SomeExpr x <- someExpr FunctionTerm + let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ + "list range enumeration not defined for ‘" <> textExprType x <> "’" + let exprList = foldr (liftA2 (:)) (Pure []) + + SomeExpr <$> choice [do symbol "]" - return $ exprList [x, y] + return $ exprList [ x ] ,do off <- stateOffset <$> getParserState osymbol ".." - ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x - z <- typedExpr + ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x + y <- typedExpr FunctionTerm symbol "]" - return $ fromThenTo <$> x <*> y <*> z + return $ fromTo <$> x <*> y ,do symbol "," - xs <- listOf typedExpr - symbol "]" - return $ exprList (x:y:xs) + y <- typedExpr FunctionTerm + + choice + [do symbol "]" + return $ exprList [ x, y ] + + ,do off <- stateOffset <$> getParserState + osymbol ".." + ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x + z <- typedExpr FunctionTerm + symbol "]" + return $ fromThenTo <$> x <*> y <*> z + + ,do symbol "," + xs <- listOf (typedExpr FunctionTerm) + symbol "]" + return $ exprList (x : y : xs) + ] ] ] @@ -224,14 +255,28 @@ applyBinOp off op x y = do y' <- unifyExpr off (Proxy @b) y return $ op <$> x' <*> y' -someExpr :: TestParser SomeExpr -someExpr = join inner <?> "expression" +data TermComplexity + = SimpleTerm -- variable name, literal or more complex term in parentheses + | FunctionTerm -- simple term or function call + +someExpr :: TermComplexity -> TestParser SomeExpr +someExpr complexity = label "expression" $ do + case complexity of + SimpleTerm -> join termSimple + FunctionTerm -> join inner where - inner = makeExprParser term table + inner = makeExprParser termFunction table parens = between (symbol "(") (symbol ")") - term = label "term" $ choice + termSimple = label "term" $ choice + [ parens inner + , return <$> literal + , return <$> variable + , return <$> constructor + ] + + termFunction = label "term" $ choice [ parens inner , return <$> literal , return <$> functionCall @@ -261,11 +306,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) @@ -338,15 +385,16 @@ someExpr = join inner <?> "expression" region (const err) $ foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops -typedExpr :: forall a. ExprType a => TestParser (Expr a) -typedExpr = do +typedExpr :: forall a. ExprType a => TermComplexity -> TestParser (Expr a) +typedExpr complexity = do off <- stateOffset <$> getParserState - SomeExpr e <- someExpr + SomeExpr e <- someExpr complexity unifyExpr off Proxy e literal :: TestParser SomeExpr literal = label "literal" $ choice [ numberLiteral + , boolLiteral , SomeExpr <$> quotedString , SomeExpr <$> regex , list @@ -360,15 +408,37 @@ variable = label "variable" $ do e <- lookupVarExpr off sline name recordSelector e <|> return e +constructor :: TestParser SomeExpr +constructor = label "constructor" $ do + off <- stateOffset <$> getParserState + sline <- getSourceLine + name <- constrName + lookupVarExpr off sline name + functionCall :: TestParser SomeExpr functionCall = do sline <- getSourceLine - variable >>= \case - SomeExpr e'@(FunVariable argTypes _ _) -> do - let check = checkFunctionArguments argTypes - args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff sline . VarName) - return $ SomeExpr $ ArgsApp args e' - e -> return e + off <- stateOffset <$> getParserState + + fun <- variable <|> constructor + FunctionArguments margs <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName) + if M.null margs + then return fun + else do + dict <- newTypeVar + res <- newTypeVar + SomeExpr (expr :: Expr fa) <- unifySomeExpr off (ExprTypeFunction (ExprTypeVar dict) (ExprTypeVar res)) fun + Just (ExprTypeArguments argTypes) <- M.lookup dict <$> gets testTypeUnif + args <- fmap (FunctionArguments . M.fromAscList) $ mapM (\( kw, ( poff, e ) ) -> ( kw, ) <$> checkFunctionArguments argTypes poff kw e) $ M.toAscList margs + M.lookup res <$> gets testTypeUnif >>= \case + Just (ExprTypePrim (_ :: Proxy a)) + | Just (Refl :: FunctionType a :~: fa) <- eqT + -> return $ SomeExpr $ ArgsApp args expr + | otherwise -> error $ "type mismatch after function unification: " <> show ( typeRep (Proxy @(FunctionType a)), typeRep (Proxy @fa) ) + _ + | Just (Refl :: FunctionType DynamicType :~: fa) <- eqT + -> return $ SomeExpr $ ArgsApp args expr + | otherwise -> error $ "type mismatch after function unification: " <> show ( typeRep (Proxy @(FunctionType DynamicType)), typeRep (Proxy @fa) ) recordSelector :: SomeExpr -> TestParser SomeExpr recordSelector (SomeExpr expr) = do @@ -386,17 +456,17 @@ recordSelector (SomeExpr expr) = do checkFunctionArguments :: FunctionArguments SomeArgumentType -> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr -checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr) = do +checkFunctionArguments (FunctionArguments argTypes) poff kw expr = do case M.lookup kw argTypes of - Just (SomeArgumentType (_ :: ArgumentType expected)) -> do - withRecovery (\e -> registerParseError e >> return sexpr) $ do - SomeExpr <$> unifyExpr poff (Proxy @expected) expr + Just (SomeArgumentType _ stype) -> do + withRecovery (\e -> registerParseError e >> return expr) $ do + unifySomeExpr poff stype expr 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 + return expr functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b) diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs index 0f34fee..105edfa 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 @@ -19,15 +20,18 @@ 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 +parseTextArgument :: TestParser (Expr Text) +parseTextArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice [ doubleQuotedString - , escapedChar + , singleQuotedString + , standaloneEscapedChar , stringExpansion , unquotedString ] where - specialChars = [ '\"', '\\', '$' ] + specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']'{-, '{', '}' -}, '(', ')'{-, '*', '?', '~', '&', '!' -} ] + + stringSpecialChars = [ '"', '\\', '$' ] unquotedString :: TestParser (Expr Text) unquotedString = do @@ -38,36 +42,92 @@ parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:) void $ char '"' let inner = choice [ char '"' >> return [] - , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner - , (:) <$> escapedChar <*> inner + , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` stringSpecialChars)) <*> inner + , (:) <$> stringEscapedChar <*> inner , (:) <$> stringExpansion <*> inner ] App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner - escapedChar :: TestParser (Expr Text) - escapedChar = do + singleQuotedString :: TestParser (Expr Text) + singleQuotedString = do + Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'') + + stringEscapedChar :: TestParser (Expr Text) + stringEscapedChar = do void $ char '\\' - Pure <$> choice - [ char '\\' >> return "\\" - , char '"' >> return "\"" - , char '$' >> return "$" - , char 'n' >> return "\n" + fmap Pure $ choice $ + map (\c -> char c >> return (T.singleton c)) stringSpecialChars ++ + [ char 'n' >> return "\n" , char 'r' >> return "\r" , char 't' >> return "\t" + , return "\\" ] -parseArguments :: TestParser (Expr [ Text ]) + standaloneEscapedChar :: TestParser (Expr Text) + standaloneEscapedChar = do + void $ char '\\' + fmap T.singleton . Pure <$> printChar + +parseRedirection :: TestParser (Expr ShellArgument) +parseRedirection = choice + [ do + osymbol "<" + fmap ShellRedirectStdin <$> parseTextArgument + , do + osymbol ">" + fmap (ShellRedirectStdout False) <$> parseTextArgument + , do + osymbol ">>" + fmap (ShellRedirectStdout True) <$> parseTextArgument + , do + osymbol "2>" + fmap (ShellRedirectStderr False) <$> parseTextArgument + , do + osymbol "2>>" + fmap (ShellRedirectStderr True) <$> parseTextArgument + ] + +parseArgument :: TestParser (Expr ShellArgument) +parseArgument = choice + [ parseRedirection + , fmap ShellArgument <$> parseTextArgument + ] + +parseArguments :: TestParser (Expr [ ShellArgument ]) parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument -shellStatement :: TestParser (Expr [ ShellStatement ]) -shellStatement = label "shell statement" $ do - command <- parseArgument +parseCommand :: TestParser (Expr ShellCommand) +parseCommand = label "shell statement" $ do + line <- getSourceLine + command <- parseTextArgument args <- parseArguments - return $ fmap (: []) $ ShellStatement + return $ ShellCommand <$> command <*> args + <*> pure line + +parsePipeline :: Maybe (Expr ShellPipeline) -> TestParser (Expr ShellPipeline) +parsePipeline mbupper = do + cmd <- parseCommand + let pipeline = + case mbupper of + Nothing -> fmap (\ecmd -> ShellPipeline ecmd Nothing) cmd + Just upper -> liftA2 (\ecmd eupper -> ShellPipeline ecmd (Just eupper)) cmd upper + choice + [ do + osymbol "|" + parsePipeline (Just pipeline) + + , do + return pipeline + ] + +parseStatement :: TestParser (Expr [ ShellStatement ]) +parseStatement = do + line <- getSourceLine + fmap ((: []) . flip ShellStatement line) <$> parsePipeline Nothing shellScript :: TestParser (Expr ShellScript) shellScript = do indent <- L.indentLevel - fmap ShellScript <$> blockOf indent shellStatement + fmap ShellScript <$> blockOf indent parseStatement diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 7c2977d..f4f5b61 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -1,5 +1,6 @@ module Parser.Statement ( testStep, + testBlock, ) where import Control.Monad @@ -36,14 +37,14 @@ letStatement = do off <- stateOffset <$> getParserState name <- varName osymbol "=" - SomeExpr e <- someExpr + se@(SomeExpr e) <- someExpr FunctionTerm localState $ do let tname = TypedVarName name - addVarName off tname + addVarNameType off tname (someExprType se) 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 @@ -54,7 +55,7 @@ forStatement = do wsymbol "in" loff <- stateOffset <$> getParserState - SomeExpr e <- someExpr + SomeExpr e <- someExpr FunctionTerm let err = parseError $ FancyError loff $ S.singleton $ ErrorFail $ T.unpack $ "expected a list, expression has type '" <> textExprType e <> "'" ExprListUnpacker unpack _ <- maybe err return $ exprListUnpacker e @@ -68,29 +69,58 @@ 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 ref <- L.indentLevel wsymbol "shell" - wsymbol "as" - pname <- newVarName - wsymbol "on" - node <- typedExpr - symbol ":" - void eol - void $ L.indentGuard scn GT ref - script <- shellScript - cont <- testBlock ref - return $ TestBlockStep EmptyTestBlock <$> - (SpawnShell pname <$> node <*> script <*> LambdaAbstraction pname cont) + 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 SimpleTerm + 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 <- fmap Scope <$> 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 - SomeExpr expr <- someExpr + SomeExpr expr <- someExpr FunctionTerm choice [ continuePartial off ref expr , unifyExpr off Proxy expr @@ -106,7 +136,7 @@ exprStatement = do blockOf indent $ do coff <- stateOffset <$> getParserState sline <- getSourceLine - args <- functionArguments (checkFunctionArguments (exprArgs fun)) someExpr literal (\poff -> lookupVarExpr poff sline . VarName) + args <- functionArguments (checkFunctionArguments (exprArgs fun)) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName) let fun' = ArgsApp args fun choice [ continuePartial coff indent fun' @@ -139,19 +169,18 @@ instance ParamType SourceLine where parseParam _ = mzero showParamType _ = "<source line>" +instance ParamType CallStack where + type ParamRep CallStack = Expr CallStack + parseParam _ = mzero + showParamType _ = "<call stack>" + paramExpr = id + instance ExprType a => ParamType (TypedVarName a) where parseParam _ = newVarName showParamType _ = "<variable>" paramNewVariables _ var = SomeNewVariables [ var ] paramNewVariablesEmpty _ = SomeNewVariables @a [] -instance ExprType a => ParamType (Expr a) where - parseParam _ = do - off <- stateOffset <$> getParserState - SomeExpr e <- literal <|> between (symbol "(") (symbol ")") someExpr - unifyExpr off Proxy e - showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" - instance ParamType a => ParamType [a] where type ParamRep [a] = [ParamRep a] parseParam _ = listOf (parseParam @a Proxy) @@ -187,8 +216,8 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where instance ExprType a => ParamType (Traced a) where type ParamRep (Traced a) = Expr a - parseParam _ = parseParam (Proxy @(Expr a)) - showParamType _ = showParamType (Proxy @(Expr a)) + parseParam _ = parseParam (Proxy @(ExprParam a)) + showParamType _ = showParamType (Proxy @(ExprParam a)) paramExpr = Trace data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a)) @@ -246,6 +275,9 @@ paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" +callStack :: CommandDef CallStack +callStack = param "" + newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } instance ExprType a => ParamType (InnerBlock a) where @@ -261,14 +293,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) @@ -277,7 +309,7 @@ instance ExprType a => ParamType (ExprParam a) where type ParamRep (ExprParam a) = Expr a parseParam _ = do off <- stateOffset <$> getParserState - SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr + SomeExpr e <- someExpr SimpleTerm unifyExpr off Proxy e showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" paramExpr = fmap ExprParam @@ -297,6 +329,7 @@ command name (CommandDef types ctor) = do iparams <- forM params $ \case (_, SomeParam (p :: Proxy p) Nothing) | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line + | Just (Refl :: p :~: CallStack) <- eqT -> return $ SomeParam p $ Identity $ Variable line callStackFqVarName | SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables , Just (Refl :: p :~: InnerBlock a) <- eqT @@ -351,7 +384,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 @@ -359,7 +393,7 @@ testWith = do wsymbol "with" off <- stateOffset <$> getParserState - ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr + ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr SimpleTerm let expected = [ ExprTypePrim @Network Proxy , ExprTypePrim @Node Proxy @@ -377,7 +411,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 @@ -395,13 +429,17 @@ testSpawn :: TestParser (Expr (TestBlock ())) testSpawn = command "spawn" $ Spawn <$> param "as" <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") + <*> (maybe [] fromExprParam <$> param "args") + <*> (maybe Nothing (Just . fromExprParam) <$> param "killwith") <*> innerBlockFun testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect - <$> cmdLine + <$> callStack + <*> cmdLine <*> (fromExprParam <$> paramOrContext "from") <*> param "" + <*> (maybe 1 fromExprParam <$> param "timeout") <*> param "capture" <*> innerBlockFunList diff --git a/src/Process.hs b/src/Process.hs index 290aedf..4f4c286 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -1,13 +1,19 @@ module Process ( Process(..), - ProcName(..), - textProcName, unpackProcName, + ProcessId(..), textProcId, + ProcName(..), textProcName, unpackProcName, + Signal, send, - outProc, + outProc, outProcName, lineReadingLoop, + startProcessIOLoops, spawnOn, closeProcess, + closeTestProcess, withProcess, + + IgnoreProcessOutput(..), + flushProcessOutput, ) where import Control.Arrow @@ -18,9 +24,12 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Function +import Data.List +import Data.Maybe +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 @@ -28,23 +37,29 @@ import System.Exit import System.FilePath import System.IO import System.IO.Error -import System.Posix.Signals +import System.Posix.Process import System.Process import {-# SOURCE #-} GDB import Network import Network.Ip import Output +import Process.Signal import Run.Monad +import Script.Expr import Script.Expr.Class +import Script.Object data Process = Process - { procName :: ProcName + { procId :: ProcessId + , procName :: ProcName , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode ) , procStdin :: Handle - , procOutput :: TVar [Text] + , procOutput :: TVar [ Text ] + , procIgnore :: TVar ( Int, [ ( Int, Maybe Regex ) ] ) , procKillWith :: Maybe Signal , procNode :: Node + , procPid :: Maybe Pid } instance Eq Process where @@ -52,18 +67,24 @@ instance Eq Process where instance ExprType Process where textExprType _ = T.pack "proc" - textExprValue n = T.pack "p:" <> textProcName (procName n) + textExprValue p = "<process:" <> textProcName (procName p) <> "#" <> textProcId (procId p) <> ">" recordMembers = map (first T.pack) - [ ("node", RecordSelector $ procNode) + [ ( "node", RecordSelector $ procNode ) + , ( "pid", RecordSelector $ maybe (0 :: Integer) fromIntegral . procPid ) ] +newtype ProcessId = ProcessId Int + data ProcName = ProcName Text | ProcNameTcpdump | ProcNameGDB deriving (Eq, Ord) +textProcId :: ProcessId -> Text +textProcId (ProcessId pid) = T.pack (show pid) + textProcName :: ProcName -> Text textProcName (ProcName name) = name textProcName ProcNameTcpdump = T.pack "tcpdump" @@ -78,22 +99,52 @@ send p line = liftIO $ do hFlush (procStdin p) outProc :: MonadOutput m => OutputType -> Process -> Text -> m () -outProc otype p line = outLine otype (Just $ textProcName $ procName p) line +outProc otype p line = outProcName otype (procName p) line + +outProcName :: MonadOutput m => OutputType -> ProcName -> Text -> m () +outProcName otype pname line = outLine otype (Just $ textProcName pname) line lineReadingLoop :: MonadOutput m => Process -> Handle -> (Text -> m ()) -> m () lineReadingLoop process h act = liftIO (tryIOError (T.hGetLine h)) >>= \case - Left err - | isEOFError err -> return () - | otherwise -> outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err + Left err -> do + when (not (isEOFError err)) $ do + outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err + liftIO $ hClose h Right line -> do act line lineReadingLoop process h act +startProcessIOLoops :: Process -> Handle -> Handle -> TestRun () +startProcessIOLoops process@Process {..} hout herr = do + + void $ forkTest $ lineReadingLoop process hout $ \line -> do + outProc OutputChildStdout process line + ignored <- liftIO $ atomically $ do + ignores <- map snd . snd <$> readTVar procIgnore + let ignored = any (matches line) ignores + when (not ignored) $ do + modifyTVar procOutput (++ [ line ]) + return ignored + when ignored $ do + outProc OutputIgnored process line + + void $ forkTest $ lineReadingLoop process herr $ \line -> do + case procName of + ProcNameTcpdump -> return () + _ -> outProc OutputChildStderr process line + + where + matches _ Nothing + = True + matches line (Just re) + | Right (Just _) <- regexMatch re line = True + | otherwise = False + spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process -spawnOn target pname killWith cmd = do +spawnOn target procName procKillWith 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 ) @@ -103,56 +154,73 @@ spawnOn target pname killWith cmd = do return (path' ++ rest) _ -> return cmd + procId <- case procName of + ProcNameTcpdump -> return $ ProcessId (-1) + _ -> do + idVar <- asks $ teNextProcId . fst + liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x )) + 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 - } - pout <- liftIO $ newTVarIO [] - - let process = Process - { procName = pname - , procHandle = Left handle - , procStdin = hin - , procOutput = pout - , procKillWith = killWith - , procNode = either (const undefined) id target + (Just procStdin, 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 } + let procHandle = Left handle + procOutput <- liftIO $ newTVarIO [] + procIgnore <- liftIO $ newTVarIO ( 0, [] ) + let procNode = either (const undefined) id target + procPid <- liftIO $ getPid handle + let process = Process {..} - void $ forkTest $ lineReadingLoop process hout $ \line -> do - outProc OutputChildStdout process line - liftIO $ atomically $ modifyTVar pout (++[line]) - void $ forkTest $ lineReadingLoop process herr $ \line -> do - case pname of - ProcNameTcpdump -> return () - _ -> outProc OutputChildStderr process line + startProcessIOLoops process hout herr asks (teGDB . fst) >>= maybe (return Nothing) (liftIO . tryReadMVar) >>= \case - Just gdb | ProcName _ <- pname -> addInferior gdb process + Just gdb | ProcName _ <- procName -> addInferior gdb process _ -> return () 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 () - Just sig -> liftIO $ either getPid (\_ -> return Nothing) (procHandle p) >>= \case + Just sig -> case procPid p of Nothing -> return () 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 () - ExitFailure code -> do - outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code + + status <- case procPid p of + Nothing -> Just . Exited <$> liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) + Just pid -> liftIO (getProcessStatus True False pid) + case status of + Just (Exited ExitSuccess) -> do + return () + Just (Exited (ExitFailure code)) -> do + outProc OutputChildFail p $ "exit code: " <> T.pack (show code) + throwError Failed + Just (Terminated sig _) + | Just (Signal sig) == procKillWith p -> return () + | otherwise -> do + outProc OutputChildFail p $ "killed with signal " <> T.pack (show sig) + throwError Failed + Just (Stopped sig) -> do + outProc OutputChildFail p $ "stopped with signal " <> T.pack (show sig) throwError Failed + Nothing -> do + outProc OutputChildFail p $ "no exit status" + throwError Failed + +closeTestProcess :: Process -> TestRun () +closeTestProcess process = do + timeout <- getCurrentTimeout + closeProcess timeout process withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a withProcess target pname killWith cmd inner = do @@ -163,5 +231,36 @@ 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 + + +data IgnoreProcessOutput = IgnoreProcessOutput Process Int + +instance ObjectType TestRun IgnoreProcessOutput where + type ConstructorArgs IgnoreProcessOutput = ( Process, Maybe Regex ) + + textObjectType _ _ = "IgnoreProcessOutput" + textObjectValue _ (IgnoreProcessOutput _ _) = "<IgnoreProcessOutput>" + + createObject oid ( process@Process {..}, regex ) = do + ( obj, flushed ) <- liftIO $ atomically $ do + flushed <- flushProcessOutput process regex + ( iid, list ) <- readTVar procIgnore + writeTVar procIgnore ( iid + 1, ( iid, regex ) : list ) + return ( Object oid $ IgnoreProcessOutput process iid, flushed ) + mapM_ (outProc OutputIgnored process) flushed + return obj + + destroyObject Object { objImpl = IgnoreProcessOutput Process {..} iid } = do + liftIO $ atomically $ do + writeTVar procIgnore . fmap (filter ((iid /=) . fst)) =<< readTVar procIgnore + +flushProcessOutput :: Process -> Maybe Regex -> STM [ Text ] +flushProcessOutput p mbre = do + current <- readTVar (procOutput p) + let ( ignore, keep ) = case mbre of + Nothing -> ( current, [] ) + Just re -> partition (either error isJust . regexMatch re) current + writeTVar (procOutput p) keep + return ignore diff --git a/src/Process/Signal.hs b/src/Process/Signal.hs new file mode 100644 index 0000000..e57b68d --- /dev/null +++ b/src/Process/Signal.hs @@ -0,0 +1,88 @@ +module Process.Signal ( + Signal(..), + signalBuiltins, + signalProcess, +) where + +import Control.Monad.IO.Class + +import Data.Text (Text) +import Data.Text qualified as T + +import Script.Expr + +import System.Posix qualified as Posix + + +newtype Signal = Signal Posix.Signal + deriving (Eq, Ord) + +instance ExprType Signal where + textExprType _ = "Signal" + textExprValue (Signal sig) + | sig == Posix.sigHUP = "SIGHUP" + | sig == Posix.sigINT = "SIGINT" + | sig == Posix.sigQUIT = "SIGQUIT" + | sig == Posix.sigILL = "SIGILL" + | sig == Posix.sigTRAP = "SIGTRAP" + | sig == Posix.sigABRT = "SIGABRT" + | sig == Posix.sigBUS = "SIGBUS" + | sig == Posix.sigFPE = "SIGFPE" + | sig == Posix.sigKILL = "SIGKILL" + | sig == Posix.sigUSR1 = "SIGUSR1" + | sig == Posix.sigSEGV = "SIGSEGV" + | sig == Posix.sigUSR2 = "SIGUSR2" + | sig == Posix.sigPIPE = "SIGPIPE" + | sig == Posix.sigALRM = "SIGALRM" + | sig == Posix.sigTERM = "SIGTERM" + | sig == Posix.sigCHLD = "SIGCHLD" + | sig == Posix.sigCONT = "SIGCONT" + | sig == Posix.sigSTOP = "SIGSTOP" + | sig == Posix.sigTSTP = "SIGTSTP" + | sig == Posix.sigTTIN = "SIGTTIN" + | sig == Posix.sigTTOU = "SIGTTOU" + | sig == Posix.sigURG = "SIGURG" + | sig == Posix.sigXCPU = "SIGXCPU" + | sig == Posix.sigXFSZ = "SIGXFSZ" + | sig == Posix.sigVTALRM = "SIGVTALRM" + | sig == Posix.sigPROF = "SIGPROF" + | sig == Posix.sigPOLL = "SIGPOLL" + | sig == Posix.sigSYS = "SIGSYS" + | otherwise = "<SIG_" <> T.pack (show sig) <> ">" + + +signalBuiltins :: [ ( Text, SomeExpr ) ] +signalBuiltins = map (fmap $ SomeExpr . Pure) + [ ( "SIGHUP", Signal Posix.sigHUP ) + , ( "SIGINT", Signal Posix.sigINT ) + , ( "SIGQUIT", Signal Posix.sigQUIT ) + , ( "SIGILL", Signal Posix.sigILL ) + , ( "SIGTRAP", Signal Posix.sigTRAP ) + , ( "SIGABRT", Signal Posix.sigABRT ) + , ( "SIGBUS", Signal Posix.sigBUS ) + , ( "SIGFPE", Signal Posix.sigFPE ) + , ( "SIGKILL", Signal Posix.sigKILL ) + , ( "SIGUSR1", Signal Posix.sigUSR1 ) + , ( "SIGSEGV", Signal Posix.sigSEGV ) + , ( "SIGUSR2", Signal Posix.sigUSR2 ) + , ( "SIGPIPE", Signal Posix.sigPIPE ) + , ( "SIGALRM", Signal Posix.sigALRM ) + , ( "SIGTERM", Signal Posix.sigTERM ) + , ( "SIGCHLD", Signal Posix.sigCHLD ) + , ( "SIGCONT", Signal Posix.sigCONT ) + , ( "SIGSTOP", Signal Posix.sigSTOP ) + , ( "SIGTSTP", Signal Posix.sigTSTP ) + , ( "SIGTTIN", Signal Posix.sigTTIN ) + , ( "SIGTTOU", Signal Posix.sigTTOU ) + , ( "SIGURG", Signal Posix.sigURG ) + , ( "SIGXCPU", Signal Posix.sigXCPU ) + , ( "SIGXFSZ", Signal Posix.sigXFSZ ) + , ( "SIGVTALRM", Signal Posix.sigVTALRM ) + , ( "SIGPROF", Signal Posix.sigPROF ) + , ( "SIGPOLL", Signal Posix.sigPOLL ) + , ( "SIGSYS", Signal Posix.sigSYS ) + ] + + +signalProcess :: MonadIO m => Signal -> Posix.ProcessID -> m () +signalProcess (Signal sig) pid = liftIO $ Posix.signalProcess sig pid @@ -1,6 +1,7 @@ module Run ( module Run.Monad, runTest, + loadModules, evalGlobalDefs, ) where @@ -9,15 +10,17 @@ import Control.Concurrent import Control.Concurrent.STM 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 +29,25 @@ 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 Process.Signal import Run.Monad +import Sandbox 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 +58,10 @@ runTest out opts gdefs test = do createDirectoryIfMissing True testDir failedVar <- newTVarIO Nothing + objIdVar <- newMVar 1 + procIdVar <- newMVar 1 procVar <- newMVar [] + timeoutVar <- newMVar ( optTimeout opts, 0 ) mgdb <- if optGDB opts then flip runReaderT out $ do @@ -59,18 +73,22 @@ runTest out opts gdefs test = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teNextObjId = objIdVar + , teNextProcId = procIdVar , teProcesses = procVar + , teTimeout = timeoutVar , teGDB = fst <$> mgdb } tstate = TestState { tsGlobals = gdefs - , tsLocals = [] + , tsLocals = [ ( callStackVarName, SomeExpr $ Pure $ CallStack [] ) ] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty } - let sigHandler SignalInfo { siginfoSpecific = chld } = do + let sigHandler SignalInfo { siginfoSpecific = NoSignalSpecificInfo } = return () + sigHandler SignalInfo { siginfoSpecific = chld } = do processes <- readMVar procVar forM_ processes $ \p -> do mbpid <- either getPid (\_ -> return Nothing) (procHandle p) @@ -88,16 +106,29 @@ runTest out opts gdefs test = do oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing resetOutputTime out - res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do - withInternet $ \_ -> do - evalBlock =<< eval (testSteps test) - when (optWait opts) $ do - void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + testRunResult <- newEmptyMVar + + flip runReaderT out $ do + void $ outLine OutputGlobalInfo Nothing $ "Starting test ‘" <> testName test <> "’" + + void $ forkOS $ do + isolateFilesystem testDir >>= \case + True -> do + tres <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do + withInternet $ \_ -> do + runStep =<< eval (testSteps test) + when (optWait opts) $ do + void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + putMVar testRunResult tres + _ -> do + putMVar testRunResult ( Left Failed, [] ) + + ( res, [] ) <- takeMVar testRunResult 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 +136,55 @@ 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 OutputGlobalError 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) +evalGlobalDefs exprs = builtins `M.union` M.fromList exprs + +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 ] -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 + 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 killWith inner -> do case target of Left net -> withNode net (Right tvname) go Right node -> go node @@ -130,38 +193,44 @@ 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 - - SpawnShell (TypedVarName (VarName tname)) node script inner -> do + cmd = T.unwords $ T.pack tool : map escape args + escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" + outProcName OutputChildExec pname cmd + withProcess (Right node) pname killWith (T.unpack cmd) $ runStep . 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 + 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 stack line p expr timeout captures inner -> do + expect stack line p expr timeout captures $ runStep . inner Flush p regex -> do - flush p regex + mapM_ (outProc OutputIgnored p) =<< + atomicallyTest (flushProcessOutput p regex) - Guard line vars expr -> do - testStepGuard line vars expr + Guard stack expr -> do + testStepGuard stack 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..." @@ -171,11 +240,10 @@ withInternet :: (Network -> TestRun a) -> TestRun a withInternet inner = do testDir <- asks $ optTestDir . teOptions . fst inet <- newInternet testDir - res <- withNetwork (inetRoot inet) $ \net -> do - withTypedVar rootNetworkVar net $ do - inner net - delInternet inet - return res + flip finally (delInternet inet) $ do + withNetwork (inetRoot inet) $ \net -> do + withTypedVar rootNetworkVar net $ do + inner net withSubnet :: Network -> Maybe (TypedVarName Network) -> (Network -> TestRun a) -> TestRun a withSubnet parent tvname inner = do @@ -184,8 +252,8 @@ withSubnet parent tvname inner = do withNetwork :: Network -> (Network -> TestRun a) -> TestRun a withNetwork net inner = do - tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case - Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination) + tcpdump <- asks (optTcpdump . teOptions . fst) >>= return . \case + Just path -> withProcess (Left net) ProcNameTcpdump (Just (Signal softwareTermination)) (path ++ " -i br0 -w './br0.pcap' -U -Z root") . const Nothing -> id @@ -251,20 +319,16 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just ( | otherwise = fmap (x:) <$> tryMatch re xs tryMatch _ [] = Nothing -exprFailed :: Text -> SourceLine -> Maybe ProcName -> EvalTrace -> TestRun () -exprFailed desc sline pname exprVars = do +exprFailed :: Text -> CallStack -> Maybe ProcName -> TestRun () +exprFailed desc stack pname = do let prompt = maybe T.empty textProcName pname - outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", textSourceLine sline] - forM_ exprVars $ \((name, sel), value) -> - outLine OutputMatchFail (Just prompt) $ T.concat - [ " ", textFqVarName name, T.concat (map ("."<>) sel) - , " = ", textSomeVarValue sline value - ] + outLine (OutputMatchFail stack) (Just prompt) $ desc <> " failed" throwError Failed -expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun () -expect sline p (Traced trace re) tvars inner = do - timeout <- asks $ optTimeout . teOptions . fst +expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestRun ()) -> TestRun () +expect (CallStack cs) sline p (Traced trace re) etimeout tvars inner = do + let stack = CallStack (( sline, trace ) : cs) + timeout <- (etimeout *) <$> getCurrentTimeout delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do line <- readTVar (procOutput p) @@ -278,21 +342,14 @@ expect sline p (Traced trace re) tvars inner = do let vars = map (\(TypedVarName n) -> n) tvars when (length vars /= length capture) $ do - outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline + outProc (OutputMatchFail stack) p $ T.pack "mismatched number of capture variables" throwError Failed outProc OutputMatch p line inner capture - Nothing -> exprFailed (T.pack "expect") sline (Just $ procName p) trace - -flush :: Process -> Maybe Regex -> TestRun () -flush p mbre = do - atomicallyTest $ do - writeTVar (procOutput p) =<< case mbre of - Nothing -> return [] - Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p) + Nothing -> exprFailed (T.pack "expect") stack (Just $ procName p) -testStepGuard :: SourceLine -> EvalTrace -> Bool -> TestRun () -testStepGuard sline vars x = do - when (not x) $ exprFailed (T.pack "guard") sline Nothing vars +testStepGuard :: CallStack -> Bool -> TestRun () +testStepGuard stack x = do + when (not x) $ exprFailed (T.pack "guard") stack Nothing diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index e107017..f4444e8 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -7,6 +7,9 @@ module Run.Monad ( finally, forkTest, + forkTestUsing, + + getCurrentTimeout, ) where import Control.Concurrent @@ -14,6 +17,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,21 +29,30 @@ 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 + , teNextProcId :: MVar Int + , teProcesses :: MVar [ Process ] + , teTimeout :: MVar ( Scientific, Integer ) -- ( positive timeout, number of zero multiplications ) , teGDB :: Maybe (MVar GDB) } data TestState = TestState { tsGlobals :: GlobalDefs - , tsLocals :: [ ( VarName, SomeVarValue ) ] + , tsLocals :: [ ( VarName, SomeExpr ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific @@ -50,6 +63,7 @@ data TestOptions = TestOptions , optProcTools :: [(ProcName, String)] , optTestDir :: FilePath , optTimeout :: Scientific + , optTcpdump :: Maybe FilePath , optGDB :: Bool , optForce :: Bool , optKeep :: Bool @@ -62,6 +76,7 @@ defaultTestOptions = TestOptions , optProcTools = [] , optTestDir = ".test" , optTimeout = 1 + , optTcpdump = Nothing , optGDB = False , optForce = False , optKeep = False @@ -110,9 +125,19 @@ 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 () + +getCurrentTimeout :: TestRun Scientific +getCurrentTimeout = do + ( timeout, zeros ) <- liftIO . readMVar =<< asks (teTimeout . fst) + return $ if zeros > 0 then 0 + else timeout diff --git a/src/Sandbox.hs b/src/Sandbox.hs new file mode 100644 index 0000000..a05a455 --- /dev/null +++ b/src/Sandbox.hs @@ -0,0 +1,16 @@ +module Sandbox ( + isolateFilesystem, +) where + +import Foreign.C.String +import Foreign.C.Types + +import System.Directory + + +isolateFilesystem :: FilePath -> IO Bool +isolateFilesystem rwDir = do + absDir <- makeAbsolute rwDir + withCString absDir c_isolate_fs >>= return . (== 0) + +foreign import ccall unsafe "erebos_tester_isolate_fs" c_isolate_fs :: CString -> IO CInt diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs index ced807c..aae898a 100644 --- a/src/Script/Expr.hs +++ b/src/Script/Expr.hs @@ -8,6 +8,7 @@ module Script.Expr ( FunctionType, DynamicType, ExprType(..), SomeExpr(..), TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, + renameTypeVar, renameVarInType, VarValue(..), SomeVarValue(..), svvVariables, svvArguments, @@ -18,8 +19,9 @@ module Script.Expr ( anull, exprArgs, SomeArgumentType(..), ArgumentType(..), - Traced(..), EvalTrace, VarNameSelectors, gatherVars, + Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars, AppAnnotation(..), + callStackVarName, callStackFqVarName, module Script.Var, @@ -28,6 +30,7 @@ module Script.Expr ( ) where import Control.Monad +import Control.Monad.Except import Control.Monad.Reader import Data.Char @@ -53,12 +56,16 @@ import Util data Expr a where Let :: forall a b. ExprType b => SourceLine -> TypedVarName b -> Expr b -> Expr a -> Expr a Variable :: ExprType a => SourceLine -> FqVarName -> Expr a - DynVariable :: TypeVar -> SourceLine -> FqVarName -> Expr DynamicType - FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> FqVarName -> Expr (FunctionType a) + DynVariable :: SomeExprType -> SourceLine -> FqVarName -> Expr DynamicType + FunVariable :: ExprType a => SomeExprType -> SourceLine -> FqVarName -> Expr (FunctionType a) + OptVariable :: ExprType a => SourceLine -> FqVarName -> Expr (Maybe a) ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a) ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a) - FunctionEval :: ExprType a => Expr (FunctionType a) -> Expr a + FunctionEval :: ExprType a => SourceLine -> Expr (FunctionType a) -> Expr a + HideType :: forall a. Typeable a => SomeExprType -> Expr a -> Expr DynamicType + TypeLambda :: TypeVar -> SomeExprType -> (SomeExprType -> Expr DynamicType) -> Expr DynamicType + TypeApp :: forall a. ExprType a => Expr DynamicType -> SomeExprType -> Expr a LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b) Pure :: a -> Expr a App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b @@ -95,10 +102,14 @@ mapExpr f = go e@Variable {} -> f e e@DynVariable {} -> f e e@FunVariable {} -> f e + e@OptVariable {} -> f e ArgsReq args expr -> f $ ArgsReq args (go expr) ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr) FunctionAbstraction expr -> f $ FunctionAbstraction (go expr) - FunctionEval expr -> f $ FunctionEval (go expr) + FunctionEval sline expr -> f $ FunctionEval sline (go expr) + HideType stype expr -> HideType stype $ go expr + TypeLambda tvar stype efun -> TypeLambda tvar stype (go . efun) + TypeApp expr stype -> TypeApp (go expr) stype LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr) e@Pure {} -> f e App ann efun earg -> f $ App ann (go efun) (go earg) @@ -114,19 +125,19 @@ class MonadFail m => MonadEval m where askDictionary :: m VariableDictionary withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a -type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue +type GlobalDefs = Map ( ModuleName, VarName ) SomeExpr -type VariableDictionary = [ ( VarName, SomeVarValue ) ] +type VariableDictionary = [ ( VarName, SomeExpr ) ] -lookupVar :: MonadEval m => FqVarName -> m SomeVarValue +lookupVar :: MonadEval m => FqVarName -> m SomeExpr lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name -tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue) +tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeExpr) tryLookupVar (LocalVarName name) = lookup name <$> askDictionary tryLookupVar (GlobalVarName mname var) = M.lookup ( mname, var ) <$> askGlobalDefs withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a -withVar name value = withDictionary (( name, someConstValue value ) : ) +withVar name value = withDictionary (( name, SomeExpr (Pure value) ) : ) withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a withTypedVar (TypedVarName name) = withVar name @@ -138,49 +149,79 @@ isInternalVar (LocalVarName (VarName name)) | otherwise = False -newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a) - deriving (Functor, Applicative, Monad) + +newtype SimpleEval a = SimpleEval (ReaderT ( GlobalDefs, VariableDictionary ) (Except String) a) + deriving (Functor, Applicative, Monad, MonadError String) runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a -runSimpleEval (SimpleEval x) = curry $ runReader x +runSimpleEval (SimpleEval x) gdefs dict = either error id $ runExcept $ runReaderT x ( gdefs, dict ) + +trySimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> Maybe a +trySimpleEval (SimpleEval x) gdefs dict = either (const Nothing) Just $ runExcept $ runReaderT x ( gdefs, dict ) instance MonadFail SimpleEval where - fail = error . ("eval failed: " <>) + fail = throwError . ("eval failed: " <>) instance MonadEval SimpleEval where askGlobalDefs = SimpleEval (asks fst) askDictionary = SimpleEval (asks snd) withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner) +callStackVarName :: VarName +callStackVarName = VarName "$STACK" + +callStackFqVarName :: FqVarName +callStackFqVarName = LocalVarName callStackVarName + eval :: forall m a. MonadEval m => Expr a -> m a eval = \case Let _ (TypedVarName name) valExpr expr -> do val <- eval valExpr withVar name val $ eval expr - Variable sline name -> fromSomeVarValue sline name =<< lookupVar name + Variable _ name -> evalSomeExpr name =<< lookupVar name DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’" - FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name + FunVariable _ _ name -> evalSomeExpr name =<< lookupVar name + OptVariable _ name -> maybe (return Nothing) (fmap Just . evalSomeExpr name) =<< tryLookupVar name ArgsReq (FunctionArguments req) efun -> do gdefs <- askGlobalDefs dict <- askDictionary - return $ FunctionType $ \(FunctionArguments args) -> - let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req + return $ FunctionType $ \stack (FunctionArguments args) -> + let used = M.intersectionWith (\(SomeVarValue value) ( vname, _ ) -> ( vname, SomeExpr $ Pure $ vvFunction value (CallStack []) mempty )) args req FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict) - in fun $ FunctionArguments $ args `M.difference` req + in fun stack $ FunctionArguments $ args `M.difference` req ArgsApp eargs efun -> do FunctionType fun <- eval efun args <- mapM evalSome eargs - return $ FunctionType $ \args' -> fun (args <> args') + return $ FunctionType $ \stack args' -> fun stack (args <> args') FunctionAbstraction expr -> do - val <- eval expr - return $ FunctionType $ const val - FunctionEval efun -> do - FunctionType fun <- eval efun - return $ fun mempty + gdefs <- askGlobalDefs + dict <- askDictionary + return $ FunctionType $ \stack _ -> + runSimpleEval (eval expr) gdefs (( callStackVarName, SomeExpr (Pure stack) ) : filter ((callStackVarName /=) . fst) dict) + FunctionEval sline efun -> do + vars <- gatherVars efun + CallStack cs <- maybe (return $ CallStack []) (evalSomeExpr callStackFqVarName) =<< tryLookupVar callStackFqVarName + let cs' = CallStack (( sline, vars ) : cs) + FunctionType fun <- withVar callStackVarName cs' $ eval efun + return $ fun cs' mempty + HideType _ expr -> DynamicType <$> eval expr + TypeLambda _ _ f -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ DynamicType $ \t -> runSimpleEval (eval $ f t) gdefs dict + TypeApp expr stype -> do + DynamicType f <- eval expr + case cast f of + Just f' -> do + case f' stype of + DynamicType x -> case cast x of + Just x' -> return x' + n@Nothing -> fail $ "type error in type application result " <> show ( typeOf x, typeOf n ) + n@Nothing -> fail $ "type error in type application " <> show ( typeOf f, typeOf n ) LambdaAbstraction (TypedVarName name) expr -> do gdefs <- askGlobalDefs dict <- askDictionary - return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict) + return $ \x -> runSimpleEval (eval expr) gdefs (( name, SomeExpr $ Pure x ) : dict) Pure value -> return value App _ f x -> eval f <*> eval x Concat xs -> T.concat <$> mapM eval xs @@ -192,6 +233,13 @@ eval = \case Undefined err -> fail err Trace expr -> Traced <$> gatherVars expr <*> eval expr +evalSomeExpr :: forall m a. (MonadEval m, ExprType a) => FqVarName -> SomeExpr -> m a +evalSomeExpr name (SomeExpr (e :: Expr b)) = do + maybe (fail err) eval $ cast e + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable ‘", textFqVarName name, T.pack "’ has type type ", + textExprType @b Proxy ] + evalToVarValue :: MonadEval m => Expr a -> m (VarValue a) evalToVarValue expr = do VarValue @@ -205,7 +253,7 @@ evalFunToVarValue expr = do VarValue <$> gatherVars expr <*> pure (exprArgs expr) - <*> pure (const fun) + <*> pure fun evalSome :: MonadEval m => SomeExpr -> m SomeVarValue evalSome (SomeExpr expr) @@ -216,13 +264,13 @@ evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs [] -data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a) +data FunctionType a = FunctionType (CallStack -> FunctionArguments SomeVarValue -> a) instance ExprType a => ExprType (FunctionType a) where textExprType _ = "function type" textExprValue _ = "<function type>" -data DynamicType +data DynamicType = forall a. Typeable a => DynamicType a instance ExprType DynamicType where textExprType _ = "ambiguous type" @@ -236,41 +284,100 @@ newtype TypeVar = TypeVar Text data SomeExprType = forall a. ExprType a => ExprTypePrim (Proxy a) + | forall a. ExprTypeConstr1 a => ExprTypeConstr1 (Proxy a) | ExprTypeVar TypeVar - | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a) + | ExprTypeFunction SomeExprType SomeExprType + | ExprTypeArguments (FunctionArguments SomeArgumentType) + | ExprTypeApp SomeExprType [ SomeExprType ] + | ExprTypeForall TypeVar SomeExprType someExprType :: SomeExpr -> SomeExprType someExprType (SomeExpr expr) = go expr where go :: forall e. ExprType e => Expr e -> SomeExprType go = \case - DynVariable tvar _ _ -> ExprTypeVar tvar - (e :: Expr a) - | IsFunType <- asFunType e -> ExprTypeFunction (gof e) (proxyOfFunctionType e) - | otherwise -> ExprTypePrim (Proxy @a) - - gof :: forall e. ExprType e => Expr (FunctionType e) -> FunctionArguments SomeArgumentType - gof = \case - Let _ _ _ body -> gof body - Variable {} -> error "someExprType: gof: variable" - FunVariable params _ _ -> params - ArgsReq args body -> fmap snd args <> gof body - ArgsApp (FunctionArguments used) body -> - let FunctionArguments args = gof body - in FunctionArguments $ args `M.difference` used - FunctionAbstraction {} -> mempty - FunctionEval {} -> error "someExprType: gof: function eval" - Pure {} -> error "someExprType: gof: pure" - App {} -> error "someExprType: gof: app" - Undefined {} -> error "someExprType: gof: undefined" + DynVariable stype _ _ -> stype + e@(FunVariable args _ _) -> ExprTypeFunction args (ExprTypePrim (proxyOfFunctionType e)) + HideType stype _ -> stype + TypeLambda tvar stype _ -> ExprTypeForall tvar stype + + ArgsReq args inner -> exprTypeFunction (fmap snd args) (go inner) + ArgsApp (FunctionArguments used) inner + | ExprTypeFunction (ExprTypeArguments (FunctionArguments args)) x <- go inner + -> ExprTypeFunction (ExprTypeArguments (FunctionArguments (args `M.difference` used))) x + FunctionAbstraction inner -> exprTypeFunction mempty (go inner) + FunctionEval _ inner + | ExprTypeFunction _ x <- go inner -> x + + (_ :: Expr a) -> ExprTypePrim (Proxy @a) + + exprTypeFunction :: FunctionArguments SomeArgumentType -> SomeExprType -> SomeExprType + exprTypeFunction args (ExprTypeFunction (ExprTypeArguments args') inner) = ExprTypeFunction (ExprTypeArguments (args <> args')) inner + exprTypeFunction args inner = ExprTypeFunction (ExprTypeArguments args) inner proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a proxyOfFunctionType _ = Proxy + +renameTypeVar :: TypeVar -> TypeVar -> Expr a -> Expr a +renameTypeVar a b = go + where + go :: Expr e -> Expr e + go orig = case orig of + Let sline vname x y -> Let sline vname (go x) (go y) + Variable {} -> orig + DynVariable stype sline name -> DynVariable (renameVarInType a b stype) sline name + FunVariable {} -> orig + OptVariable {} -> orig + ArgsReq args body -> ArgsReq args (go body) + ArgsApp args fun -> ArgsApp (fmap (renameTypeVarInSomeExpr a b) args) (go fun) + FunctionAbstraction expr -> FunctionAbstraction (go expr) + FunctionEval sline expr -> FunctionEval sline (go expr) + HideType stype expr -> HideType (renameVarInType a b stype) (go expr) + TypeLambda tvar stype expr + | tvar == a -> orig + | tvar == b -> error "type var collision" + | otherwise -> TypeLambda tvar (renameVarInType a b stype) (go . expr) + TypeApp expr stype -> TypeApp (go expr) (renameVarInType a b stype) + LambdaAbstraction vname expr -> LambdaAbstraction vname (go expr) + Pure {} -> orig + App ann f x -> App ann (go f) (go x) + Concat xs -> Concat (map go xs) + Regex xs -> Regex (map go xs) + Undefined {} -> orig + Trace expr -> Trace (go expr) + +renameTypeVarInSomeExpr :: TypeVar -> TypeVar -> SomeExpr -> SomeExpr +renameTypeVarInSomeExpr a b (SomeExpr e) = SomeExpr (renameTypeVar a b e) + +renameVarInType :: TypeVar -> TypeVar -> SomeExprType -> SomeExprType +renameVarInType a b = go + where + go orig = case orig of + ExprTypePrim {} -> orig + ExprTypeConstr1 {} -> orig + ExprTypeVar tvar | tvar == a -> ExprTypeVar b + | otherwise -> orig + ExprTypeFunction args result -> ExprTypeFunction (go args) (go result) + ExprTypeArguments args -> ExprTypeArguments (fmap (\(SomeArgumentType atype stype) -> SomeArgumentType atype (go stype)) args) + ExprTypeApp c xs -> ExprTypeApp (go c) (map go xs) + ExprTypeForall tvar stype + | tvar == a -> orig + | tvar == b -> error "type var collision" + | otherwise -> ExprTypeForall tvar (go stype) + + textSomeExprType :: SomeExprType -> Text -textSomeExprType (ExprTypePrim p) = textExprType p -textSomeExprType (ExprTypeVar (TypeVar name)) = name -textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r +textSomeExprType = go [] + where + go _ (ExprTypePrim p) = textExprType p + go (x : _) (ExprTypeConstr1 c) = textExprTypeConstr1 c x + go [] (ExprTypeConstr1 _) = "<incomplte type>" + go _ (ExprTypeVar (TypeVar name)) = name + go _ (ExprTypeFunction _ r) = "function:" <> textSomeExprType r + go _ (ExprTypeArguments _) = "{…}" + go _ (ExprTypeApp c xs) = go (map textSomeExprType xs) c + go _ (ExprTypeForall (TypeVar name) ctype) = "∀" <> name <> "." <> go [] ctype data AsFunType a = forall b. (a ~ FunctionType b, ExprType b) => IsFunType @@ -289,7 +396,7 @@ asFunType = \case data VarValue a = VarValue { vvVariables :: EvalTrace , vvArguments :: FunctionArguments SomeArgumentType - , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a + , vvFunction :: CallStack -> FunctionArguments SomeVarValue -> a } data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a) @@ -303,33 +410,33 @@ svvArguments (SomeVarValue vv) = vvArguments vv someConstValue :: ExprType a => a -> SomeVarValue someConstValue = SomeVarValue . VarValue [] mempty . const . const -fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> VarValue a -> m a -fromConstValue sline name (VarValue _ args value :: VarValue b) = do +fromConstValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> VarValue a -> m a +fromConstValue stack name (VarValue _ args value :: VarValue b) = do maybe (fail err) return $ do guard $ anull args - cast $ value sline mempty + cast $ value stack mempty where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", if anull args then textExprType @b Proxy else "function type" ] -fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m a -fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do +fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> SomeVarValue -> m a +fromSomeVarValue stack name (SomeVarValue (VarValue _ args value :: VarValue b)) = do maybe (fail err) return $ do guard $ anull args - cast $ value sline mempty + cast $ value stack mempty where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", if anull args then textExprType @b Proxy else "function type" ] -textSomeVarValue :: SourceLine -> SomeVarValue -> Text -textSomeVarValue sline (SomeVarValue (VarValue _ args value)) - | anull args = textExprValue $ value sline mempty +textSomeVarValue :: SomeVarValue -> Text +textSomeVarValue (SomeVarValue (VarValue _ args value)) + | anull args = textExprValue $ value (CallStack []) mempty | otherwise = "<function>" someVarValueType :: SomeVarValue -> SomeExprType someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a)) | anull args = ExprTypePrim (Proxy @a) - | otherwise = ExprTypeFunction args (Proxy @a) + | otherwise = ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (Proxy @a)) newtype ArgumentKeyword = ArgumentKeyword Text @@ -345,31 +452,25 @@ exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType exprArgs = \case Let _ _ _ expr -> exprArgs expr Variable {} -> mempty - FunVariable args _ _ -> args + FunVariable (ExprTypeArguments args) _ _ -> args + FunVariable _ _ _ -> error "exprArgs: type-var args" ArgsReq args expr -> fmap snd args <> exprArgs expr ArgsApp (FunctionArguments applied) expr -> let FunctionArguments args = exprArgs expr in FunctionArguments (args `M.difference` applied) FunctionAbstraction {} -> mempty FunctionEval {} -> mempty + TypeApp {} -> error "exprArgs: type application" Pure {} -> error "exprArgs: pure" App {} -> error "exprArgs: app" Undefined {} -> error "exprArgs: undefined" -funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m (FunctionType a) -funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do - maybe (fail err) return $ do - FunctionType <$> cast (value sline) - where - err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has ", - (if anull args then "type " else "function type returting ") <> textExprType @b Proxy ] - -data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a) +data SomeArgumentType = SomeArgumentType ArgumentType SomeExprType -data ArgumentType a +data ArgumentType = RequiredArgument | OptionalArgument - | ExprDefault (Expr a) + | ExprDefault SomeExpr | ContextDefault @@ -377,6 +478,11 @@ data Traced a = Traced EvalTrace a type VarNameSelectors = ( FqVarName, [ Text ] ) type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ] +newtype CallStack = CallStack [ ( SourceLine, EvalTrace ) ] + +instance ExprType CallStack where + textExprType _ = T.pack "callstack" + textExprValue _ = T.pack "<callstack>" gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace gatherVars = fmap (uniqOn fst . sortOn fst) . helper @@ -384,25 +490,29 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper helper :: forall b. Expr b -> m EvalTrace helper = \case Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr - Variable _ var - | isInternalVar var -> return [] - | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + e@(Variable _ var) -> gatherLocalVar var e + e@(DynVariable _ _ var) -> gatherLocalVar var e + e@(FunVariable _ _ var) -> gatherLocalVar var e + e@(OptVariable _ var) -> gatherLocalVar var e ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr ArgsApp (FunctionArguments args) fun -> do v <- helper fun vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args return $ concat (v : vs) FunctionAbstraction expr -> helper expr - FunctionEval efun -> helper efun + FunctionEval _ efun -> helper efun + HideType _ expr -> helper expr + TypeLambda {} -> return [] + TypeApp expr _ -> helper expr LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr Pure _ -> return [] e@(App (AnnRecord sel) _ x) | Just (var, sels) <- gatherSelectors x -> do - val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e - return [ (( var, sels ++ [ sel ] ), val ) ] + gdefs <- askGlobalDefs + dict <- askDictionary + let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval e) gdefs dict + return $ catMaybes [ (( var, sels ++ [ sel ] ), ) <$> mbVal ] | otherwise -> do helper x App _ f x -> (++) <$> helper f <*> helper x @@ -411,6 +521,16 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper Undefined {} -> return [] Trace expr -> helper expr + gatherLocalVar :: forall b. ExprType b => FqVarName -> Expr b -> m EvalTrace + gatherLocalVar var expr + | GlobalVarName {} <- var = return [] + | isInternalVar var = return [] + | otherwise = do + gdefs <- askGlobalDefs + dict <- askDictionary + let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval expr) gdefs dict + return $ maybe [] (\x -> [ ( ( var, [] ), x ) ]) mbVal + gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] ) gatherSelectors = \case Variable _ var -> Just (var, []) diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs index 20a92b4..5bf8a4b 100644 --- a/src/Script/Expr/Class.hs +++ b/src/Script/Expr/Class.hs @@ -1,10 +1,13 @@ module Script.Expr.Class ( ExprType(..), + ExprTypeConstr1(..), + TypeDeconstructor(..), RecordSelector(..), ExprListUnpacker(..), ExprEnumerator(..), ) where +import Data.Kind import Data.Maybe import Data.Scientific import Data.Text (Text) @@ -16,6 +19,9 @@ class Typeable a => ExprType a where textExprType :: proxy a -> Text textExprValue :: a -> Text + matchTypeConstructor :: proxy a -> TypeDeconstructor a + matchTypeConstructor _ = NoTypeDeconstructor + recordMembers :: [(Text, RecordSelector a)] recordMembers = [] @@ -31,6 +37,13 @@ class Typeable a => ExprType a where exprEnumerator :: proxy a -> Maybe (ExprEnumerator a) exprEnumerator _ = Nothing +class (Typeable a, forall b. ExprType b => ExprType (a b)) => ExprTypeConstr1 (a :: Type -> Type) where + textExprTypeConstr1 :: proxy a -> Text -> Text + +data TypeDeconstructor a + = NoTypeDeconstructor + | forall c x. (ExprTypeConstr1 c, ExprType x, c x ~ a) => TypeDeconstructor1 (Proxy c) (Proxy x) + data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) @@ -39,6 +52,10 @@ data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (P data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) +instance ExprType () where + textExprType _ = "Unit" + textExprValue () = "()" + instance ExprType Integer where textExprType _ = T.pack "integer" textExprValue x = T.pack (show x) @@ -70,8 +87,22 @@ instance ExprType Void where textExprType _ = T.pack "void" textExprValue _ = T.pack "<void>" -instance ExprType a => ExprType [a] where - textExprType _ = "[" <> textExprType @a Proxy <> "]" +instance ExprType a => ExprType [ a ] where + textExprType _ = textExprTypeConstr1 @[] Proxy (textExprType @a Proxy) textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" + matchTypeConstructor _ = TypeDeconstructor1 Proxy Proxy exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) + +instance ExprTypeConstr1 [] where + textExprTypeConstr1 _ x = "[" <> x <> "]" + +instance ExprType a => ExprType (Maybe a) where + textExprType _ = textExprType @a Proxy <> "?" + textExprValue (Just x) = textExprValue x + textExprValue Nothing = "Nothing" + +instance (ExprType a, ExprType b) => ExprType (Either a b) where + textExprType _ = textExprType @a Proxy <> "|" <> textExprType @b Proxy + textExprValue (Left x) = "Left " <> textExprValue x + textExprValue (Right x) = "Right " <> textExprValue x diff --git a/src/Script/Object.hs b/src/Script/Object.hs new file mode 100644 index 0000000..7e60f80 --- /dev/null +++ b/src/Script/Object.hs @@ -0,0 +1,53 @@ +module Script.Object ( + ObjectId(..), + ObjectType(..), + Object(..), SomeObject(..), + toSomeObject, fromSomeObject, + destroySomeObject, +) where + +import Data.Kind +import Data.Text (Text) +import Data.Typeable + +import Script.Expr.Class + + +newtype ObjectId = ObjectId Int + +class Typeable a => ObjectType m a where + type ConstructorArgs a :: Type + type ConstructorArgs a = () + + textObjectType :: proxy (m a) -> proxy a -> Text + textObjectValue :: proxy (m a) -> a -> Text + + createObject :: ObjectId -> ConstructorArgs a -> m (Object m a) + destroyObject :: Object m a -> m () + +instance (Typeable m, ObjectType m a) => ExprType (Object m a) where + textExprType _ = textObjectType (Proxy @(m a)) (Proxy @a) + textExprValue = textObjectValue (Proxy @(m a)) . objImpl + + +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..2d1b82b 100644 --- a/src/Script/Shell.hs +++ b/src/Script/Shell.hs @@ -1,6 +1,9 @@ module Script.Shell ( - ShellStatement(..), ShellScript(..), + ShellStatement(ShellStatement), + ShellPipeline(ShellPipeline), + ShellCommand(ShellCommand), + ShellArgument(..), withShellProcess, ) where @@ -11,69 +14,198 @@ import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Reader +import Data.Maybe import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T + +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Marshal.Array +import Foreign.Storable import System.Exit +import System.FilePath import System.IO +import System.Posix.IO qualified as P +import System.Posix.Process +import System.Posix.Types import System.Process hiding (ShellCommand) import Network +import Network.Ip import Output import Process import Run.Monad +import Script.Expr.Class +import Script.Var + +newtype ShellScript = ShellScript [ ShellStatement ] data ShellStatement = ShellStatement - { shellCommand :: Text - , shellArguments :: [ Text ] + { shellPipeline :: ShellPipeline + , shellSourceLine :: SourceLine } -newtype ShellScript = ShellScript [ ShellStatement ] +data ShellPipeline = ShellPipeline + { pipeCommand :: ShellCommand + , pipeUpstream :: Maybe ShellPipeline + } + +data ShellCommand = ShellCommand + { cmdCommand :: Text + , cmdExtArguments :: [ ShellArgument ] + , cmdSourceLine :: SourceLine + } + +data ShellArgument + = ShellArgument Text + | ShellRedirectStdin Text + | ShellRedirectStdout Bool Text + | ShellRedirectStderr Bool Text + +cmdArguments :: ShellCommand -> [ Text ] +cmdArguments = catMaybes . map (\case ShellArgument x -> Just x; _ -> Nothing) . cmdExtArguments + +instance ExprType ShellScript where + textExprType _ = T.pack "ShellScript" + textExprValue _ = "<shell-script>" + +instance ExprType ShellStatement where + textExprType _ = T.pack "ShellStatement" + textExprValue _ = "<shell-statement>" +instance ExprType ShellPipeline where + textExprType _ = T.pack "ShellPipeline" + textExprValue _ = "<shell-pipeline>" -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 +instance ExprType ShellCommand where + textExprType _ = T.pack "ShellCommand" + textExprValue _ = "<shell-command>" + +instance ExprType ShellArgument where + textExprType _ = T.pack "ShellArgument" + textExprValue _ = "<shell-argument>" + + +data ShellExecInfo = ShellExecInfo + { seiNode :: Node + , seiProcName :: ProcName + , seiStatusVar :: MVar ExitCode + } + + +data HandleHandling + = CloseHandle Handle + | KeepHandle Handle + +closeIfRequested :: MonadIO m => HandleHandling -> m () +closeIfRequested (CloseHandle h) = liftIO $ hClose h +closeIfRequested (KeepHandle _) = return () + +handledHandle :: HandleHandling -> Handle +handledHandle (CloseHandle h) = h +handledHandle (KeepHandle h) = h + + +executeCommand :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellCommand -> TestRun () +executeCommand ShellExecInfo {..} pstdin pstdout pstderr scmd@ShellCommand {..} = do + let args = cmdArguments scmd + ( pstdin', pstdout', pstderr' ) <- (\f -> foldM f ( pstdin, pstdout, pstderr ) cmdExtArguments) $ \cur@( cin, cout, cerr ) -> \case + ShellRedirectStdin path -> do + closeIfRequested cin + h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) ReadMode + return ( CloseHandle h, cout, cerr ) + ShellRedirectStdout append path -> do + closeIfRequested cout + h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) $ if append then AppendMode else WriteMode + return ( cin, CloseHandle h, cerr ) + ShellRedirectStderr append path -> do + closeIfRequested cerr + h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) $ if append then AppendMode else WriteMode + return ( cin, cout, CloseHandle h ) + _ -> do + return cur + + pid <- liftIO $ do + (_, _, _, phandle) <- createProcess_ "shell" + (proc (T.unpack cmdCommand) (map T.unpack args)) + { std_in = UseHandle $ handledHandle pstdin' + , std_out = UseHandle $ handledHandle pstdout' + , std_err = UseHandle $ handledHandle pstderr' + , cwd = Just (nodeDir seiNode) + , env = Just [] + } + Just pid <- getPid phandle + return pid + + mapM_ closeIfRequested [ pstdin', pstdout', pstderr' ] + liftIO (getProcessStatus True False pid) >>= \case + Just (Exited ExitSuccess) -> do + return () + Just (Exited status) -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "failed at: " <> textSourceLine cmdSourceLine + liftIO $ putMVar seiStatusVar status + throwError Failed + Just (Terminated sig _) -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "killed with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine + liftIO $ putMVar seiStatusVar (ExitFailure (- fromIntegral sig)) + throwError Failed + Just (Stopped sig) -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "stopped with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine + liftIO $ putMVar seiStatusVar (ExitFailure (- fromIntegral sig)) + throwError Failed + Nothing -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "no exit status" + liftIO $ putMVar seiStatusVar (ExitFailure (- 1)) + throwError Failed + +executePipeline :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellPipeline -> TestRun () +executePipeline sei pstdin pstdout pstderr ShellPipeline {..} = do + case pipeUpstream of + Nothing -> do + executeCommand sei pstdin pstdout pstderr pipeCommand + + Just upstream -> do + ( pipeRead, pipeWrite ) <- createPipeCloexec + void $ forkTestUsing forkOS $ do + executePipeline sei pstdin (CloseHandle pipeWrite) (KeepHandle $ handledHandle pstderr) upstream + + executeCommand sei (CloseHandle pipeRead) pstdout (KeepHandle $ handledHandle pstderr) pipeCommand + closeIfRequested pstderr + +executeScript :: ShellExecInfo -> Handle -> Handle -> Handle -> ShellScript -> TestRun () +executeScript sei@ShellExecInfo {..} pstdin pstdout pstderr (ShellScript statements) = do + setNetworkNamespace $ getNetns seiNode + forM_ statements $ \ShellStatement {..} -> do + executePipeline sei (KeepHandle pstdin) (KeepHandle pstdout) (KeepHandle pstderr) shellPipeline + liftIO $ putMVar seiStatusVar ExitSuccess spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process spawnShell procNode procName script = do + idVar <- asks $ teNextProcId . fst + procId <- liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x )) + 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 + procIgnore <- liftIO $ newTVarIO ( 0, [] ) + seiStatusVar <- liftIO $ newEmptyMVar + ( pstdin, procStdin ) <- createPipeCloexec + ( hout, pstdout ) <- createPipeCloexec + ( herr, pstderr ) <- createPipeCloexec + procHandle <- fmap (Right . (, seiStatusVar)) $ forkTestUsing forkOS $ do + let seiNode = procNode + seiProcName = procName + executeScript ShellExecInfo {..} pstdin pstdout pstderr script + liftIO $ do + hClose pstdin + hClose pstdout + hClose pstderr let procKillWith = Nothing + let procPid = 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 - + startProcessIOLoops process hout herr return process withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a @@ -85,5 +217,19 @@ 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 + + +foreign import ccall "shell_pipe_cloexec" c_pipe_cloexec :: Ptr Fd -> IO CInt + +createPipeCloexec :: (MonadIO m, MonadFail m) => m ( Handle, Handle ) +createPipeCloexec = liftIO $ do + allocaArray 2 $ \ptr -> do + c_pipe_cloexec ptr >>= \case + 0 -> do + rh <- P.fdToHandle =<< peekElemOff ptr 0 + wh <- P.fdToHandle =<< peekElemOff ptr 1 + return ( rh, wh ) + _ -> do + fail $ "failed to create pipe" diff --git a/src/Script/Var.hs b/src/Script/Var.hs index 668060c..2c50101 100644 --- a/src/Script/Var.hs +++ b/src/Script/Var.hs @@ -9,6 +9,8 @@ module Script.Var ( import Data.Text (Text) import Data.Text qualified as T +import Script.Expr.Class + newtype VarName = VarName Text deriving (Eq, Ord) @@ -40,6 +42,10 @@ unqualifyName (LocalVarName name) = name newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName } deriving (Eq, Ord) +instance ExprType a => ExprType (TypedVarName a) where + textExprType _ = "TypedVarName" + textExprValue = textVarName . fromTypedVarName + newtype ModuleName = ModuleName [ Text ] deriving (Eq, Ord, Show) @@ -54,3 +60,7 @@ data SourceLine textSourceLine :: SourceLine -> Text textSourceLine (SourceLine text) = text textSourceLine SourceLineBuiltin = "<builtin>" + +instance ExprType SourceLine where + textExprType _ = "SourceLine" + textExprValue = textSourceLine diff --git a/src/Test.hs b/src/Test.hs index b8c5049..d16b997 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,23 +1,41 @@ module Test ( Test(..), + Tag(..), TestStep(..), TestBlock(..), + + MultiplyTimeout(..), ) where +import Control.Concurrent.MVar +import Control.Monad.Except +import Control.Monad.Reader + +import Data.Bifunctor import Data.Scientific -import Data.Text (Text) +import Data.Text (Text, pack) 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 ()) + , testTags :: [ Expr Tag ] + , testSteps :: Expr (TestStep ()) } +data Tag = Tag ModuleName VarName + +instance ExprType Tag where + textExprType _ = "Tag" + textExprValue (Tag mname vname) = "<tag:" <> textModuleName mname <> "." <> textVarName vname <> ">" + data TestBlock a where EmptyTestBlock :: TestBlock () TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a @@ -31,20 +49,51 @@ 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 ] -> Maybe Signal -> (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 :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ 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 + Guard :: CallStack -> Bool -> TestStep () + 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>" +instance ExprType a => ExprType (TestBlock a) where + textExprType _ = "TestBlock" + textExprValue _ = "<test-block>" + +instance ExprType a => ExprType (TestStep a) where + textExprType _ = "TestStep" + textExprValue _ = "<test-step>" + + +data MultiplyTimeout = MultiplyTimeout Scientific + +instance ObjectType TestRun MultiplyTimeout where + type ConstructorArgs MultiplyTimeout = Scientific + + textObjectType _ _ = "MultiplyTimeout" + textObjectValue _ (MultiplyTimeout x) = pack (show x) <> "@MultiplyTimeout" + + createObject oid timeout + | timeout >= 0 = do + var <- asks (teTimeout . fst) + liftIO $ modifyMVar_ var $ return . + (if timeout == 0 then second (+ 1) else first (* timeout)) + return $ Object oid $ MultiplyTimeout timeout + + | otherwise = do + outLine OutputError Nothing "timeout must not be negative" + throwError Failed + + destroyObject Object { objImpl = MultiplyTimeout timeout } = do + var <- asks (teTimeout . fst) + liftIO $ modifyMVar_ var $ return . + (if timeout == 0 then second (subtract 1) else first (/ timeout)) diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index 69579bc..32483d1 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -3,55 +3,73 @@ module Test.Builtins ( ) where import Data.Map qualified as M -import Data.Maybe +import Data.Proxy +import Data.Scientific import Data.Text (Text) -import Process (Process) +import Process +import Process.Signal import Script.Expr import Test builtins :: GlobalDefs -builtins = M.fromList - [ fq "send" builtinSend - , fq "flush" builtinFlush - , fq "guard" builtinGuard - , fq "wait" builtinWait +builtins = M.fromList $ concat + [ [ fq "send" builtinSend + , fq "flush" builtinFlush + , fq "ignore" builtinIgnore + , fq "guard" builtinGuard + , fq "multiply_timeout" builtinMultiplyTimeout + , fq "wait" builtinWait + ] + , map (uncurry fq) signalBuiltins ] where fq name impl = (( ModuleName [ "$" ], VarName name ), impl ) -getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a -getArg args = fromMaybe (error "parameter mismatch") . getArgMb args +biVar :: ExprType a => Text -> Expr a +biVar = Variable SourceLineBuiltin . LocalVarName . VarName -getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a -getArgMb (FunctionArguments args) kw = do - fromSomeVarValue SourceLineBuiltin (LocalVarName (VarName "")) =<< M.lookup kw args +biOpt :: ExprType a => Text -> Expr (Maybe a) +biOpt = OptVariable SourceLineBuiltin . LocalVarName . VarName -getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( FqVarName, [ Text ] ), SomeVarValue ) ] -getArgVars (FunctionArguments args) kw = do - maybe [] svvVariables $ M.lookup kw args +biArgs :: [ ( Maybe ArgumentKeyword, a ) ] -> FunctionArguments ( VarName, a ) +biArgs = FunctionArguments . M.fromList . map (\( kw, atype ) -> ( kw, ( VarName $ maybe "$0" (\(ArgumentKeyword tkw) -> "$" <> tkw) kw, atype ) )) -builtinSend :: SomeVarValue -builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing) +builtinSend :: SomeExpr +builtinSend = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Send <$> biVar "$to" <*> biVar "$0") where atypes = - [ ( Just "to", SomeArgumentType (ContextDefault @Process) ) - , ( Nothing, SomeArgumentType (RequiredArgument @Text) ) + [ ( Just "to", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) ) + , ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Text)) ) ] -builtinFlush :: SomeVarValue -builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlockStep EmptyTestBlock $ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) +builtinFlush :: SomeExpr +builtinFlush = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Flush <$> biVar "$from" <*> biOpt "$matching") where atypes = - [ ( Just "from", SomeArgumentType (ContextDefault @Process) ) - , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) ) + [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) ) + , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) ) ] -builtinGuard :: SomeVarValue -builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ - \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing) +builtinIgnore :: SomeExpr +builtinIgnore = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @IgnoreProcessOutput) <$> ((,) <$> biVar "$from" <*> biOpt "$matching")) + where + atypes = + [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) ) + , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) ) + ] + +builtinGuard :: SomeExpr +builtinGuard = SomeExpr $ + ArgsReq (biArgs [ ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Bool)) ) ]) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Guard <$> Variable SourceLineBuiltin callStackFqVarName <*> biVar "$0") + +builtinMultiplyTimeout :: SomeExpr +builtinMultiplyTimeout = SomeExpr $ ArgsReq (biArgs $ [ ( Just "by", SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Scientific)) ) ]) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @MultiplyTimeout) <$> biVar "$by") -builtinWait :: SomeVarValue -builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait +builtinWait :: SomeExpr +builtinWait = SomeExpr $ Pure $ TestBlockStep EmptyTestBlock Wait diff --git a/src/TestMode.hs b/src/TestMode.hs index ab938e6..33f2493 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 "/bin/true" $ 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" @@ -9,8 +9,11 @@ #include <sched.h> #include <stdbool.h> #include <stdio.h> +#include <stdlib.h> #include <string.h> #include <sys/mount.h> +#include <sys/stat.h> +#include <sys/syscall.h> #include <unistd.h> /* @@ -45,9 +48,15 @@ static bool writeProcSelfFile( const char * file, const char * data, size_t size int main( int argc, char * argv[] ) { + int ret; + uid_t uid = geteuid(); gid_t gid = getegid(); - unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS ); + ret = unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS ); + if( ret < 0 ){ + fprintf( stderr, "unsharing user, network and mount namespaces failed: %s\n", strerror( errno )); + return 1; + } char buf[ 256 ]; int len; @@ -71,7 +80,70 @@ int main( int argc, char * argv[] ) if ( ! writeProcSelfFile( "gid_map", buf, len ) ) return 1; - mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" ); + /* + * Prepare for future filesystem isolation within additional mount namespace: + * - clone whole mount tree as read-only under new /tmp/new_root + * - keep writable /proc and /tmp + */ + + ret = mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" ); + if( ret < 0 ){ + fprintf( stderr, "failed to mount tmpfs on /run: %s\n", strerror( errno )); + return 1; + } + + ret = mkdir( "/run/new_root", 0700 ); + if( ret < 0 ){ + fprintf( stderr, "failed to create new_root directory: %s\n", strerror( errno )); + return 1; + } + + ret = mount( "/", "/run/new_root", NULL, MS_BIND | MS_REC, NULL ); + if( ret < 0 ){ + fprintf( stderr, "failed to bind-mount / on new_root: %s\n", strerror( errno )); + return 1; + } + + struct mount_attr * attr_ro = &( struct mount_attr ) { + .attr_set = MOUNT_ATTR_RDONLY, + }; + ret = mount_setattr( -1, "/run/new_root", AT_RECURSIVE, attr_ro, sizeof( * attr_ro ) ); + if( ret < 0 ){ + fprintf( stderr, "failed set sandbox root as read-only: %s\n", strerror( errno )); + return 1; + } + + struct mount_attr * attr_rw = &( struct mount_attr ) { + .attr_clr = MOUNT_ATTR_RDONLY, + }; + ret = mount_setattr( -1, "/run/new_root/proc", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) ); + if( ret < 0 ){ + fprintf( stderr, "failed set sandbox /proc as read-write: %s\n", strerror( errno )); + return 1; + } + ret = mount_setattr( -1, "/run/new_root/tmp", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) ); + if( ret < 0 ){ + if( errno == EINVAL ){ + // Original /tmp is not a separate filesystem, so we can't just change the attributes + ret = mount( "/tmp", "/run/new_root/tmp", NULL, MS_BIND, NULL ); + if( ret < 0 ) + fprintf( stderr, "failed to bind-mount original /tmp in sandbox as read-write: %s\n", strerror( errno )); + } else { + fprintf( stderr, "failed set sandbox /tmp as read-write: %s\n", strerror( errno )); + } + } + + ret = mount( "tmpfs", "/run/new_root/run", "tmpfs", 0, "size=4m" ); + if( ret < 0 ){ + fprintf( stderr, "failed to mount tmpfs on sandbox /run: %s\n", strerror( errno )); + return 1; + } + + ret = mkdir( "/run/new_root/run/old_root", 0700 ); + if( ret < 0 ){ + fprintf( stderr, "failed to create old_root directory: %s\n", strerror( errno )); + return 1; + } hs_init( &argc, &argv ); testerMain(); @@ -79,3 +151,53 @@ int main( int argc, char * argv[] ) return 0; } + +/* + * - Replace filesystem hierarchy with read-only version, + * - bind-mound rwdir from writable tree, and + * - keep writeable /tmp from host. + */ +int erebos_tester_isolate_fs( const char * rwdir ) +{ + int ret; + + ret = unshare( CLONE_NEWNS ); + if( ret < 0 ){ + fprintf( stderr, "unsharing mount namespace failed: %s\n", strerror( errno )); + return -1; + } + + char * cwd = getcwd( NULL, 0 ); + ret = syscall( SYS_pivot_root, "/run/new_root", "/run/new_root/run/old_root" ); + if( ret < 0 ){ + fprintf( stderr, "failed to pivot_root: %s\n", strerror( errno )); + free( cwd ); + return -1; + } + + char oldrwdir[ strlen(rwdir) + 15 ]; + snprintf( oldrwdir, sizeof oldrwdir, "/run/old_root/%s", rwdir ); + ret = mount( oldrwdir, rwdir, NULL, MS_BIND, NULL ); + if( ret < 0 ){ + fprintf( stderr, "failed to bind-mount %s on %s: %s\n", oldrwdir, rwdir, strerror( errno )); + free( cwd ); + return -1; + } + + ret = umount2( "/run/old_root", MNT_DETACH ); + if( ret < 0 ){ + fprintf( stderr, "failed to detach /run/old_root: %s\n", strerror( errno )); + free( cwd ); + return -1; + } + + ret = chdir( cwd ); + if( ret < 0 ){ + fprintf( stderr, "failed to chdir to %s: %s\n", cwd, strerror( errno )); + free( cwd ); + return -1; + } + free( cwd ); + + return 0; +} diff --git a/src/shell.c b/src/shell.c new file mode 100644 index 0000000..d832078 --- /dev/null +++ b/src/shell.c @@ -0,0 +1,8 @@ +#define _GNU_SOURCE +#include <fcntl.h> +#include <unistd.h> + +int shell_pipe_cloexec( int pipefd[ 2 ] ) +{ + return pipe2( pipefd, O_CLOEXEC ); +} diff --git a/test/asset/output/flush.et b/test/asset/output/flush.et new file mode 100644 index 0000000..0051dfd --- /dev/null +++ b/test/asset/output/flush.et @@ -0,0 +1,13 @@ +test Test: + node n + shell on n as p: + echo a + echo b + echo c + echo d + echo e + with p: + expect /e/ + flush matching /[b-z]/ + expect /.*/ + expect /.*/ timeout 0.0 diff --git a/test/asset/output/ignore.et b/test/asset/output/ignore.et new file mode 100644 index 0000000..cc70e3b --- /dev/null +++ b/test/asset/output/ignore.et @@ -0,0 +1,20 @@ +test Test: + node n + shell on n as p: + echo a + echo b + echo c + echo d + grep -q . + echo e + echo F + echo g + echo H + with p: + expect /d/ + ignore matching /[b-z]/ + send "x" + expect /.*/ + expect /H/ + expect /F/ + expect /.*/ timeout 0.0 diff --git a/test/asset/parser/function-fail.et b/test/asset/parser/function-fail.et new file mode 100644 index 0000000..59ac3b0 --- /dev/null +++ b/test/asset/parser/function-fail.et @@ -0,0 +1,2 @@ +test Test: + guard 1 == 1 diff --git a/test/asset/parser/function.et b/test/asset/parser/function.et new file mode 100644 index 0000000..2a096b9 --- /dev/null +++ b/test/asset/parser/function.et @@ -0,0 +1,16 @@ +def f (x) and y = (x + y) + 1 + +def g (x) and y = (x + (y+1)) + +test Test: + guard (1 == 1) + guard (1 /= 2) + let x = 2 + guard (x == x) + guard (x /= 1) + guard (x /= x + 1) + + guard (f 1 and 2 == 4) + guard (f 1 and 2 == g 1 and 2) + guard (f 1 and (g 2 and 3) == g 1 and 2 + 4) + guard (f (10 + g and 1 1) and (g 2 and 3) == g 1 and 2 + 10 +6) diff --git a/test/asset/run-fail/bool.et b/test/asset/run-fail/bool.et new file mode 100644 index 0000000..1608a08 --- /dev/null +++ b/test/asset/run-fail/bool.et @@ -0,0 +1,3 @@ +test Test: + node n + guard (True == False) diff --git a/test/asset/run-fail/command-ignore.et b/test/asset/run-fail/command-ignore.et new file mode 100644 index 0000000..9622782 --- /dev/null +++ b/test/asset/run-fail/command-ignore.et @@ -0,0 +1,13 @@ +test Test: + node n + shell on n as p: + cat + + send "a" to p + send "b" to p + send "x" to p + expect /x/ from p + ignore from p + + multiply_timeout by 0.0 + expect /.*/ from p diff --git a/test/asset/run-success/bool.et b/test/asset/run-success/bool.et new file mode 100644 index 0000000..7121cc0 --- /dev/null +++ b/test/asset/run-success/bool.et @@ -0,0 +1,7 @@ +test Test: + node n + guard (True == True) + guard (False == False) + guard (False /= True) + guard ((1 == 1) == True) + guard ((1 == 0) == False) diff --git a/test/asset/run-success/command-flush.et b/test/asset/run-success/command-flush.et new file mode 100644 index 0000000..8c5f7b8 --- /dev/null +++ b/test/asset/run-success/command-flush.et @@ -0,0 +1,30 @@ +def expect_next from p (str): + expect /(.*)/ from p capture line + guard (line == str) + +test Test: + node n + shell on n as p: + cat + + send "a1" to p + send "b" to p + send "x" to p + expect /x/ from p + + flush from p matching /a.*/ + send "a2" to p + send "c" to p + + expect_next "b" from p + expect_next "a2" from p + expect_next "c" from p + + send "d" to p + send "e" to p + send "f" to p + send "x" to p + expect /x/ from p + flush from p + send "g" to p + expect_next "g" from p diff --git a/test/asset/run-success/command-ignore.et b/test/asset/run-success/command-ignore.et new file mode 100644 index 0000000..dc950d1 --- /dev/null +++ b/test/asset/run-success/command-ignore.et @@ -0,0 +1,39 @@ +def expect_next from p (str): + expect /(.*)/ from p capture line + guard (line == str) + +test Test: + node n + shell on n as p: + cat + + send "a" to p + send "b" to p + send "x" to p + expect /x/ from p + + ignore from p matching /a/ + send "a" to p + send "c" to p + + expect_next "b" from p + expect_next "c" from p + + send "a" to p + send "b" to p + with p: + send "c" + ignore matching /[bcd]/ + send "d" + send "e" + expect_next "e" from p + + send "a" to p + send "b" to p + local: + send "c" to p + send "d" to p + + expect_next "b" from p + expect_next "c" from p + expect_next "d" from p diff --git a/test/asset/run/callstack.et b/test/asset/run/callstack.et new file mode 100644 index 0000000..36eb401 --- /dev/null +++ b/test/asset/run/callstack.et @@ -0,0 +1,41 @@ +test AG: + let x = 1 + guard (x == 0) + +test AE: + spawn as p + let x = 2 + expect /$x/ from p timeout 0.0 + +def fg: + let x = 1 + guard (x == 0) + +test BG: + fg + +def gg (x): + let y = 2 + guard (x == y) + +test CG: + let z = 3 + gg (z) + +def fe on p: + let x = 1 + expect /$x/ from p timeout 0.0 + +test BE: + spawn as p + fe on p + +def ge (x) on p: + guard (x /= 0) + let y = 2 + expect /$x $y/ from p timeout 0.0 + +test CE: + spawn as p + let z = 3 + ge (z) on p diff --git a/test/asset/run/echo.et b/test/asset/run/echo.et new file mode 100644 index 0000000..9950d7b --- /dev/null +++ b/test/asset/run/echo.et @@ -0,0 +1,4 @@ +test ExpectEcho: + spawn as p + send "abcdef" to p + expect /abcdef/ from p diff --git a/test/asset/run/erebos-tester.yaml b/test/asset/run/erebos-tester.yaml new file mode 100644 index 0000000..937ca97 --- /dev/null +++ b/test/asset/run/erebos-tester.yaml @@ -0,0 +1,2 @@ +tests: ./scripts/**/*.et +tool: ./tools/tool diff --git a/test/asset/run/sysinfo.et b/test/asset/run/sysinfo.et new file mode 100644 index 0000000..1b9f6aa --- /dev/null +++ b/test/asset/run/sysinfo.et @@ -0,0 +1,12 @@ +test SysInfo: + node n + spawn on n as p1 + with p1: + send "network-info" + expect /ip ${n.ifname} ${n.ip}/ + + spawn as p2 + guard (p2.node.ip /= p1.node.ip) + with p2: + send "network-info" + expect /ip ${n.ifname} ${p2.node.ip}/ diff --git a/test/asset/run/tools/echo.sh b/test/asset/run/tools/echo.sh new file mode 100755 index 0000000..53b1eae --- /dev/null +++ b/test/asset/run/tools/echo.sh @@ -0,0 +1,2 @@ +#!/bin/sh +cat diff --git a/test/asset/run/tools/sysinfo.sh b/test/asset/run/tools/sysinfo.sh new file mode 100755 index 0000000..38591f4 --- /dev/null +++ b/test/asset/run/tools/sysinfo.sh @@ -0,0 +1,9 @@ +#!/bin/sh + +while read cmd; do + case "$cmd" in + network-info) + ip -o addr show | sed -e 's/[0-9]*: \([a-z0-9]*\).*inet6\? \([0-9a-f:.]*\).*/ip \1 \2/' + ;; + esac +done diff --git a/test/asset/run/trivial.et b/test/asset/run/trivial.et new file mode 100644 index 0000000..0b2e878 --- /dev/null +++ b/test/asset/run/trivial.et @@ -0,0 +1,7 @@ +test AlwaysSucceeds: + node n + guard (1 == 1) + +test AlwaysFails: + node n + guard (1 == 0) diff --git a/test/asset/shell/echo.et b/test/asset/shell/echo.et new file mode 100644 index 0000000..1e48cac --- /dev/null +++ b/test/asset/shell/echo.et @@ -0,0 +1,25 @@ +test Echo: + node n + let echo_str = "echo" + let space_str = "a b" + + shell on n as sh: + echo a b c + echo "a b c" + echo 'a b d' + echo a b " c d" + + /bin/echo "abcd" xyz + "echo" a"a" "b"c d + $echo_str b $echo_str c + + echo "$space_str" + echo $space_str + echo '$space_str' + + echo \$ \" \\ + echo "\""\""a" + echo "'" '"' '\\\' "\\" + echo a\ b\ \ c + + echo \" \' \\ \$ \# \| \> \< \; \[ \] \{ \} \( \) \* \? \~ \& \! diff --git a/test/asset/shell/pipe.et b/test/asset/shell/pipe.et new file mode 100644 index 0000000..a00360a --- /dev/null +++ b/test/asset/shell/pipe.et @@ -0,0 +1,25 @@ +test Pipe: + node n + shell on n as sh: + echo abcd | grep -o '[bc]*' + echo abcd | grep -o '[bcd]*' | grep -o '[ab]*' + + +test Redirect: + node n + shell on n as sh: + echo a > file + echo b > file + echo c >> file + echo x + cat file + echo y + cat < file + echo z + +test PipeRedirect: + node n + shell on n as sh: + echo abcdefghi | grep -o '[b-h]*' | grep -o '[a-g]*' > file + cat < file | grep -o '[acegi]' | cat > file2 + cat file2 - < file diff --git a/test/asset/shell/spawn.et b/test/asset/shell/spawn.et new file mode 100644 index 0000000..9d48e72 --- /dev/null +++ b/test/asset/shell/spawn.et @@ -0,0 +1,13 @@ +test ShellTrue: + node n + shell on n: + true + + shell on n as sh: + true + + +test ShellFalse: + node n + shell on n as sh: + false diff --git a/test/script/definition.et b/test/script/definition.et index d2da737..3d84040 100644 --- a/test/script/definition.et +++ b/test/script/definition.et @@ -10,6 +10,7 @@ test Definition: expect /load-done/ send "run Test" + expect /global-info - Starting test ‘Test’/ expect /child-stdout p 4/ expect /match p 4/ expect /child-stdout p 11/ diff --git a/test/script/output.et b/test/script/output.et new file mode 100644 index 0000000..d3f0eea --- /dev/null +++ b/test/script/output.et @@ -0,0 +1,55 @@ +module output + +asset scripts: + path: ../asset/output + +test FlushOutput: + spawn as p + with p: + send "load ${scripts.path}/flush.et" + expect /load-done/ + + send "run Test" + expect /child-stdout p a/ + expect /child-stdout p b/ + expect /child-stdout p c/ + expect /child-stdout p d/ + expect /child-stdout p e/ + expect /match p e/ + expect /ignored p b/ + expect /ignored p c/ + expect /ignored p d/ + expect /match p a/ + expect /match-fail expect.*/ + + expect /(run-.*)/ capture done + guard (done == "run-failed") + +test IgnoreOutput: + spawn as p + with p: + send "load ${scripts.path}/ignore.et" + expect /load-done/ + + send "run Test" + expect /child-stdout p a/ + expect /child-stdout p b/ + expect /child-stdout p c/ + expect /child-stdout p d/ + expect /child-stdin p x/ + expect /child-stdout p e/ + expect /child-stdout p F/ + expect /child-stdout p g/ + expect /child-stdout p H/ + expect /match p d/ + expect /ignored p b/ + expect /ignored p c/ + expect /match p a/ + expect /ignored p e/ + expect /match p H/ + expect /ignored p g/ + expect /match p F/ + expect /match-fail expect.*/ + + expect /(run-.*)/ capture done + guard (done == "run-failed") diff --git a/test/script/parser.et b/test/script/parser.et index 554e345..1a00bc8 100644 --- a/test/script/parser.et +++ b/test/script/parser.et @@ -11,3 +11,9 @@ test Parser: send "load ${scripts.path}/indent.et" expect /load-done/ + + send "load ${scripts.path}/function.et" + expect /load-done/ + + send "load ${scripts.path}/function-fail.et" + expect /load-failed parse-error/ diff --git a/test/script/run.et b/test/script/run.et new file mode 100644 index 0000000..2572f87 --- /dev/null +++ b/test/script/run.et @@ -0,0 +1,195 @@ +module run + +asset scripts: + path: ../asset/run + +asset scripts_success: + path: ../asset/run-success + +asset scripts_fail: + path: ../asset/run-fail + + +test TrivialRun: + spawn as p + with p: + send "load ${scripts.path}/trivial.et" + expect /load-done/ + + send "run AlwaysSucceeds" + local: + expect /(run-.*)/ capture done + guard (done == "run-done") + + send "run AlwaysFails" + local: + expect /match-fail .*/ + expect /(run-.*)/ capture done + guard (done == "run-failed") + + +test SimpleRun: + let should_succeed = [ "bool", "command-flush", "command-ignore" ] + let should_fail = [ "bool", "command-ignore" ] + spawn as p + + with p: + for file in should_succeed: + send "load ${scripts_success.path}/$file.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run Test" + local: + expect /(run-.*)/ capture done + guard (done == "run-done") + flush + + for file in should_fail: + send "load ${scripts_fail.path}/$file.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run Test" + local: + expect /(run-.*)/ capture done + guard (done == "run-failed") + flush + + +test RunConfig: + node n + local: + shell on n: + cp ${scripts.path}/erebos-tester.yaml . + mkdir tools + cp ${scripts.path}/tools/echo.sh ./tools/tool + mkdir scripts + cp ${scripts.path}/trivial.et ./scripts/ + cp ${scripts.path}/echo.et ./scripts/ + + spawn as p on n + + with p: + send "load-config" + expect /load-config-done/ + send "run-all" + expect /run-test-result AlwaysSucceeds done/ + expect /run-test-result AlwaysFails failed/ + expect /child-stdin p abcdef/ + expect /child-stdout p abcdef/ + expect /match p abcdef/ + expect /run-test-result ExpectEcho done/ + expect /run-all-done/ + + +test GetSysInfo: + node n + local: + shell on n: + cp ${scripts.path}/erebos-tester.yaml . + mkdir tools + cp ${scripts.path}/tools/sysinfo.sh ./tools/tool + mkdir scripts + cp ${scripts.path}/sysinfo.et ./scripts/ + + spawn as p on n + + with p: + send "load-config" + expect /load-config-done/ + send "run SysInfo" + expect /run-done/ + + +test CallStack: + spawn as p + with p: + send "load ${scripts.path}/callstack.et" + expect /load-done/ + + send "run AG" + expect /match-fail guard failed/ + expect /match-fail-line .*\/callstack.et:3:5: .*/ + expect /match-fail-var x 1/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /(run-.*)/ capture done + guard (done == "run-failed") + flush + + send "run AE" + expect /match-fail expect failed/ + expect /match-fail-line .*\/callstack.et:8:5: .*/ + expect /match-fail-var x 2/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /(run-.*)/ capture done + guard (done == "run-failed") + flush + + send "run BG" + expect /match-fail guard failed/ + expect /match-fail-line .*\/callstack.et:12:5: .*/ + expect /match-fail-var x 1/ + expect /match-fail-line .*\/callstack.et:15:5: .*/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /(run-.*)/ capture done + guard (done == "run-failed") + flush + + send "run CG" + expect /match-fail guard failed/ + expect /match-fail-line .*\/callstack.et:19:5: .*/ + expect /match-fail-var x 3/ + expect /match-fail-var y 2/ + expect /match-fail-line .*\/callstack.et:23:5: .*/ + expect /match-fail-var z 3/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /(run-.*)/ capture done + guard (done == "run-failed") + flush + + send "run BE" + expect /match-fail expect failed/ + expect /match-fail-line .*\/callstack.et:27:5: .*/ + expect /match-fail-var x 1/ + expect /match-fail-line .*\/callstack.et:31:5: .*/ + expect /match-fail-var p <process:p#[0-9]+>/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /(run-.*)/ capture done + guard (done == "run-failed") + flush + + send "run CE" + expect /match-fail expect failed/ + expect /match-fail-line .*\/callstack.et:36:5: .*/ + expect /match-fail-var x 3/ + expect /match-fail-var y 2/ + expect /match-fail-line .*\/callstack.et:41:5: .*/ + expect /match-fail-var p <process:p#[0-9]+>/ + expect /match-fail-var z 3/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /(run-.*)/ capture done + guard (done == "run-failed") + flush diff --git a/test/script/shell.et b/test/script/shell.et new file mode 100644 index 0000000..282df37 --- /dev/null +++ b/test/script/shell.et @@ -0,0 +1,100 @@ +asset scripts: + path: ../asset/shell + + +test ShellSpawn: + spawn as p + with p: + send "load ${scripts.path}/spawn.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run-all" + expect /run-test-result ShellTrue done/ + expect /child-fail sh failed at: .*: false/ + expect /child-fail sh exit code: 1/ + expect /run-test-result ShellFalse failed/ + expect /run-all-done/ + + +def expect_next_stdout from p (expected): + expect from p /child-stdout sh (.*)/ capture line + guard (line == expected) + +test ShellEcho: + spawn as p + with p: + send "load ${scripts.path}/echo.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run-all" + + expect_next_stdout from p: + "a b c" + "a b c" + "a b d" + "a b c d" + + "abcd xyz" + "aa bc d" + "b echo c" + + "a b" + "a b" + "\$space_str" + + "\$ \" \\" + "\"\"a" + "' \" \\\\\\ \\" + "a b c" + + "\" ' \\ \$ # | > < ; [ ] { } ( ) * ? ~ & !" + + with p: + expect /run-test-result Echo done/ + expect /run-all-done/ + + +test ShellPipe: + spawn as p + with p: + send "load ${scripts.path}/pipe.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run-all" + + expect_next_stdout from p: + "bc" + "b" + with p: + expect /run-test-result Pipe done/ + + expect_next_stdout from p: + "x" + "b" + "c" + "y" + "b" + "c" + "z" + with p: + expect /run-test-result Redirect done/ + + expect_next_stdout from p: + "c" + "e" + "g" + "bcdefg" + with p: + expect /run-test-result PipeRedirect done/ + + with p: + expect /run-all-done/ |