diff options
54 files changed, 2757 insertions, 886 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 74ef7be..bdfbc83 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,39 @@ # Revision history for erebos-tester +## 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 + +## 0.3.0 -- 2025-02-28 + +* User-defined functions +* Modules, exports and imports +* Added `ifname` member to the `node` type +* Added `>`, `>=`, `<=` and `<` operators for numbers +* Change "flush" command to take regex argument via "matching" keyword +* Change working directory of spawned process to node directory +* Use custom C main instead of wrapper binary for unshare(2) call. +* Fix regex check in flush command +* Time information in output +* Support for GHC up to 9.12 +* Fail when test requested on command-line is not found + ## 0.2.4 -- 2024-08-13 * Fix build with mtl-2.3 @@ -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 @@ -178,8 +192,11 @@ and used by `spawn` or network configuration commands. Members: +`ifname` +: Name of the primary network interface of the node. + `ip` -: String representation of node's IP address. +: String representation of the node primary IP address. `network` : The network which the node belogs to. @@ -193,6 +210,15 @@ Members: `node` : Node on which the process is running. +#### asset + +Represents an asset (file or directory), which can be used during test execution. + +Members: + +`path` +: Path to the asset valid during the test execution. + #### list Lists are written using bracket notation: @@ -204,7 +230,7 @@ List elements can be of any type, but all elements of a particular list must hav Used in the `for` command. -### Build-in commands +### Built-in commands ``` subnet <name> [of <network>] @@ -219,11 +245,12 @@ 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>] ``` Spawn a new test process on `<node>` or `<network>` (or one from context) and assign the new process to variable `<name>`. When spawning on network, create a new node for this process. +Extra `<arguments>` to the tool can be given as a list of strings using the `args` keyword. The process is terminated when the variable `<name>` goes out of scope (at the end of the block in which it was created) by closing its stdin. When the process fails to terminate successfully within a timeout, the test fails. @@ -255,6 +282,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> ``` @@ -310,6 +346,13 @@ 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 ``` @@ -370,6 +413,89 @@ parentheses: def twice (x) = 2 * x ``` +### Modules, exports and imports + +Each test script file constitutes a module. As such, it can export definitions +for other modules to use, and import definitions from other modules. The name +of each module must match the filename with the file extension removed, and is +given using the `module` declaration. This declaration, if present, must be +given at the beginning of the file, before other declarations. + +For example a file `test/foo.et` can start with: +``` +module foo +``` +This name is also implicitly assigned when the `module` declaration is omitted. + +In case of a more complex hierarchy, individual parts are separated with `.` +and must match names of parent directories. E.g. a file `test/bar/baz.et` +can start with: + +``` +module bar.baz +``` + +Such declared hierarchy is then used to determine the root of the project in +order to find imported modules. + +To export a definition from module, use `export` keyword before `def`: +``` +export def say_hello to p: + send "hello" to p + expect /hi/ from p +``` +or list the exported name in a standalone export declaration: +``` +export say_hello + +... + +def say_hello to p: + send "hello" to p + expect /hi/ from p +``` + +To import module, use `import <name>` statement, which makes all the exported +definitions from the module `<name>` available in the local scope. +``` +module bar.baz + +import foo +``` + +### Assets + +To provide the used test tool with access to auxiliary files needed for the +test execution, asset objects can be defined. The definition is done on the +toplevel using the `asset` keyword, giving the asset object name and a path to +the asset on the filesystem, relative to the directory containing the test +script: + +``` +asset my_asset: + path: ../path/to/file +``` + +Such defined asset object can then be used in expressions within tests or function definitions: + +``` +test: + spawn p + send to p "use-asset ${my_asset.path}" +``` + +The `my_asset.path` expression expands to a 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 77af52b..e8fe761 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: erebos-tester -version: 0.2.4 +version: 0.3.3 synopsis: Test framework with virtual network using Linux namespaces description: This framework is intended mainly for networking libraries/applications and @@ -28,7 +28,7 @@ flag ci source-repository head type: git - location: git://erebosprotocol.net/tester + location: https://code.erebosprotocol.net/tester executable erebos-tester ghc-options: @@ -43,35 +43,50 @@ executable erebos-tester -- sometimes needed for backward/forward compatibility: -Wno-error=unused-imports - main-is: Main.hs + main-is: + Main.hs - other-modules: Config - GDB - Network - Network.Ip - Output - Parser - Parser.Core - Parser.Expr - Parser.Statement - Paths_erebos_tester - Process - Run - Run.Monad - Test - Test.Builtins - Util - Version - Version.Git + other-modules: + Asset + Config + GDB + Network + Network.Ip + Output + Parser + Parser.Core + Parser.Expr + Parser.Shell + Parser.Statement + Paths_erebos_tester + Process + Run + Run.Monad + Sandbox + Script.Expr + Script.Expr.Class + Script.Module + Script.Object + Script.Shell + Script.Var + Test + Test.Builtins + TestMode + Util + Version + Version.Git - autogen-modules: Paths_erebos_tester + autogen-modules: + Paths_erebos_tester - c-sources: + c-sources: src/main.c + src/shell.c - other-extensions: + other-extensions: + CPP TemplateHaskell - default-extensions: + default-extensions: DefaultSignatures DeriveTraversable ExistentialQuantification @@ -92,11 +107,11 @@ executable erebos-tester TypeFamilies TypeOperators - build-depends: - base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 }, + build-depends: + base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 }, bytestring ^>= { 0.10, 0.11, 0.12 }, containers ^>= { 0.6.2.1, 0.7 }, - clock ^>= { 0.8.4 }, + clock ^>= { 0.8.3 }, directory ^>=1.3.6.0, filepath ^>= { 1.4.2.1, 1.5.2 }, Glob >=0.10 && <0.11, @@ -108,10 +123,11 @@ executable erebos-tester process ^>=1.6.9, regex-tdfa ^>=1.3.1.0, scientific >=0.3 && < 0.4, - stm ^>=2.5.0.1, - template-haskell^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22 }, + stm ^>= { 2.5.0 }, + template-haskell^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 }, text ^>= { 1.2, 2.0, 2.1 }, th-compat >=0.1 && <0.2, unix >=2.7 && <2.9, - hs-source-dirs: src - default-language: Haskell2010 + + hs-source-dirs: src + default-language: Haskell2010 diff --git a/erebos-tester.yaml b/erebos-tester.yaml new file mode 100644 index 0000000..2c75d7c --- /dev/null +++ b/erebos-tester.yaml @@ -0,0 +1 @@ +tests: test/script/**/*.et diff --git a/minici.yaml b/minici.yaml index a3f87f5..0813962 100644 --- a/minici.yaml +++ b/minici.yaml @@ -1,3 +1,13 @@ job build: shell: - - cabal build -fci + - 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/Asset.hs b/src/Asset.hs new file mode 100644 index 0000000..72ffd54 --- /dev/null +++ b/src/Asset.hs @@ -0,0 +1,33 @@ +module Asset ( + Asset(..), + AssetPath(..), +) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable + +import Script.Expr.Class + +data Asset = Asset + { assetPath :: AssetPath + } + +newtype AssetPath = AssetPath FilePath + +textAssetPath :: AssetPath -> Text +textAssetPath (AssetPath path) = T.pack path + +instance ExprType Asset where + textExprType _ = "asset" + textExprValue asset = "asset:" <> textAssetPath (assetPath asset) + + recordMembers = + [ ( "path", RecordSelector $ assetPath ) + ] + +instance ExprType AssetPath where + textExprType _ = "filepath" + textExprValue = ("filepath:" <>) . textAssetPath + + exprExpansionConvTo = cast textAssetPath 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,12 +72,14 @@ gdbStart onCrash = do { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } pout <- liftIO $ newTVarIO [] + ignore <- liftIO $ newTVarIO ( 0, [] ) let process = Process { procName = ProcNameGDB - , procHandle = handle + , procHandle = Left handle , procStdin = hin , procOutput = pout + , procIgnore = ignore , procKillWith = Nothing , procNode = undefined } @@ -144,7 +146,7 @@ gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . erro addInferior :: MonadOutput m => GDB -> Process -> m () addInferior gdb process = do - liftIO (getPid $ procHandle process) >>= \case + liftIO (either getPid (\_ -> return Nothing) $ procHandle process) >>= \case Nothing -> outProc OutputError process $ "failed to get PID" Just pid -> do tgid <- liftIO (atomically $ tryReadTChan $ gdbThreadGroups gdb) >>= \case diff --git a/src/Main.hs b/src/Main.hs index 73d8c02..b3f7a2a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,8 +2,10 @@ module Main (main) where import Control.Monad +import Data.List import Data.Maybe -import qualified Data.Text as T +import Data.Text (Text) +import Data.Text qualified as T import Text.Read (readMaybe) @@ -12,40 +14,44 @@ 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 import Test +import TestMode import Util import Version data CmdlineOptions = CmdlineOptions { optTest :: TestOptions , optRepeat :: Int + , optExclude :: [ Text ] , optVerbose :: Bool , optColor :: Maybe Bool , optShowHelp :: Bool , optShowVersion :: Bool + , optTestMode :: Bool } defaultCmdlineOptions :: CmdlineOptions defaultCmdlineOptions = CmdlineOptions { optTest = defaultTestOptions , optRepeat = 1 + , optExclude = [] , optVerbose = False , optColor = Nothing , optShowHelp = False , optShowVersion = False + , optTestMode = False } -options :: [OptDescr (CmdlineOptions -> CmdlineOptions)] +options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] options = [ Option ['T'] ["tool"] (ReqArg (\str -> to $ \opts -> case break (==':') str of @@ -79,6 +85,9 @@ options = , Option ['r'] ["repeat"] (ReqArg (\str opts -> opts { optRepeat = read str }) "<count>") "number of times to repeat the test(s)" + , Option [ 'e' ] [ "exclude" ] + (ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test>") + "exclude given test from execution" , Option [] ["wait"] (NoArg $ to $ \opts -> opts { optWait = True }) "wait at the end of each test" @@ -92,11 +101,17 @@ options = where to f opts = opts { optTest = f (optTest opts) } +hiddenOptions :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] +hiddenOptions = + [ Option [] [ "test-mode" ] + (NoArg (\opts -> opts { optTestMode = True })) + "test mode" + ] + main :: IO () main = do - configPath <- findConfig - 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) @@ -105,19 +120,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 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" , "" @@ -130,32 +152,55 @@ main = do putStrLn versionLine exitSuccess - getPermissions (head $ words $ optDefaultTool $ optTest opts) >>= \perms -> do - when (not $ executable perms) $ do - fail $ optDefaultTool (optTest opts) <> " is not executable" + when (optTestMode opts) $ do + testMode config + exitSuccess + + case words $ optDefaultTool $ optTest opts of + (path : _) -> getPermissions path >>= \perms -> do + when (not $ executable perms) $ do + fail $ "‘" <> path <> "’ is not executable" + _ -> fail $ "invalid tool argument: ‘" <> optDefaultTool (optTest opts) <> "’" files <- if not (null ofiles) then return $ flip map ofiles $ \ofile -> case span (/= ':') ofile of (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" useColor <- case optColor opts of Just use -> return use Nothing -> queryTerminal (Fd 1) - out <- startOutput (optVerbose opts) useColor - - modules <- parseTestFiles $ map fst files - tests <- forM (zip modules $ map snd files) $ \( Module {..}, mbTestName ) -> do - return $ map ( , moduleDefinitions ) $ case mbTestName of - Nothing -> moduleTests - Just name -> filter ((==name) . testName) moduleTests - - ok <- allM (uncurry $ runTest out $ optTest opts) $ - concat $ replicate (optRepeat opts) $ concat tests + let outputStyle + | optVerbose opts = OutputStyleVerbose + | otherwise = OutputStyleQuiet + out <- startOutput outputStyle useColor + + ( 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" + exitFailure + + ok <- allM (runTest out (optTest opts) 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 c841acb..e12231d 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -26,7 +26,8 @@ import System.FilePath import System.Process import Network.Ip -import Test +import Script.Expr +import Script.Expr.Class {- NETWORK STRUCTURE @@ -108,8 +109,9 @@ instance ExprType Node where textExprValue n = T.pack "n:" <> textNodeName (nodeName n) recordMembers = map (first T.pack) - [ ("ip", RecordSelector $ textIpAddress . nodeIp) - , ("network", RecordSelector $ nodeNetwork) + [ ( "ifname", RecordSelector $ const ("veth0" :: Text) ) + , ( "ip", RecordSelector $ textIpAddress . nodeIp ) + , ( "network", RecordSelector $ nodeNetwork ) ] diff --git a/src/Network.hs-boot b/src/Network.hs-boot deleted file mode 100644 index 1b5e9c4..0000000 --- a/src/Network.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Network where - -data Network -data Node -data NodeName 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 1555e54..0ad1f12 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -1,5 +1,5 @@ module Output ( - Output, OutputType(..), + Output, OutputStyle(..), OutputType(..), MonadOutput(..), startOutput, resetOutputTime, @@ -18,12 +18,15 @@ import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.IO qualified as TL +import System.Clock import System.Console.Haskeline import System.Console.Haskeline.History -import System.Clock +import System.IO import Text.Printf +import Script.Expr + data Output = Output { outState :: MVar OutputState , outConfig :: OutputConfig @@ -31,7 +34,7 @@ data Output = Output } data OutputConfig = OutputConfig - { outVerbose :: Bool + { outStyle :: OutputStyle , outUseColor :: Bool } @@ -40,15 +43,23 @@ data OutputState = OutputState , outHistory :: History } -data OutputType = OutputChildStdout - | OutputChildStderr - | OutputChildStdin - | OutputChildInfo - | OutputChildFail - | OutputMatch - | OutputMatchFail - | OutputError - | OutputAlways +data OutputStyle + = OutputStyleQuiet + | OutputStyleVerbose + | OutputStyleTest + deriving (Eq) + +data OutputType + = OutputChildStdout + | OutputChildStderr + | OutputChildStdin + | OutputChildInfo + | OutputChildFail + | OutputMatch + | OutputMatchFail CallStack + | OutputError + | OutputAlways + | OutputTestRaw class MonadIO m => MonadOutput m where getOutput :: m Output @@ -56,11 +67,12 @@ class MonadIO m => MonadOutput m where instance MonadIO m => MonadOutput (ReaderT Output m) where getOutput = ask -startOutput :: Bool -> Bool -> IO Output -startOutput outVerbose outUseColor = do +startOutput :: OutputStyle -> Bool -> IO Output +startOutput outStyle outUseColor = do outState <- newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory } outConfig <- pure OutputConfig {..} outStartedAt <- newMVar =<< getTime Monotonic + hSetBuffering stdout LineBuffering return Output {..} resetOutputTime :: Output -> IO () @@ -74,9 +86,10 @@ 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 OutputMatchFail {} = T.pack "31" outColor OutputError = T.pack "31" outColor OutputAlways = "0" +outColor OutputTestRaw = "0" outSign :: OutputType -> Text outSign OutputChildStdout = T.empty @@ -85,19 +98,33 @@ outSign OutputChildStdin = T.empty outSign OutputChildInfo = T.pack "." outSign OutputChildFail = T.pack "!!" outSign OutputMatch = T.pack "+" -outSign OutputMatchFail = T.pack "/" +outSign OutputMatchFail {} = T.pack "/" outSign OutputError = T.pack "!!" outSign OutputAlways = T.empty +outSign OutputTestRaw = T.empty outArr :: OutputType -> Text outArr OutputChildStdin = "<" outArr _ = ">" +outTestLabel :: OutputType -> Text +outTestLabel = \case + OutputChildStdout -> "child-stdout" + OutputChildStderr -> "child-stderr" + OutputChildStdin -> "child-stdin" + OutputChildInfo -> "child-info" + OutputChildFail -> "child-fail" + OutputMatch -> "match" + OutputMatchFail {} -> "match-fail" + OutputError -> "error" + OutputAlways -> "other" + OutputTestRaw -> "" + printWhenQuiet :: OutputType -> Bool printWhenQuiet = \case OutputChildStderr -> True OutputChildFail -> True - OutputMatchFail -> True + OutputMatchFail {} -> True OutputError -> True OutputAlways -> True _ -> False @@ -107,21 +134,70 @@ ioWithOutput act = liftIO . act =<< getOutput outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m () outLine otype prompt line = ioWithOutput $ \out -> - when (outVerbose (outConfig out) || printWhenQuiet otype) $ do + case outStyle (outConfig out) of + OutputStyleQuiet + | printWhenQuiet otype -> normalOutput out + | otherwise -> return () + OutputStyleVerbose -> normalOutput out + OutputStyleTest -> testOutput out + where + normalOutput out = do stime <- readMVar (outStartedAt out) nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic withMVar (outState out) $ \st -> do - 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 + [ [ 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 [] + ] + + testOutput out = do + withMVar (outState out) $ \st -> do + 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 + ] + 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 323f2cf..9f1a0e3 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -2,9 +2,11 @@ module Parser ( parseTestFiles, + CustomTestError(..), ) where import Control.Monad +import Control.Monad.Except import Control.Monad.State import Data.IORef @@ -22,14 +24,16 @@ import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L import System.Directory -import System.Exit import System.FilePath import System.IO.Error +import Asset import Network import Parser.Core import Parser.Expr import Parser.Statement +import Script.Expr +import Script.Module import Test import Test.Builtins @@ -39,36 +43,37 @@ parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do modify $ \s -> s { testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar } - block (\name steps -> return $ Test name $ mconcat steps) header testStep + block (\name steps -> return $ Test name $ Scope <$> mconcat steps) header testStep where header = do wsymbol "test" lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') -parseDefinition :: TestParser ( VarName, SomeExpr ) -parseDefinition = label "symbol definition" $ do - def <- localState $ L.indentBlock scn $ do +parseDefinition :: Pos -> TestParser ( VarName, SomeExpr ) +parseDefinition href = label "symbol definition" $ do + def@( name, expr ) <- localState $ do wsymbol "def" name <- varName argsDecl <- functionArguments (\off _ -> return . ( off, )) varName mzero (\_ -> return . VarName) atypes <- forM argsDecl $ \( off, vname :: VarName ) -> do tvar <- newTypeVar - modify $ \s -> s { testVars = ( vname, ExprTypeVar tvar ) : testVars s } + modify $ \s -> s { testVars = ( vname, ( LocalVarName vname, ExprTypeVar tvar )) : testVars s } return ( off, vname, tvar ) - choice + SomeExpr expr <- choice [ do osymbol ":" - let finish steps = do - atypes' <- getInferredTypes atypes - ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs (mconcat steps) - return $ L.IndentSome Nothing finish testStep + scn + ref <- L.indentGuard scn GT href + SomeExpr <$> testBlock ref , do osymbol "=" - SomeExpr (expr :: Expr e) <- someExpr - atypes' <- getInferredTypes atypes - L.IndentNone . ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr + someExpr <* eol ] - modify $ \s -> s { testVars = fmap someExprType def : testVars s } + scn + atypes' <- getInferredTypes atypes + sexpr <- SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr + return ( name, sexpr ) + modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } return def where getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do @@ -96,12 +101,37 @@ parseDefinition = label "symbol definition" $ do replaceArgs (SomeExpr e) = SomeExpr (go unif e) e -> e +parseAsset :: Pos -> TestParser ( VarName, SomeExpr ) +parseAsset href = label "asset definition" $ do + wsymbol "asset" + name <- varName + osymbol ":" + void eol + ref <- L.indentGuard scn GT href + + wsymbol "path" + osymbol ":" + off <- stateOffset <$> getParserState + path <- TL.unpack <$> takeWhile1P Nothing (/= '\n') + dir <- takeDirectory <$> gets testSourcePath + absPath <- liftIO (makeAbsolute $ dir </> path) + let assetPath = AssetPath absPath + liftIO (doesPathExist absPath) >>= \case + True -> return () + False -> registerParseError $ FancyError off $ S.singleton $ ErrorCustom $ FileNotFound absPath + + void $ L.indentGuard scn LT ref + let expr = SomeExpr $ Pure Asset {..} + modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } + return ( name, expr ) + parseExport :: TestParser [ Toplevel ] parseExport = label "export declaration" $ toplevel id $ do + ref <- L.indentLevel wsymbol "export" choice [ do - def@( name, _ ) <- parseDefinition + def@( name, _ ) <- parseDefinition ref <|> parseAsset ref return [ ToplevelDefinition def, ToplevelExport name ] , do names <- listOf varName @@ -112,14 +142,14 @@ parseExport = label "export declaration" $ toplevel id $ do parseImport :: TestParser [ Toplevel ] parseImport = label "import declaration" $ toplevel (\() -> []) $ do wsymbol "import" - name <- parseModuleName - importedModule <- getOrParseModule name - let importedDefs = filter ((`elem` moduleExports importedModule) . fst) (moduleDefinitions importedModule) - modify $ \s -> s { testVars = map (fmap someExprType) importedDefs ++ testVars s } + modName <- parseModuleName + importedModule <- getOrParseModule modName + modify $ \s -> s { testVars = map (fmap (fmap someExprType)) (moduleExportedDefinitions importedModule) ++ testVars s } eol >> scn parseTestModule :: FilePath -> TestParser Module parseTestModule absPath = do + scn moduleName <- choice [ label "module declaration" $ do wsymbol "module" @@ -136,7 +166,8 @@ parseTestModule absPath = do modify $ \s -> s { testCurrentModuleName = moduleName } toplevels <- fmap concat $ many $ choice [ (: []) <$> parseTestDefinition - , (: []) <$> toplevel ToplevelDefinition parseDefinition + , (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1) + , (: []) <$> toplevel ToplevelDefinition (parseAsset pos1) , parseExport , parseImport ] @@ -146,46 +177,48 @@ parseTestModule absPath = do eof return Module {..} -parseTestFiles :: [ FilePath ] -> IO [ Module ] +parseTestFiles :: [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] )) parseTestFiles paths = do parsedModules <- newIORef [] - reverse <$> foldM (go parsedModules) [] paths + runExceptT $ do + requestedModules <- reverse <$> foldM (go parsedModules) [] paths + allModules <- map snd <$> liftIO (readIORef parsedModules) + return ( requestedModules, allModules ) where go parsedModules res path = do - let moduleName = error "current module name should be set at the beginning of parseTestModule" - parseTestFile parsedModules moduleName path >>= \case + liftIO (parseTestFile parsedModules Nothing path) >>= \case Left err -> do - putStr (showErrorComponent err) - exitFailure + throwError err Right cur -> do return $ cur : res -parseTestFile :: IORef [ ( FilePath, Module ) ] -> ModuleName -> FilePath -> IO (Either CustomTestError Module) -parseTestFile parsedModules moduleName path = do +parseTestFile :: IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module) +parseTestFile parsedModules mbModuleName path = do absPath <- makeAbsolute path (lookup absPath <$> readIORef parsedModules) >>= \case Just found -> return $ Right found Nothing -> do let initState = TestParserState - { testVars = concat - [ map (fmap someVarValueType) builtins + { testSourcePath = path + , testVars = concat + [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins ] , testContext = SomeExpr (Undefined "void" :: Expr Void) , testNextTypeVar = 0 , testTypeUnif = M.empty - , testCurrentModuleName = moduleName + , testCurrentModuleName = fromMaybe (error "current module name should be set at the beginning of parseTestModule") mbModuleName , testParseModule = \(ModuleName current) mname@(ModuleName imported) -> do let projectRoot = iterate takeDirectory absPath !! length current - parseTestFile parsedModules mname $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath + parseTestFile parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath } mbContent <- (Just <$> TL.readFile path) `catchIOError` \e -> if isDoesNotExistError e then return Nothing else ioError e case mbContent of Just content -> do - runTestParser path content initState (parseTestModule absPath) >>= \case + runTestParser content initState (parseTestModule absPath) >>= \case Left bundle -> do return $ Left $ ImportModuleError bundle Right testModule -> do modifyIORef parsedModules (( absPath, testModule ) : ) return $ Right testModule - Nothing -> return $ Left $ ModuleNotFound moduleName + Nothing -> return $ Left $ maybe (FileNotFound path) ModuleNotFound mbModuleName diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index f964291..f44e721 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -17,6 +17,8 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Network () +import Script.Expr +import Script.Module import Test newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a) @@ -25,6 +27,7 @@ newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestErr , MonadState TestParserState , MonadPlus , MonadFail + , MonadIO , MonadParsec CustomTestError TestStream ) @@ -34,6 +37,7 @@ type TestParseError = ParseError TestStream CustomTestError data CustomTestError = ModuleNotFound ModuleName + | FileNotFound FilePath | ImportModuleError (ParseErrorBundle TestStream CustomTestError) deriving (Eq) @@ -42,17 +46,22 @@ instance Ord CustomTestError where compare (ModuleNotFound _) _ = LT compare _ (ModuleNotFound _) = GT + compare (FileNotFound a) (FileNotFound b) = compare a b + compare (FileNotFound _) _ = LT + compare _ (FileNotFound _) = GT + -- Ord instance is required to store errors in Set, but there shouldn't be -- two ImportModuleErrors at the same possition, so "dummy" comparison -- should be ok. compare (ImportModuleError _) (ImportModuleError _) = EQ instance ShowErrorComponent CustomTestError where - showErrorComponent (ModuleNotFound name) = "module `" <> T.unpack (textModuleName name) <> "' not found" + showErrorComponent (ModuleNotFound name) = "module ‘" <> T.unpack (textModuleName name) <> "’ not found" + showErrorComponent (FileNotFound path) = "file ‘" <> path <> "’ not found" showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle -runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a) -runTestParser path content initState (TestParser parser) = flip (flip runParserT path) content . flip evalStateT initState $ parser +runTestParser :: TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a) +runTestParser content initState (TestParser parser) = flip (flip runParserT (testSourcePath initState)) content . flip evalStateT initState $ parser data Toplevel = ToplevelTest Test @@ -61,7 +70,8 @@ data Toplevel | ToplevelImport ( ModuleName, VarName ) data TestParserState = TestParserState - { testVars :: [ ( VarName, SomeExprType ) ] + { testSourcePath :: FilePath + , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ] , testContext :: SomeExpr , testNextTypeVar :: Int , testTypeUnif :: Map TypeVar SomeExprType @@ -75,25 +85,36 @@ newTypeVar = do modify $ \s -> s { testNextTypeVar = idx + 1 } return $ TypeVar $ T.pack $ 'a' : show idx -lookupVarType :: Int -> VarName -> TestParser SomeExprType +lookupVarType :: Int -> VarName -> TestParser ( FqVarName, SomeExprType ) lookupVarType off name = do gets (lookup name . testVars) >>= \case Nothing -> do registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "variable not in scope: `" <> textVarName name <> "'" vtype <- ExprTypeVar <$> newTypeVar - modify $ \s -> s { testVars = ( name, vtype ) : testVars s } - return vtype - Just t@(ExprTypeVar tvar) -> do - gets (fromMaybe t . M.lookup tvar . testTypeUnif) + let fqName = LocalVarName name + modify $ \s -> s { testVars = ( name, ( fqName, vtype )) : testVars s } + return ( fqName, vtype ) + Just ( fqName, t@(ExprTypeVar tvar) ) -> do + ( fqName, ) <$> gets (fromMaybe t . M.lookup tvar . testTypeUnif) Just x -> return x lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr lookupVarExpr off sline name = do - lookupVarType off name >>= \case - ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline name :: Expr a) - ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline name - ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline name :: Expr (FunctionType a)) + ( 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)) + +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 + SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a)) unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do @@ -180,7 +201,8 @@ unifyExpr off pa expr = if SomeExpr context <- gets testContext context' <- unifyExpr off atype context return $ Just ( kw, SomeExpr context' ) - return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) + sline <- getSourceLine + return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) | Just (Refl :: DynamicType :~: b) <- eqT , Undefined msg <- expr @@ -242,6 +264,18 @@ listOf item = do x <- item (x:) <$> choice [ symbol "," >> listOf item, return [] ] +blockOf :: Monoid a => Pos -> TestParser a -> TestParser a +blockOf indent step = go + where + go = do + scn + pos <- L.indentLevel + optional eof >>= \case + Just _ -> return mempty + _ | pos < indent -> return mempty + | pos == indent -> mappend <$> step <*> go + | otherwise -> L.incorrectIndent EQ indent pos + getSourceLine :: TestParser SourceLine getSourceLine = do diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index 41790bb..b9b5f01 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -11,6 +11,8 @@ module Parser.Expr ( literal, variable, + stringExpansion, + checkFunctionArguments, functionArguments, ) where @@ -35,11 +37,10 @@ import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L import Text.Megaparsec.Error.Builder qualified as Err -import Text.Regex.TDFA qualified as RE -import Text.Regex.TDFA.Text qualified as RE import Parser.Core -import Test +import Script.Expr +import Script.Expr.Class reservedWords :: [ Text ] reservedWords = @@ -80,7 +81,7 @@ addVarName off (TypedVarName name) = do 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, ExprTypePrim @a Proxy ) : testVars s } + modify $ \s -> s { testVars = ( name, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s } someExpansion :: TestParser SomeExpr someExpansion = do @@ -89,12 +90,12 @@ someExpansion = do [do off <- stateOffset <$> getParserState sline <- getSourceLine name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') - lookupVarExpr off sline name + lookupScalarVarExpr off sline name , between (char '{') (char '}') someExpr ] -stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a) -stringExpansion tname conv = do +expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a) +expressionExpansion tname = do off <- stateOffset <$> getParserState SomeExpr e <- someExpansion let err = do @@ -102,7 +103,10 @@ stringExpansion tname conv = do [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ] return $ Undefined "expansion not defined for type" - maybe err return $ listToMaybe $ catMaybes $ conv e + maybe err (return . (<$> e)) $ listToMaybe $ catMaybes [ cast (id :: a -> a), exprExpansionConvTo, exprExpansionConvFrom ] + +stringExpansion :: TestParser (Expr Text) +stringExpansion = expressionExpansion "string" numberLiteral :: TestParser SomeExpr numberLiteral = label "number" $ lexeme $ do @@ -114,6 +118,13 @@ numberLiteral = label "number" $ lexeme $ do else return $ SomeExpr $ Pure x ] +boolLiteral :: TestParser SomeExpr +boolLiteral = label "bool" $ lexeme $ do + SomeExpr . Pure <$> choice + [ wsymbol "True" *> return True + , wsymbol "False" *> return False + ] + quotedString :: TestParser (Expr Text) quotedString = label "string" $ lexeme $ do void $ char '"' @@ -130,11 +141,7 @@ quotedString = label "string" $ lexeme $ do , char 't' >> return '\t' ] (Pure (T.singleton c) :) <$> inner - ,do e <- stringExpansion (T.pack "string") $ \e -> - [ cast e - , fmap (T.pack . show @Integer) <$> cast e - , fmap (T.pack . show @Scientific) <$> cast e - ] + ,do e <- stringExpansion (e:) <$> inner ] Concat <$> inner @@ -152,19 +159,14 @@ regex = label "regular expression" $ lexeme $ do , anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c]) ] (s:) <$> inner - ,do e <- stringExpansion (T.pack "regex") $ \e -> - [ cast e - , fmap RegexString <$> cast e - , fmap (RegexString . T.pack . show @Integer) <$> cast e - , fmap (RegexString . T.pack . show @Scientific) <$> cast e - ] + ,do e <- expressionExpansion (T.pack "regex") (e:) <$> inner ] parts <- inner let testEval = \case Pure (RegexPart p) -> p _ -> "" - case RE.compile RE.defaultCompOpt RE.defaultExecOpt $ T.concat $ map testEval parts of + case regexCompile $ T.concat $ map testEval parts of Left err -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [ "failed to parse regular expression: ", T.pack err ] Right _ -> return () @@ -266,11 +268,13 @@ someExpr = join inner <?> "expression" [ SomeBinOp ((==) @Integer) , SomeBinOp ((==) @Scientific) , SomeBinOp ((==) @Text) + , SomeBinOp ((==) @Bool) ] , binary' "/=" (\op xs ys -> length xs /= length ys || or (zipWith op xs ys)) $ [ SomeBinOp ((/=) @Integer) , SomeBinOp ((/=) @Scientific) , SomeBinOp ((/=) @Text) + , SomeBinOp ((/=) @Bool) ] , binary ">" $ [ SomeBinOp ((>) @Integer) @@ -352,6 +356,7 @@ typedExpr = do literal :: TestParser SomeExpr literal = label "literal" $ choice [ numberLiteral + , boolLiteral , SomeExpr <$> quotedString , SomeExpr <$> regex , list @@ -391,18 +396,17 @@ recordSelector (SomeExpr expr) = do checkFunctionArguments :: FunctionArguments SomeArgumentType -> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr -checkFunctionArguments (FunctionArguments argTypes) poff kw expr = do +checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr) = do case M.lookup kw argTypes of Just (SomeArgumentType (_ :: ArgumentType expected)) -> do - withRecovery registerParseError $ do - void $ unify poff (ExprTypePrim (Proxy @expected)) (someExprType expr) - return expr + withRecovery (\e -> registerParseError e >> return sexpr) $ do + SomeExpr <$> unifyExpr poff (Proxy @expected) 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 expr + return sexpr 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 new file mode 100644 index 0000000..22d47ed --- /dev/null +++ b/src/Parser/Shell.hs @@ -0,0 +1,108 @@ +module Parser.Shell ( + ShellScript, + shellScript, +) where + +import Control.Applicative (liftA2) +import Control.Monad + +import Data.Char +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL + +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L + +import Parser.Core +import Parser.Expr +import Script.Expr +import Script.Shell + +parseArgument :: TestParser (Expr Text) +parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice + [ doubleQuotedString + , singleQuotedString + , standaloneEscapedChar + , stringExpansion + , unquotedString + ] + where + specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']', '{', '}', '(', ')', '*', '?', '~', '&', '!' ] + + stringSpecialChars = [ '"', '\\', '$' ] + + unquotedString :: TestParser (Expr Text) + unquotedString = do + Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars) + + doubleQuotedString :: TestParser (Expr Text) + doubleQuotedString = do + void $ char '"' + let inner = choice + [ char '"' >> return [] + , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` stringSpecialChars)) <*> inner + , (:) <$> stringEscapedChar <*> inner + , (:) <$> stringExpansion <*> inner + ] + App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner + + singleQuotedString :: TestParser (Expr Text) + singleQuotedString = do + Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'') + + stringEscapedChar :: TestParser (Expr Text) + stringEscapedChar = do + void $ char '\\' + 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 "\\" + ] + + standaloneEscapedChar :: TestParser (Expr Text) + standaloneEscapedChar = do + void $ char '\\' + fmap Pure $ choice $ + map (\c -> char c >> return (T.singleton c)) specialChars ++ + [ char ' ' >> return " " + ] + +parseArguments :: TestParser (Expr [ Text ]) +parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument + +parseCommand :: TestParser (Expr ShellCommand) +parseCommand = label "shell statement" $ do + line <- getSourceLine + command <- parseArgument + args <- parseArguments + return $ ShellCommand + <$> command + <*> args + <*> pure line + +parsePipeline :: Expr (Maybe ShellPipeline) -> TestParser (Expr ShellPipeline) +parsePipeline upper = do + cmd <- parseCommand + let pipeline = ShellPipeline <$> cmd <*> upper + choice + [ do + osymbol "|" + parsePipeline (Just <$> pipeline) + + , do + return pipeline + ] + +parseStatement :: TestParser (Expr [ ShellStatement ]) +parseStatement = do + line <- getSourceLine + fmap ((: []) . flip ShellStatement line) <$> parsePipeline (pure Nothing) + +shellScript :: TestParser (Expr ShellScript) +shellScript = do + indent <- L.indentLevel + fmap ShellScript <$> blockOf indent parseStatement diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 7765b12..474fa03 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -1,5 +1,6 @@ module Parser.Statement ( testStep, + testBlock, ) where import Control.Monad @@ -21,11 +22,14 @@ import qualified Text.Megaparsec.Char.Lexer as L import Network (Network, Node) import Parser.Core import Parser.Expr +import Parser.Shell import Process (Process) +import Script.Expr +import Script.Expr.Class import Test import Util -letStatement :: TestParser (Expr TestBlock) +letStatement :: TestParser (Expr (TestBlock ())) letStatement = do line <- getSourceLine indent <- L.indentLevel @@ -40,9 +44,9 @@ letStatement = do addVarName off tname void $ eol body <- testBlock indent - return $ Let line tname e body + return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body) -forStatement :: TestParser (Expr TestBlock) +forStatement :: TestParser (Expr (TestBlock ())) forStatement = do ref <- L.indentLevel wsymbol "for" @@ -65,9 +69,54 @@ forStatement = do body <- testBlock indent return $ (\xs f -> mconcat $ map f xs) <$> (unpack <$> e) - <*> LambdaAbstraction tname body + <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body) -exprStatement :: TestParser (Expr TestBlock) +shellStatement :: TestParser (Expr (TestBlock ())) +shellStatement = do + ref <- L.indentLevel + wsymbol "shell" + parseParams ref Nothing Nothing + + where + parseParamKeyword kw prev = do + off <- stateOffset <$> getParserState + wsymbol kw + when (isJust prev) $ do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "unexpected parameter with keyword ‘" <> kw <> "’" + + parseParams ref mbpname mbnode = choice + [ do + parseParamKeyword "as" mbpname + pname <- newVarName + parseParams ref (Just pname) mbnode + + , do + parseParamKeyword "on" mbnode + node <- typedExpr + parseParams ref mbpname (Just node) + + , do + off <- stateOffset <$> getParserState + symbol ":" + node <- case mbnode of + Just node -> return node + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "missing parameter with keyword ‘on’" + return $ Undefined "" + + void eol + void $ L.indentGuard scn GT ref + script <- shellScript + cont <- 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 @@ -77,11 +126,11 @@ exprStatement = do , unifyExpr off Proxy expr ] where - continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr TestBlock) + continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr (TestBlock ())) continuePartial off ref expr = do symbol ":" void eol - (fun :: Expr (FunctionType TestBlock)) <- unifyExpr off Proxy expr + (fun :: Expr (FunctionType (TestBlock ()))) <- unifyExpr off Proxy expr scn indent <- L.indentGuard scn GT ref blockOf indent $ do @@ -227,10 +276,10 @@ paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" -newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock } +newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } instance ExprType a => ParamType (InnerBlock a) where - type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr TestBlock ) + type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr (TestBlock ()) ) parseParam _ = mzero showParamType _ = "<code block>" paramExpr ( vars, expr ) = fmap InnerBlock $ helper vars $ const <$> expr @@ -242,14 +291,14 @@ instance ExprType a => ParamType (InnerBlock a) where combine f (x : xs) = f x xs combine _ [] = error "inner block parameter count mismatch" -innerBlock :: CommandDef TestBlock +innerBlock :: CommandDef (TestStep ()) innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun -innerBlockFun :: ExprType a => CommandDef (a -> TestBlock) +innerBlockFun :: ExprType a => CommandDef (a -> TestStep ()) innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList -innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock) -innerBlockFunList = fromInnerBlock <$> param "" +innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ()) +innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param "" newtype ExprParam a = ExprParam { fromExprParam :: a } deriving (Functor, Foldable, Traversable) @@ -263,7 +312,7 @@ instance ExprType a => ParamType (ExprParam a) where showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" paramExpr = fmap ExprParam -command :: String -> CommandDef TestStep -> TestParser (Expr TestBlock) +command :: String -> CommandDef (TestStep ()) -> TestParser (Expr (TestBlock ())) command name (CommandDef types ctor) = do indent <- L.indentLevel line <- getSourceLine @@ -271,7 +320,7 @@ command name (CommandDef types ctor) = do localState $ do restOfLine indent [] line $ map (fmap $ \(SomeParam p@(_ :: Proxy p) Proxy) -> SomeParam p $ Nothing @(ParamRep p)) types where - restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr TestBlock) + restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr (TestBlock ())) restOfLine cmdi partials line params = choice [do void $ lookAhead eol let definedVariables = mconcat $ map (someParamVars . snd) params @@ -288,7 +337,7 @@ command name (CommandDef types ctor) = do , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p ] (_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x - return $ (TestBlock . (: [])) <$> ctor iparams + return $ (TestBlockStep EmptyTestBlock) <$> ctor iparams ,do symbol ":" scn @@ -298,7 +347,7 @@ command name (CommandDef types ctor) = do ,do tryParams cmdi partials line [] params ] - restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr TestBlock) + restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr (TestBlock ())) restOfParts cmdi [] = testBlock cmdi restOfParts cmdi partials@((partIndent, params) : rest) = do scn @@ -324,7 +373,7 @@ command name (CommandDef types ctor) = do ] tryParams _ _ _ _ [] = mzero -testLocal :: TestParser (Expr TestBlock) +testLocal :: TestParser (Expr (TestBlock ())) testLocal = do ref <- L.indentLevel wsymbol "local" @@ -332,9 +381,10 @@ 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 :: TestParser (Expr (TestBlock ())) testWith = do ref <- L.indentLevel wsymbol "with" @@ -358,27 +408,28 @@ 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 :: TestParser (Expr (TestBlock ())) testSubnet = command "subnet" $ Subnet <$> param "" <*> (fromExprParam <$> paramOrContext "of") <*> innerBlockFun -testNode :: TestParser (Expr TestBlock) +testNode :: TestParser (Expr (TestBlock ())) testNode = command "node" $ DeclNode <$> param "" <*> (fromExprParam <$> paramOrContext "on") <*> innerBlockFun -testSpawn :: TestParser (Expr TestBlock) +testSpawn :: TestParser (Expr (TestBlock ())) testSpawn = command "spawn" $ Spawn <$> param "as" <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") + <*> (maybe [] fromExprParam <$> param "args") <*> innerBlockFun -testExpect :: TestParser (Expr TestBlock) +testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect <$> cmdLine <*> (fromExprParam <$> paramOrContext "from") @@ -386,47 +437,36 @@ testExpect = command "expect" $ Expect <*> param "capture" <*> innerBlockFunList -testDisconnectNode :: TestParser (Expr TestBlock) +testDisconnectNode :: TestParser (Expr (TestBlock ())) testDisconnectNode = command "disconnect_node" $ DisconnectNode <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectNodes :: TestParser (Expr TestBlock) +testDisconnectNodes :: TestParser (Expr (TestBlock ())) testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectUpstream :: TestParser (Expr TestBlock) +testDisconnectUpstream :: TestParser (Expr (TestBlock ())) testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testPacketLoss :: TestParser (Expr TestBlock) +testPacketLoss :: TestParser (Expr (TestBlock ())) testPacketLoss = command "packet_loss" $ PacketLoss <$> (fromExprParam <$> paramOrContext "") <*> (fromExprParam <$> paramOrContext "on") <*> innerBlock -testBlock :: Pos -> TestParser (Expr TestBlock) +testBlock :: Pos -> TestParser (Expr (TestBlock ())) testBlock indent = blockOf indent testStep -blockOf :: Monoid a => Pos -> TestParser a -> TestParser a -blockOf indent step = go - where - go = do - scn - pos <- L.indentLevel - optional eof >>= \case - Just _ -> return mempty - _ | pos < indent -> return mempty - | pos == indent -> mappend <$> step <*> go - | otherwise -> L.incorrectIndent EQ indent pos - -testStep :: TestParser (Expr TestBlock) +testStep :: TestParser (Expr (TestBlock ())) testStep = choice [ letStatement , forStatement + , shellStatement , testLocal , testWith , testSubnet diff --git a/src/Process.hs b/src/Process.hs index 376b1ba..0c24b4f 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -5,9 +5,14 @@ module Process ( send, outProc, lineReadingLoop, + startProcessIOLoops, spawnOn, closeProcess, + closeTestProcess, withProcess, + + IgnoreProcessOutput(..), + flushProcessOutput, ) where import Control.Arrow @@ -18,11 +23,16 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Function +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 import System.Exit +import System.FilePath import System.IO import System.IO.Error import System.Posix.Signals @@ -33,13 +43,16 @@ import Network import Network.Ip import Output import Run.Monad -import Test +import Script.Expr +import Script.Expr.Class +import Script.Object data Process = Process { procName :: ProcName - , procHandle :: ProcessHandle + , 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 } @@ -80,65 +93,94 @@ outProc otype p line = outLine otype (Just $ textProcName $ procName p) 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 + liftIO $ atomically $ do + ignores <- map snd . snd <$> readTVar procIgnore + when (not $ any (matches line) ignores) $ do + modifyTVar procOutput (++ [ 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 shell wrapper. + cmd' <- liftIO $ do + case span (/= ' ') cmd of + ( path, rest ) + | any isPathSeparator path && isRelative path + -> do + path' <- makeAbsolute path + return (path' ++ rest) + _ -> return cmd + let netns = either getNetns getNetns target - let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" " - (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", "." ) ] - } - pout <- liftIO $ newTVarIO [] - - let process = Process - { procName = pname - , procHandle = handle - , procStdin = hin - , procOutput = pout - , procKillWith = killWith - , procNode = either (const undefined) id target + currentEnv <- liftIO $ getEnvironment + (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 + let process = Process {..} - forkTest $ lineReadingLoop process hout $ \line -> do - outProc OutputChildStdout process line - liftIO $ atomically $ modifyTVar pout (++[line]) - 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 $ getPid (procHandle p) >>= \case + Just sig -> liftIO $ either getPid (\_ -> return Nothing) (procHandle p) >>= \case Nothing -> return () Just pid -> signalProcess sig pid liftIO $ void $ forkIO $ do - threadDelay 1000000 - terminateProcess $ procHandle p - liftIO (waitForProcess (procHandle p)) >>= \case + 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 throwError Failed +closeTestProcess :: Process -> TestRun () +closeTestProcess process = do + timeout <- liftIO . readMVar =<< asks (teTimeout . fst) + closeProcess timeout process + withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a withProcess target pname killWith cmd inner = do procVar <- asks $ teProcesses . fst @@ -148,5 +190,28 @@ 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 ) + + createObject oid ( process@Process {..}, regex ) = do + liftIO $ atomically $ do + flushProcessOutput process regex + ( iid, list ) <- readTVar procIgnore + writeTVar procIgnore ( iid + 1, ( iid, regex ) : list ) + return $ Object oid $ IgnoreProcessOutput process iid + + destroyObject Object { objImpl = IgnoreProcessOutput Process {..} iid } = do + liftIO $ atomically $ do + writeTVar procIgnore . fmap (filter ((iid /=) . fst)) =<< readTVar procIgnore + +flushProcessOutput :: Process -> Maybe Regex -> STM () +flushProcessOutput p mbre = do + writeTVar (procOutput p) =<< case mbre of + Nothing -> return [] + Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p) @@ -1,6 +1,8 @@ module Run ( module Run.Monad, runTest, + loadModules, + evalGlobalDefs, ) where import Control.Applicative @@ -8,14 +10,18 @@ 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 @@ -24,17 +30,26 @@ import System.Posix.Process import System.Posix.Signals import System.Process +import Text.Megaparsec (errorBundlePretty, showErrorComponent) + import GDB import Network import Network.Ip import Output +import Parser import Process import Run.Monad +import Sandbox +import Script.Expr +import Script.Module +import Script.Object +import Script.Shell import Test import Test.Builtins -runTest :: Output -> TestOptions -> Test -> [ ( VarName, SomeExpr ) ] -> IO Bool -runTest out opts test variables = do + +runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool +runTest out opts gdefs test = do let testDir = optTestDir opts when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e -> if isDoesNotExistError e then return () else ioError e @@ -43,7 +58,9 @@ runTest out opts test variables = do createDirectoryIfMissing True testDir failedVar <- newTVarIO Nothing + objIdVar <- newMVar 1 procVar <- newMVar [] + timeoutVar <- newMVar $ optTimeout opts mgdb <- if optGDB opts then flip runReaderT out $ do @@ -55,11 +72,14 @@ runTest out opts test variables = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teNextObjId = objIdVar , teProcesses = procVar + , teTimeout = timeoutVar , teGDB = fst <$> mgdb } tstate = TestState - { tsVars = builtins + { tsGlobals = gdefs + , tsLocals = [] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty @@ -68,7 +88,7 @@ runTest out opts test variables = do let sigHandler SignalInfo { siginfoSpecific = chld } = do processes <- readMVar procVar forM_ processes $ \p -> do - mbpid <- getPid (procHandle p) + mbpid <- either getPid (\_ -> return Nothing) (procHandle p) when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do let err detail = outProc OutputChildFail p detail case siginfoStatus chld of @@ -82,24 +102,27 @@ runTest out opts test variables = do Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing - let withVarExprList (( name, expr ) : rest) act = do - value <- evalSome expr - local (fmap $ \s -> s { tsVars = ( name, value ) : tsVars s }) $ do - withVarExprList rest act - withVarExprList [] act = act - resetOutputTime out - res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do - withVarExprList variables $ do - withInternet $ \_ -> do - evalBlock =<< eval (testSteps test) - when (optWait opts) $ do - void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + testRunResult <- newEmptyMVar + + 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) @@ -107,17 +130,56 @@ runTest out opts test variables = do (Right (), Nothing) -> do when (not $ optKeep opts) $ removeDirectoryRecursive testDir return True - _ -> return False + _ -> do + flip runReaderT out $ do + void $ outLine OutputError Nothing $ "Test ‘" <> testName test <> "’ failed." + return False + + +loadModules :: [ FilePath ] -> IO ( [ Module ], GlobalDefs ) +loadModules files = do + ( modules, allModules ) <- parseTestFiles files >>= \case + Right res -> do + return res + Left err -> do + case err of + ImportModuleError bundle -> + putStr (errorBundlePretty bundle) + _ -> do + putStrLn (showErrorComponent err) + exitFailure + let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules + return ( modules, globalDefs ) + + +evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs +evalGlobalDefs exprs = fix $ \gdefs -> + builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs) + +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 (TestBlock steps) = forM_ steps $ \case Subnet name parent inner -> do - withSubnet parent (Just name) $ evalBlock . inner + withSubnet parent (Just name) $ runStep . inner DeclNode name net inner -> do - withNode net (Left name) $ evalBlock . inner + withNode net (Left name) $ runStep . inner - Spawn tvname@(TypedVarName (VarName tname)) target inner -> do + Spawn tvname@(TypedVarName (VarName tname)) target args inner -> do case target of Left net -> withNode net (Right tvname) go Right node -> go node @@ -126,34 +188,42 @@ evalBlock (TestBlock steps) = forM_ steps $ \case opts <- asks $ teOptions . fst let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) - withProcess (Right node) pname Nothing tool $ evalBlock . inner + cmd = unwords $ tool : map (T.unpack . escape) args + escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" + withProcess (Right node) pname Nothing cmd $ runStep . inner + + SpawnShell mbname node script inner -> do + let tname | Just (TypedVarName (VarName name)) <- mbname = name + | otherwise = "shell" + let pname = ProcName tname + withShellProcess node pname script $ runStep . inner Send p line -> do outProc OutputChildStdin p line send p line Expect line p expr captures inner -> do - expect line p expr captures $ evalBlock . inner + expect line p expr captures $ runStep . inner Flush p regex -> do - flush p regex + 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..." @@ -243,20 +313,15 @@ 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 - [ " ", textVarName 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 + timeout <- liftIO . readMVar =<< asks (teTimeout . fst) delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do line <- readTVar (procOutput p) @@ -270,27 +335,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 (CallStack [ ( sline, [] ) ])) p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline throwError Failed - forM_ vars $ \name -> do - cur <- asks (lookup name . tsVars . snd) - when (isJust cur) $ do - outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` textSourceLine sline - 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") (CallStack [ ( sline, trace ) ]) (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 3739e2e..f681e99 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -7,6 +7,7 @@ module Run.Monad ( finally, forkTest, + forkTestUsing, ) where import Control.Concurrent @@ -14,31 +15,41 @@ 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.Set (Set) import Data.Scientific -import qualified Data.Text as T +import Data.Set (Set) +import Data.Text qualified as T import {-# SOURCE #-} GDB import Network.Ip import Output import {-# SOURCE #-} Process -import Test +import Script.Expr +import Script.Object -newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a } - deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO) +newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed (WriterT [ SomeObject TestRun ] IO)) a } + deriving + ( Functor, Applicative, Monad + , MonadReader ( TestEnv, TestState ) + , MonadWriter [ SomeObject TestRun ] + , MonadIO + ) data TestEnv = TestEnv { teOutput :: Output , teFailed :: TVar (Maybe Failed) , teOptions :: TestOptions - , teProcesses :: MVar [Process] + , teNextObjId :: MVar Int + , teProcesses :: MVar [ Process ] + , teTimeout :: MVar Scientific , teGDB :: Maybe (MVar GDB) } data TestState = TestState - { tsVars :: [(VarName, SomeVarValue)] + { tsGlobals :: GlobalDefs + , tsLocals :: [ ( VarName, SomeVarValue ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific @@ -91,8 +102,9 @@ instance MonadError Failed TestRun where catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler instance MonadEval TestRun where - askDictionary = asks (tsVars . snd) - withDictionary f = local (fmap $ \s -> s { tsVars = f (tsVars s) }) + askGlobalDefs = asks (tsGlobals . snd) + askDictionary = asks (tsLocals . snd) + withDictionary f = local (fmap $ \s -> s { tsLocals = f (tsLocals s) }) instance MonadOutput TestRun where getOutput = asks $ teOutput . fst @@ -107,10 +119,14 @@ finally act handler = do void handler return x -forkTest :: TestRun () -> TestRun () -forkTest act = do +forkTest :: TestRun () -> TestRun ThreadId +forkTest = forkTestUsing forkIO + +forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId +forkTestUsing fork act = do tenv <- ask - void $ liftIO $ forkIO $ do - runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case + liftIO $ fork $ do + ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act) + case res of Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e) Right () -> return () diff --git a/src/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 new file mode 100644 index 0000000..4e99a26 --- /dev/null +++ b/src/Script/Expr.hs @@ -0,0 +1,452 @@ +module Script.Expr ( + Expr(..), varExpr, mapExpr, + + MonadEval(..), VariableDictionary, GlobalDefs, + lookupVar, tryLookupVar, withVar, withTypedVar, + eval, evalSome, evalSomeWith, + + FunctionType, DynamicType, + ExprType(..), SomeExpr(..), + TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, + + VarValue(..), SomeVarValue(..), + svvVariables, svvArguments, + someConstValue, fromConstValue, + fromSomeVarValue, textSomeVarValue, someVarValueType, + + ArgumentKeyword(..), FunctionArguments(..), + anull, exprArgs, + SomeArgumentType(..), ArgumentType(..), + + Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars, + AppAnnotation(..), + + module Script.Var, + + Regex(RegexPart, RegexString), + regexCompile, regexMatch, +) where + +import Control.Monad +import Control.Monad.Reader + +import Data.Char +import Data.Foldable +import Data.List +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe +import Data.Scientific +import Data.String +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable + +import Text.Regex.TDFA qualified as RE +import Text.Regex.TDFA.Text qualified as RE + +import Script.Expr.Class +import Script.Var +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) + 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 => SourceLine -> Expr (FunctionType a) -> 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 + Concat :: [ Expr Text ] -> Expr Text + Regex :: [ Expr Regex ] -> Expr Regex + Undefined :: String -> Expr a + Trace :: Expr a -> Expr (Traced a) + +data AppAnnotation b = AnnNone + | ExprType b => AnnRecord Text + +instance Functor Expr where + fmap f x = Pure f <*> x + +instance Applicative Expr where + pure = Pure + (<*>) = App AnnNone + +instance Semigroup a => Semigroup (Expr a) where + e <> f = (<>) <$> e <*> f + +instance Monoid a => Monoid (Expr a) where + mempty = Pure mempty + +varExpr :: ExprType a => SourceLine -> TypedVarName a -> Expr a +varExpr sline (TypedVarName name) = Variable sline (LocalVarName name) + +mapExpr :: forall a. (forall b. Expr b -> Expr b) -> Expr a -> Expr a +mapExpr f = go + where + go :: forall c. Expr c -> Expr c + go = \case + Let sline vname vval expr -> f $ Let sline vname (go vval) (go expr) + e@Variable {} -> f e + e@DynVariable {} -> f e + e@FunVariable {} -> 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 sline expr -> f $ FunctionEval sline (go expr) + LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr) + e@Pure {} -> f e + App ann efun earg -> f $ App ann (go efun) (go earg) + e@Concat {} -> f e + e@Regex {} -> f e + e@Undefined {} -> f e + Trace expr -> f $ Trace (go expr) + + + +class MonadFail m => MonadEval m where + askGlobalDefs :: m GlobalDefs + askDictionary :: m VariableDictionary + withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a + +type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue + +type VariableDictionary = [ ( VarName, SomeVarValue ) ] + +lookupVar :: MonadEval m => FqVarName -> m SomeVarValue +lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name + +tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue) +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 ) : ) + +withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a +withTypedVar (TypedVarName name) = withVar name + + +newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a) + deriving (Functor, Applicative, Monad) + +runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a +runSimpleEval (SimpleEval x) = curry $ runReader x + +instance MonadFail SimpleEval where + fail = error . ("eval failed: " <>) + +instance MonadEval SimpleEval where + askGlobalDefs = SimpleEval (asks fst) + askDictionary = SimpleEval (asks snd) + withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner) + +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 _ name -> fromSomeVarValue (CallStack []) name =<< lookupVar name + DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’" + FunVariable _ _ name -> funFromSomeVarValue name =<< lookupVar name + ArgsReq (FunctionArguments req) efun -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ FunctionType $ \stack (FunctionArguments args) -> + let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req + FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict) + in fun stack $ FunctionArguments $ args `M.difference` req + ArgsApp eargs efun -> do + FunctionType fun <- eval efun + args <- mapM evalSome eargs + return $ FunctionType $ \stack args' -> fun stack (args <> args') + FunctionAbstraction expr -> do + val <- eval expr + return $ FunctionType $ const $ const val + FunctionEval sline efun -> do + FunctionType fun <- eval efun + vars <- gatherVars efun + return $ fun (CallStack [ ( sline, vars ) ]) mempty + LambdaAbstraction (TypedVarName name) expr -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict) + Pure value -> return value + App _ f x -> eval f <*> eval x + Concat xs -> T.concat <$> mapM eval xs + Regex xs -> mapM eval xs >>= \case + [ re@RegexCompiled {} ] -> return re + parts -> case regexCompile $ T.concat $ map regexSource parts of + Left err -> fail err + Right re -> return re + Undefined err -> fail err + Trace expr -> Traced <$> gatherVars expr <*> eval expr + +evalToVarValue :: MonadEval m => Expr a -> m (VarValue a) +evalToVarValue expr = do + VarValue + <$> gatherVars expr + <*> pure mempty + <*> (const . const <$> eval expr) + +evalFunToVarValue :: MonadEval m => Expr (FunctionType a) -> m (VarValue a) +evalFunToVarValue expr = do + FunctionType fun <- eval expr + VarValue + <$> gatherVars expr + <*> pure (exprArgs expr) + <*> pure fun + +evalSome :: MonadEval m => SomeExpr -> m SomeVarValue +evalSome (SomeExpr expr) + | IsFunType <- asFunType expr = SomeVarValue <$> evalFunToVarValue expr + | otherwise = SomeVarValue <$> evalToVarValue expr + +evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue +evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs [] + + +data FunctionType a = FunctionType (CallStack -> FunctionArguments SomeVarValue -> a) + +instance ExprType a => ExprType (FunctionType a) where + textExprType _ = "function type" + textExprValue _ = "<function type>" + +data DynamicType + +instance ExprType DynamicType where + textExprType _ = "ambiguous type" + textExprValue _ = "<dynamic type>" + + +data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) + +newtype TypeVar = TypeVar Text + deriving (Eq, Ord) + +data SomeExprType + = forall a. ExprType a => ExprTypePrim (Proxy a) + | ExprTypeVar TypeVar + | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a) + +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" + + proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a + proxyOfFunctionType _ = Proxy + +textSomeExprType :: SomeExprType -> Text +textSomeExprType (ExprTypePrim p) = textExprType p +textSomeExprType (ExprTypeVar (TypeVar name)) = name +textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r + +data AsFunType a + = forall b. (a ~ FunctionType b, ExprType b) => IsFunType + | NotFunType + +asFunType :: Expr a -> AsFunType a +asFunType = \case + Let _ _ _ expr -> asFunType expr + FunVariable {} -> IsFunType + ArgsReq {} -> IsFunType + ArgsApp {} -> IsFunType + FunctionAbstraction {} -> IsFunType + _ -> NotFunType + + +data VarValue a = VarValue + { vvVariables :: EvalTrace + , vvArguments :: FunctionArguments SomeArgumentType + , vvFunction :: CallStack -> FunctionArguments SomeVarValue -> a + } + +data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a) + +svvVariables :: SomeVarValue -> EvalTrace +svvVariables (SomeVarValue vv) = vvVariables vv + +svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType +svvArguments (SomeVarValue vv) = vvArguments vv + +someConstValue :: ExprType a => a -> SomeVarValue +someConstValue = SomeVarValue . VarValue [] mempty . const . const + +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 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) => 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 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 :: 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) + + +newtype ArgumentKeyword = ArgumentKeyword Text + deriving (Show, Eq, Ord, IsString) + +newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a) + deriving (Show, Semigroup, Monoid, Functor, Foldable, Traversable) + +anull :: FunctionArguments a -> Bool +anull (FunctionArguments args) = M.null args + +exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType +exprArgs = \case + Let _ _ _ expr -> exprArgs expr + Variable {} -> mempty + FunVariable args _ _ -> 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 + Pure {} -> error "exprArgs: pure" + App {} -> error "exprArgs: app" + Undefined {} -> error "exprArgs: undefined" + +funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => FqVarName -> SomeVarValue -> m (FunctionType a) +funFromSomeVarValue name (SomeVarValue (VarValue _ args value :: VarValue b)) = do + maybe (fail err) return $ do + FunctionType <$> cast value + 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 ArgumentType a + = RequiredArgument + | OptionalArgument + | ExprDefault (Expr a) + | ContextDefault + + +data Traced a = Traced EvalTrace a + +type VarNameSelectors = ( FqVarName, [ Text ] ) +type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ] +newtype CallStack = CallStack [ ( SourceLine, EvalTrace ) ] + +gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace +gatherVars = fmap (uniqOn fst . sortOn fst) . helper + where + helper :: forall b. Expr b -> m EvalTrace + helper = \case + Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr + Variable _ var + | GlobalVarName {} <- var -> return [] + | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + DynVariable _ _ var + | GlobalVarName {} <- var -> return [] + | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + FunVariable _ _ var + | GlobalVarName {} <- var -> return [] + | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + 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 + 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 ) ] + | otherwise -> do + helper x + App _ f x -> (++) <$> helper f <*> helper x + Concat es -> concat <$> mapM helper es + Regex es -> concat <$> mapM helper es + Undefined {} -> return [] + Trace expr -> helper expr + + gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] ) + gatherSelectors = \case + Variable _ var -> Just (var, []) + App (AnnRecord sel) _ x -> do + (var, sels) <- gatherSelectors x + return (var, sels ++ [sel]) + _ -> Nothing + + +data Regex = RegexCompiled Text RE.Regex + | RegexPart Text + | RegexString Text + +instance ExprType Regex where + textExprType _ = T.pack "regex" + textExprValue _ = T.pack "<regex>" + + exprExpansionConvFrom = listToMaybe $ catMaybes + [ cast (RegexString) + , cast (RegexString . T.pack . show @Integer) + , cast (RegexString . T.pack . show @Scientific) + ] + +regexCompile :: Text -> Either String Regex +regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $ + T.singleton '^' <> src <> T.singleton '$' + +regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text])) +regexMatch (RegexCompiled _ re) text = RE.regexec re text +regexMatch _ _ = Left "regex not compiled" + +regexSource :: Regex -> Text +regexSource (RegexCompiled src _) = src +regexSource (RegexPart src) = src +regexSource (RegexString str) = T.concatMap escapeChar str + where + escapeChar c | isAlphaNum c = T.singleton c + | c `elem` ['`', '\'', '<', '>'] = T.singleton c + | otherwise = T.pack ['\\', c] diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs new file mode 100644 index 0000000..20a92b4 --- /dev/null +++ b/src/Script/Expr/Class.hs @@ -0,0 +1,77 @@ +module Script.Expr.Class ( + ExprType(..), + RecordSelector(..), + ExprListUnpacker(..), + ExprEnumerator(..), +) where + +import Data.Maybe +import Data.Scientific +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable +import Data.Void + +class Typeable a => ExprType a where + textExprType :: proxy a -> Text + textExprValue :: a -> Text + + recordMembers :: [(Text, RecordSelector a)] + recordMembers = [] + + exprExpansionConvTo :: ExprType b => Maybe (a -> b) + exprExpansionConvTo = Nothing + + exprExpansionConvFrom :: ExprType b => Maybe (b -> a) + exprExpansionConvFrom = Nothing + + exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a) + exprListUnpacker _ = Nothing + + exprEnumerator :: proxy a -> Maybe (ExprEnumerator a) + exprEnumerator _ = Nothing + + +data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) + +data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e) + +data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) + + +instance ExprType Integer where + textExprType _ = T.pack "integer" + textExprValue x = T.pack (show x) + + exprExpansionConvTo = listToMaybe $ catMaybes + [ cast (T.pack . show :: Integer -> Text) + ] + + exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo + +instance ExprType Scientific where + textExprType _ = T.pack "number" + textExprValue x = T.pack (show x) + + exprExpansionConvTo = listToMaybe $ catMaybes + [ cast (T.pack . show :: Scientific -> Text) + ] + +instance ExprType Bool where + textExprType _ = T.pack "bool" + textExprValue True = T.pack "true" + textExprValue False = T.pack "false" + +instance ExprType Text where + textExprType _ = T.pack "string" + textExprValue x = T.pack (show x) + +instance ExprType Void where + textExprType _ = T.pack "void" + textExprValue _ = T.pack "<void>" + +instance ExprType a => ExprType [a] where + textExprType _ = "[" <> textExprType @a Proxy <> "]" + textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" + + exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) diff --git a/src/Script/Module.hs b/src/Script/Module.hs new file mode 100644 index 0000000..3ea59bf --- /dev/null +++ b/src/Script/Module.hs @@ -0,0 +1,20 @@ +module Script.Module ( + Module(..), + ModuleName(..), textModuleName, + moduleExportedDefinitions, +) where + +import Script.Expr +import Test + +data Module = Module + { moduleName :: ModuleName + , moduleTests :: [ Test ] + , moduleDefinitions :: [ ( VarName, SomeExpr ) ] + , moduleExports :: [ VarName ] + } + +moduleExportedDefinitions :: Module -> [ ( VarName, ( FqVarName, SomeExpr )) ] +moduleExportedDefinitions Module {..} = + map (\( var, expr ) -> ( var, ( GlobalVarName moduleName var, expr ))) $ + filter ((`elem` moduleExports) . fst) moduleDefinitions diff --git a/src/Script/Object.hs b/src/Script/Object.hs new file mode 100644 index 0000000..9232b21 --- /dev/null +++ b/src/Script/Object.hs @@ -0,0 +1,42 @@ +module Script.Object ( + ObjectId(..), + ObjectType(..), + Object(..), SomeObject(..), + toSomeObject, fromSomeObject, + destroySomeObject, +) where + +import Data.Kind +import Data.Typeable + + +newtype ObjectId = ObjectId Int + +class Typeable a => ObjectType m a where + type ConstructorArgs a :: Type + type ConstructorArgs a = () + + createObject :: ObjectId -> ConstructorArgs a -> m (Object m a) + destroyObject :: Object m a -> m () + +data Object m a = ObjectType m a => Object + { objId :: ObjectId + , objImpl :: a + } + +data SomeObject m = forall a. ObjectType m a => SomeObject + { sobjId :: ObjectId + , sobjImpl :: a + } + +toSomeObject :: Object m a -> SomeObject m +toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl } + +fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a) +fromSomeObject SomeObject {..} = do + let objId = sobjId + objImpl <- cast sobjImpl + return Object {..} + +destroySomeObject :: SomeObject m -> m () +destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl) diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs new file mode 100644 index 0000000..23c3891 --- /dev/null +++ b/src/Script/Shell.hs @@ -0,0 +1,170 @@ +module Script.Shell ( + ShellScript(..), + ShellStatement(..), + ShellPipeline(..), + ShellCommand(..), + withShellProcess, +) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Reader + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T + +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Marshal.Array +import Foreign.Storable + +import System.Exit +import System.IO +import System.Posix.IO qualified as P +import System.Posix.Types +import System.Process hiding (ShellCommand) + +import Network +import Network.Ip +import Output +import Process +import Run.Monad +import Script.Var + + +newtype ShellScript = ShellScript [ ShellStatement ] + +data ShellStatement = ShellStatement + { shellPipeline :: ShellPipeline + , shellSourceLine :: SourceLine + } + +data ShellPipeline = ShellPipeline + { pipeCommand :: ShellCommand + , pipeUpstream :: Maybe ShellPipeline + } + +data ShellCommand = ShellCommand + { cmdCommand :: Text + , cmdArguments :: [ Text ] + , cmdSourceLine :: SourceLine + } + + +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 ShellCommand {..} = do + case cmdCommand of + "echo" -> liftIO $ do + T.hPutStrLn (handledHandle pstdout) $ T.intercalate " " cmdArguments + hFlush (handledHandle pstdout) + mapM_ closeIfRequested [ pstdin, pstdout, pstderr ] + cmd -> do + (_, _, _, phandle) <- liftIO $ createProcess_ "shell" + (proc (T.unpack cmd) (map T.unpack cmdArguments)) + { std_in = UseHandle $ handledHandle pstdin + , std_out = UseHandle $ handledHandle pstdout + , std_err = UseHandle $ handledHandle pstderr + , cwd = Just (nodeDir seiNode) + , env = Just [] + } + mapM_ closeIfRequested [ pstdin, pstdout, pstderr ] + liftIO (waitForProcess phandle) >>= \case + ExitSuccess -> return () + status -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "failed at: " <> textSourceLine cmdSourceLine + liftIO $ putMVar seiStatusVar status + 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 + procOutput <- liftIO $ newTVarIO [] + 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 process = Process {..} + + startProcessIOLoops process hout herr + return process + +withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a +withShellProcess node pname script inner = do + procVar <- asks $ teProcesses . fst + + process <- spawnShell node pname script + liftIO $ modifyMVar_ procVar $ return . (process:) + + inner process `finally` do + ps <- liftIO $ takeMVar procVar + 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 new file mode 100644 index 0000000..668060c --- /dev/null +++ b/src/Script/Var.hs @@ -0,0 +1,56 @@ +module Script.Var ( + VarName(..), textVarName, unpackVarName, + FqVarName(..), textFqVarName, unpackFqVarName, unqualifyName, + TypedVarName(..), + ModuleName(..), textModuleName, + SourceLine(..), textSourceLine, +) where + +import Data.Text (Text) +import Data.Text qualified as T + + +newtype VarName = VarName Text + deriving (Eq, Ord) + +textVarName :: VarName -> Text +textVarName (VarName name) = name + +unpackVarName :: VarName -> String +unpackVarName = T.unpack . textVarName + + +data FqVarName + = GlobalVarName ModuleName VarName + | LocalVarName VarName + deriving (Eq, Ord) + +textFqVarName :: FqVarName -> Text +textFqVarName (GlobalVarName mname vname) = textModuleName mname <> "." <> textVarName vname +textFqVarName (LocalVarName vname) = textVarName vname + +unpackFqVarName :: FqVarName -> String +unpackFqVarName = T.unpack . textFqVarName + +unqualifyName :: FqVarName -> VarName +unqualifyName (GlobalVarName _ name) = name +unqualifyName (LocalVarName name) = name + + +newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName } + deriving (Eq, Ord) + + +newtype ModuleName = ModuleName [ Text ] + deriving (Eq, Ord, Show) + +textModuleName :: ModuleName -> Text +textModuleName (ModuleName parts) = T.intercalate "." parts + +data SourceLine + = SourceLine Text + | SourceLineBuiltin + +textSourceLine :: SourceLine -> Text +textSourceLine (SourceLine text) = text +textSourceLine SourceLineBuiltin = "<builtin>" diff --git a/src/Test.hs b/src/Test.hs index 01b2d95..ce88052 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,540 +1,81 @@ module Test ( - Module(..), ModuleName(..), textModuleName, Test(..), TestStep(..), TestBlock(..), - SourceLine(..), textSourceLine, - MonadEval(..), lookupVar, tryLookupVar, withVar, - VarName(..), TypedVarName(..), textVarName, unpackVarName, withTypedVar, - ExprType(..), SomeExpr(..), - TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, - FunctionType, DynamicType, - - VarValue(..), SomeVarValue(..), - svvVariables, svvArguments, - someConstValue, fromConstValue, - fromSomeVarValue, textSomeVarValue, someVarValueType, - - RecordSelector(..), - ExprListUnpacker(..), - ExprEnumerator(..), - Expr(..), varExpr, mapExpr, eval, evalSome, - Traced(..), EvalTrace, VarNameSelectors, gatherVars, - AppAnnotation(..), - - ArgumentKeyword(..), FunctionArguments(..), - anull, exprArgs, - SomeArgumentType(..), ArgumentType(..), - - Regex(RegexPart, RegexString), regexMatch, + MultiplyTimeout(..), ) where -import Control.Monad +import Control.Concurrent.MVar +import Control.Monad.Except import Control.Monad.Reader -import Data.Char -import Data.Foldable -import Data.List -import Data.Map (Map) -import Data.Map qualified as M import Data.Scientific -import Data.String import Data.Text (Text) -import Data.Text qualified as T import Data.Typeable -import Data.Void - -import Text.Regex.TDFA qualified as RE -import Text.Regex.TDFA.Text qualified as RE - -import {-# SOURCE #-} Network -import {-# SOURCE #-} Process -import Util -data Module = Module - { moduleName :: ModuleName - , moduleTests :: [ Test ] - , moduleDefinitions :: [ ( VarName, SomeExpr ) ] - , moduleExports :: [ VarName ] - } - -newtype ModuleName = ModuleName [ Text ] - deriving (Eq, Ord) - -textModuleName :: ModuleName -> Text -textModuleName (ModuleName parts) = T.intercalate "." parts +import Network +import Output +import Process +import Run.Monad +import Script.Expr +import Script.Object +import Script.Shell data Test = Test { testName :: Text - , testSteps :: Expr TestBlock + , testSteps :: Expr (TestStep ()) } -newtype TestBlock = TestBlock [ TestStep ] - deriving (Semigroup, Monoid) - -data TestStep - = Subnet (TypedVarName Network) Network (Network -> TestBlock) - | DeclNode (TypedVarName Node) Network (Node -> TestBlock) - | Spawn (TypedVarName Process) (Either Network Node) (Process -> TestBlock) - | Send Process Text - | Expect SourceLine Process (Traced Regex) [ TypedVarName Text ] ([ Text ] -> TestBlock) - | Flush Process (Maybe Regex) - | Guard SourceLine EvalTrace Bool - | DisconnectNode Node TestBlock - | DisconnectNodes Network TestBlock - | DisconnectUpstream Network TestBlock - | PacketLoss Scientific Node TestBlock - | Wait - -data SourceLine - = SourceLine Text - | SourceLineBuiltin - -textSourceLine :: SourceLine -> Text -textSourceLine (SourceLine text) = text -textSourceLine SourceLineBuiltin = "<builtin>" - - -class MonadFail m => MonadEval m where - askDictionary :: m VariableDictionary - withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a - -type VariableDictionary = [ ( VarName, SomeVarValue ) ] - -lookupVar :: MonadEval m => VarName -> m SomeVarValue -lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return . lookup name =<< askDictionary - -tryLookupVar :: MonadEval m => VarName -> m (Maybe SomeVarValue) -tryLookupVar name = lookup name <$> askDictionary - -withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a -withVar name value = withDictionary (( name, someConstValue value ) : ) - -newtype VarName = VarName Text - deriving (Eq, Ord, Show) - -newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName } - deriving (Eq, Ord) - -textVarName :: VarName -> Text -textVarName (VarName name ) = name - -unpackVarName :: VarName -> String -unpackVarName = T.unpack . textVarName - -isInternalVar :: VarName -> Bool -isInternalVar (VarName name) - | Just ( '$', _ ) <- T.uncons name = True - | otherwise = False - -withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a -withTypedVar (TypedVarName name) = withVar name - - -class Typeable a => ExprType a where - textExprType :: proxy a -> Text - textExprValue :: a -> Text - - recordMembers :: [(Text, RecordSelector a)] - recordMembers = [] - - exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a) - exprListUnpacker _ = Nothing - - exprEnumerator :: proxy a -> Maybe (ExprEnumerator a) - exprEnumerator _ = Nothing - -instance ExprType Integer where - textExprType _ = T.pack "integer" - textExprValue x = T.pack (show x) - - exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo - -instance ExprType Scientific where - textExprType _ = T.pack "number" - textExprValue x = T.pack (show x) - -instance ExprType Bool where - textExprType _ = T.pack "bool" - textExprValue True = T.pack "true" - textExprValue False = T.pack "false" - -instance ExprType Text where - textExprType _ = T.pack "string" - textExprValue x = T.pack (show x) - -instance ExprType Regex where - textExprType _ = T.pack "regex" - textExprValue _ = T.pack "<regex>" - -instance ExprType Void where - textExprType _ = T.pack "void" - textExprValue _ = T.pack "<void>" - -instance ExprType a => ExprType [a] where - textExprType _ = "[" <> textExprType @a Proxy <> "]" - textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" - - exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) - -instance ExprType TestBlock where +data TestBlock a where + EmptyTestBlock :: TestBlock () + TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a + +instance Semigroup (TestBlock ()) where + EmptyTestBlock <> block = block + block <> EmptyTestBlock = block + block <> TestBlockStep block' step = TestBlockStep (block <> block') step + +instance Monoid (TestBlock ()) where + mempty = EmptyTestBlock + +data TestStep a where + Scope :: TestBlock a -> TestStep a + CreateObject :: forall o. ObjectType TestRun o => Proxy o -> ConstructorArgs o -> TestStep () + Subnet :: TypedVarName Network -> Network -> (Network -> TestStep a) -> TestStep a + DeclNode :: TypedVarName Node -> Network -> (Node -> TestStep a) -> TestStep a + Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> (Process -> TestStep a) -> TestStep a + SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a + Send :: Process -> Text -> TestStep () + Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a + Flush :: Process -> Maybe Regex -> TestStep () + 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>" -data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a) - -instance ExprType a => ExprType (FunctionType a) where - textExprType _ = "function type" - textExprValue _ = "<function type>" - -data DynamicType - -instance ExprType DynamicType where - textExprType _ = "ambiguous type" - textExprValue _ = "<dynamic type>" - -data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) - -newtype TypeVar = TypeVar Text - deriving (Eq, Ord) - -data SomeExprType - = forall a. ExprType a => ExprTypePrim (Proxy a) - | ExprTypeVar TypeVar - | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a) - -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" - - proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a - proxyOfFunctionType _ = Proxy - -textSomeExprType :: SomeExprType -> Text -textSomeExprType (ExprTypePrim p) = textExprType p -textSomeExprType (ExprTypeVar (TypeVar name)) = name -textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r - -data AsFunType a - = forall b. (a ~ FunctionType b, ExprType b) => IsFunType - | NotFunType - -asFunType :: Expr a -> AsFunType a -asFunType = \case - Let _ _ _ expr -> asFunType expr - FunVariable {} -> IsFunType - ArgsReq {} -> IsFunType - ArgsApp {} -> IsFunType - FunctionAbstraction {} -> IsFunType - _ -> NotFunType - - -data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a) - -svvVariables :: SomeVarValue -> EvalTrace -svvVariables (SomeVarValue vv) = vvVariables vv - -svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType -svvArguments (SomeVarValue vv) = vvArguments vv - -data VarValue a = VarValue - { vvVariables :: EvalTrace - , vvArguments :: FunctionArguments SomeArgumentType - , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a - } - -someConstValue :: ExprType a => a -> SomeVarValue -someConstValue = SomeVarValue . VarValue [] mempty . const . const - -fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> VarValue a -> m a -fromConstValue sline name (VarValue _ args value :: VarValue b) = do - maybe (fail err) return $ do - guard $ anull args - cast $ value sline mempty - where - err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", - if anull args then textExprType @b Proxy else "function type" ] - -fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m a -fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do - maybe (fail err) return $ do - guard $ anull args - cast $ value sline mempty - where - err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName 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 - | otherwise = "<function>" - -someVarValueType :: SomeVarValue -> SomeExprType -someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a)) - | anull args = ExprTypePrim (Proxy @a) - | otherwise = ExprTypeFunction args (Proxy @a) - - -data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) - -data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e) - -data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) - - -data Expr a where - Let :: forall a b. ExprType b => SourceLine -> TypedVarName b -> Expr b -> Expr a -> Expr a - Variable :: ExprType a => SourceLine -> VarName -> Expr a - DynVariable :: TypeVar -> SourceLine -> VarName -> Expr DynamicType - FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> VarName -> Expr (FunctionType 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 - LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b) - Pure :: a -> Expr a - App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b - Concat :: [Expr Text] -> Expr Text - Regex :: [Expr Regex] -> Expr Regex - Undefined :: String -> Expr a - Trace :: Expr a -> Expr (Traced a) - -data AppAnnotation b = AnnNone - | ExprType b => AnnRecord Text - -instance Functor Expr where - fmap f x = Pure f <*> x - -instance Applicative Expr where - pure = Pure - (<*>) = App AnnNone - -instance Semigroup a => Semigroup (Expr a) where - e <> f = (<>) <$> e <*> f - -instance Monoid a => Monoid (Expr a) where - mempty = Pure mempty - -varExpr :: ExprType a => SourceLine -> TypedVarName a -> Expr a -varExpr sline (TypedVarName name) = Variable sline name - -mapExpr :: forall a. (forall b. Expr b -> Expr b) -> Expr a -> Expr a -mapExpr f = go - where - go :: forall c. Expr c -> Expr c - go = \case - Let sline vname vval expr -> f $ Let sline vname (go vval) (go expr) - e@Variable {} -> f e - e@DynVariable {} -> f e - e@FunVariable {} -> 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) - LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr) - e@Pure {} -> f e - App ann efun earg -> f $ App ann (go efun) (go earg) - e@Concat {} -> f e - e@Regex {} -> f e - e@Undefined {} -> f e - Trace expr -> f $ Trace (go expr) - - -newtype SimpleEval a = SimpleEval (Reader VariableDictionary a) - deriving (Functor, Applicative, Monad) - -runSimpleEval :: SimpleEval a -> VariableDictionary -> a -runSimpleEval (SimpleEval x) = runReader x - -instance MonadFail SimpleEval where - fail = error . ("eval failed: " <>) - -instance MonadEval SimpleEval where - askDictionary = SimpleEval ask - withDictionary f (SimpleEval inner) = SimpleEval (local f inner) - - -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 - DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackVarName name <> "’" - FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name - ArgsReq (FunctionArguments req) efun -> do - dict <- askDictionary - return $ FunctionType $ \(FunctionArguments args) -> - let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req - FunctionType fun = runSimpleEval (eval efun) (toList used ++ dict) - in fun $ FunctionArguments $ args `M.difference` req - ArgsApp eargs efun -> do - FunctionType fun <- eval efun - args <- mapM evalSome eargs - return $ FunctionType $ \args' -> fun (args <> args') - FunctionAbstraction expr -> do - val <- eval expr - return $ FunctionType $ const val - FunctionEval efun -> do - FunctionType fun <- eval efun - return $ fun mempty - LambdaAbstraction (TypedVarName name) expr -> do - dict <- askDictionary - return $ \x -> runSimpleEval (eval expr) (( name, someConstValue x ) : dict) - Pure value -> return value - App _ f x -> eval f <*> eval x - Concat xs -> T.concat <$> mapM eval xs - Regex xs -> mapM eval xs >>= \case - [ re@RegexCompiled {} ] -> return re - parts -> case regexCompile $ T.concat $ map regexSource parts of - Left err -> fail err - Right re -> return re - Undefined err -> fail err - Trace expr -> Traced <$> gatherVars expr <*> eval expr - -evalSome :: MonadEval m => SomeExpr -> m SomeVarValue -evalSome (SomeExpr expr) - | IsFunType <- asFunType expr = do - FunctionType fun <- eval expr - fmap SomeVarValue $ VarValue - <$> gatherVars expr - <*> pure (exprArgs expr) - <*> pure (const fun) - | otherwise = do - fmap SomeVarValue $ VarValue - <$> gatherVars expr - <*> pure mempty - <*> (const . const <$> eval expr) - -data Traced a = Traced EvalTrace a - -type VarNameSelectors = ( VarName, [ Text ] ) -type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ] - -gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace -gatherVars = fmap (uniqOn fst . sortOn fst) . helper - where - 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 - 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 - 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 ) ] - | otherwise -> do - helper x - App _ f x -> (++) <$> helper f <*> helper x - Concat es -> concat <$> mapM helper es - Regex es -> concat <$> mapM helper es - Undefined {} -> return [] - Trace expr -> helper expr - - gatherSelectors :: forall b. Expr b -> Maybe (VarName, [Text]) - gatherSelectors = \case - Variable _ var -> Just (var, []) - App (AnnRecord sel) _ x -> do - (var, sels) <- gatherSelectors x - return (var, sels ++ [sel]) - _ -> Nothing - - -newtype ArgumentKeyword = ArgumentKeyword Text - deriving (Show, Eq, Ord, IsString) - -newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a) - deriving (Show, Semigroup, Monoid, Functor, Foldable, Traversable) - -anull :: FunctionArguments a -> Bool -anull (FunctionArguments args) = M.null args - -exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType -exprArgs = \case - Let _ _ _ expr -> exprArgs expr - Variable {} -> mempty - FunVariable args _ _ -> 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 - Pure {} -> error "exprArgs: pure" - App {} -> error "exprArgs: app" - Undefined {} -> error "exprArgs: undefined" - -funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m (FunctionType a) -funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do - maybe (fail err) return $ do - guard $ not $ anull args - FunctionType <$> cast (value sline) - where - err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textVarName 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 ArgumentType a - = RequiredArgument - | OptionalArgument - | ExprDefault (Expr a) - | ContextDefault - +data MultiplyTimeout = MultiplyTimeout Scientific -data Regex = RegexCompiled Text RE.Regex - | RegexPart Text - | RegexString Text +instance ObjectType TestRun MultiplyTimeout where + type ConstructorArgs MultiplyTimeout = Scientific -regexCompile :: Text -> Either String Regex -regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $ - T.singleton '^' <> src <> T.singleton '$' + createObject oid timeout + | timeout > 0 = do + var <- asks (teTimeout . fst) + liftIO $ modifyMVar_ var $ return . (* timeout) + return $ Object oid $ MultiplyTimeout timeout -regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text])) -regexMatch (RegexCompiled _ re) text = RE.regexec re text -regexMatch _ _ = Left "regex not compiled" + | otherwise = do + outLine OutputError Nothing "timeout must be positive" + throwError Failed -regexSource :: Regex -> Text -regexSource (RegexCompiled src _) = src -regexSource (RegexPart src) = src -regexSource (RegexString str) = T.concatMap escapeChar str - where - escapeChar c | isAlphaNum c = T.singleton c - | c `elem` ['`', '\'', '<', '>'] = T.singleton c - | otherwise = T.pack ['\\', c] + destroyObject Object { objImpl = MultiplyTimeout timeout } = do + var <- asks (teTimeout . fst) + liftIO $ modifyMVar_ var $ return . (/ timeout) diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index a676a35..5f9f890 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -4,33 +4,36 @@ module Test.Builtins ( import Data.Map qualified as M import Data.Maybe +import Data.Proxy +import Data.Scientific import Data.Text (Text) -import Process (Process) +import Process +import Script.Expr import Test -builtins :: [ ( VarName, SomeVarValue ) ] -builtins = - [ ( VarName "send", builtinSend ) - , ( VarName "flush", builtinFlush ) - , ( VarName "guard", builtinGuard ) - , ( VarName "wait", builtinWait ) +builtins :: GlobalDefs +builtins = M.fromList + [ fq "send" builtinSend + , fq "flush" builtinFlush + , fq "ignore" builtinIgnore + , fq "guard" builtinGuard + , fq "multiply_timeout" builtinMultiplyTimeout + , fq "wait" builtinWait ] + where + fq name impl = (( ModuleName [ "$" ], VarName name ), impl ) getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a getArg args = fromMaybe (error "parameter mismatch") . getArgMb args getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a getArgMb (FunctionArguments args) kw = do - fromSomeVarValue SourceLineBuiltin (VarName "") =<< M.lookup kw args - -getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( VarName, [ Text ] ), SomeVarValue ) ] -getArgVars (FunctionArguments args) kw = do - maybe [] svvVariables $ M.lookup kw args + fromSomeVarValue (CallStack []) (LocalVarName (VarName "")) =<< M.lookup kw args builtinSend :: SomeVarValue builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ] + \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing) where atypes = [ ( Just "to", SomeArgumentType (ContextDefault @Process) ) @@ -39,7 +42,16 @@ builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) builtinFlush :: SomeVarValue builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ] + \_ args -> TestBlockStep EmptyTestBlock $ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) + where + atypes = + [ ( Just "from", SomeArgumentType (ContextDefault @Process) ) + , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) ) + ] + +builtinIgnore :: SomeVarValue +builtinIgnore = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ + \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @IgnoreProcessOutput) ( getArg args (Just "from"), getArgMb args (Just "matching") ) where atypes = [ ( Just "from", SomeArgumentType (ContextDefault @Process) ) @@ -48,7 +60,11 @@ builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes builtinGuard :: SomeVarValue builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ - \sline args -> TestBlock [ Guard sline (getArgVars args Nothing) (getArg args Nothing) ] + \stack args -> TestBlockStep EmptyTestBlock $ Guard stack (getArg args Nothing) + +builtinMultiplyTimeout :: SomeVarValue +builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $ + \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @MultiplyTimeout) (getArg args (Just "by")) builtinWait :: SomeVarValue -builtinWait = someConstValue $ TestBlock [ Wait ] +builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait diff --git a/src/TestMode.hs b/src/TestMode.hs new file mode 100644 index 0000000..c052fb9 --- /dev/null +++ b/src/TestMode.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE CPP #-} + +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 + +import System.IO.Error + +import Text.Megaparsec.Error +import Text.Megaparsec.Pos + +import Config +import Output +import Parser +import Run +import Script.Expr +import Script.Module +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 :: Maybe Config -> IO () +testMode tmiConfig = do + tmiOutput <- startOutput OutputStyleTest False + let testLoop = getLineMb >>= \case + Just line -> do + case T.words line of + cname : tmiParams + | Just (CommandM cmd) <- lookup cname commands -> do + runReaderT cmd $ TestModeInput {..} + | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'" + [] -> return () + testLoop + + Nothing -> return () + + runExceptT (evalStateT testLoop initTestModeState) >>= \case + Left err -> flip runReaderT tmiOutput $ outLine OutputError Nothing $ T.pack err + Right () -> return () + +getLineMb :: MonadIO m => m (Maybe Text) +getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) + +cmdOut :: Text -> Command +cmdOut line = do + out <- asks tmiOutput + flip runReaderT out $ outLine OutputTestRaw Nothing line + +getNextTestNumber :: CommandM Int +getNextTestNumber = do + num <- gets tmsNextTestNumber + modify $ \s -> s { tmsNextTestNumber = num + 1 } + return num + +runSingleTest :: Test -> CommandM Bool +runSingleTest test = do + out <- asks tmiOutput + num <- getNextTestNumber + globals <- gets tmsGlobals + mbconfig <- asks tmiConfig + let opts = defaultTestOptions + { optDefaultTool = fromMaybe "" $ configTool =<< mbconfig + , optTestDir = ".test" <> show num + , optKeep = True + } + liftIO (runTest out opts globals test) + + +newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a) + deriving + ( Functor, Applicative, Monad, MonadIO + , MonadReader TestModeInput, MonadState TestModeState, MonadError String + ) + +instance MonadFail CommandM where + fail = throwError + +type Command = CommandM () + +commands :: [ ( Text, Command ) ] +commands = + [ ( "load", cmdLoad ) + , ( "load-config", cmdLoadConfig ) + , ( "run", cmdRun ) + , ( "run-all", cmdRunAll ) + ] + +cmdLoad :: Command +cmdLoad = do + [ path ] <- asks tmiParams + liftIO (parseTestFiles [ T.unpack path ]) >>= \case + Right ( modules, allModules ) -> do + let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules + modify $ \s -> s + { tmsModules = modules + , tmsGlobals = globalDefs + } + cmdOut "load-done" + + Left (ModuleNotFound moduleName) -> do + cmdOut $ "load-failed module-not-found" <> textModuleName moduleName + Left (FileNotFound notFoundPath) -> do + cmdOut $ "load-failed file-not-found " <> T.pack notFoundPath + Left (ImportModuleError bundle) -> do +#if MIN_VERSION_megaparsec(9,7,0) + mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle +#endif + cmdOut $ "load-failed parse-error" + where + showParseError _ SourcePos {..} _ = concat + [ "parse-error" + , " ", sourceName + , ":", show $ unPos sourceLine + , ":", show $ unPos sourceColumn + ] + +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 + TestModeState {..} <- get + case find ((name ==) . testName) $ concatMap moduleTests tmsModules of + Nothing -> cmdOut "run-not-found" + Just test -> do + 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,63 @@ 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 new_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 new_root/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 ){ + fprintf( stderr, "failed set new_root/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 new_root/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 +144,46 @@ 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 = 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/definition/basic.et b/test/asset/definition/basic.et new file mode 100644 index 0000000..6ae248e --- /dev/null +++ b/test/asset/definition/basic.et @@ -0,0 +1,22 @@ +def expr_def = 4 + +def fun_expr_def (x) = x + 5 + +def test_def (n): + shell as p on n: + echo $expr_def + + expect from p: + /4/ + +def fun_test_def (n) first x: + shell as p on n: + echo ${expr_def + x} + + expect from p: + /${4 + x}/ + +test Test: + node n + test_def (n) + fun_test_def (n) first 7 diff --git a/test/asset/expansion.et b/test/asset/expansion.et new file mode 100644 index 0000000..d14f9a1 --- /dev/null +++ b/test/asset/expansion.et @@ -0,0 +1,18 @@ +def integer_var = 1 +def number_var = 1.3 +def string_var = "abc" +def regex_var = /a.c/ + +test VariableExpansion: + node n + shell as p on n: + echo "$integer_var" + echo "$number_var" + echo "$string_var" + echo "$string_var" + + expect from p: + /$integer_var/ + /$number_var/ + /$string_var/ + /$regex_var/ diff --git a/test/asset/parser/indent.et b/test/asset/parser/indent.et new file mode 100644 index 0000000..01c4dd8 --- /dev/null +++ b/test/asset/parser/indent.et @@ -0,0 +1,41 @@ +def x1s: + wait + +def x2s: + wait + +def x4s: + wait + +def x8s: + wait + +def x16s: + wait + +def x1t: + wait + +def x2t: + wait + +export def e1s: + wait + +export def e2s: + wait + +export def e4s: + wait + +export def e8s: + wait + +export def e16s: + wait + +export def e1t: + wait + +export def e2t: + wait 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-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-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..954b9ad --- /dev/null +++ b/test/asset/run/callstack.et @@ -0,0 +1,3 @@ +test A: + let x = 1 + guard (x == 0) 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..64dcb07 --- /dev/null +++ b/test/asset/shell/pipe.et @@ -0,0 +1,5 @@ +test Pipe: + node n + shell on n as sh: + echo abcd | grep -o '[bc]*' + echo abcd | grep -o '[bcd]*' | grep -o '[ab]*' 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 new file mode 100644 index 0000000..d2da737 --- /dev/null +++ b/test/script/definition.et @@ -0,0 +1,18 @@ +module definition + +asset scripts: + path: ../asset/definition + +test Definition: + spawn as p + with p: + send "load ${scripts.path}/basic.et" + expect /load-done/ + + send "run Test" + expect /child-stdout p 4/ + expect /match p 4/ + expect /child-stdout p 11/ + expect /match p 11/ + expect /(.*)/ capture done + guard (done == "run-done") diff --git a/test/script/expansion.et b/test/script/expansion.et new file mode 100644 index 0000000..86a81dc --- /dev/null +++ b/test/script/expansion.et @@ -0,0 +1,15 @@ +module expansion + +asset expansion: + path: ../asset/expansion.et + +test VariableExpansion: + spawn as p + with p: + send "load ${expansion.path}" + expect /load-done/ + send "run VariableExpansion" + for str in [ "1", "1.3", "abc", "abc" ]: + expect /child-stdout p $str/ + expect /match p $str/ + expect /run-done/ diff --git a/test/script/parser.et b/test/script/parser.et new file mode 100644 index 0000000..554e345 --- /dev/null +++ b/test/script/parser.et @@ -0,0 +1,13 @@ +module parser + +asset scripts: + path: ../asset/parser + +test Parser: + spawn as p + with p: + send "load non-existing-file.et" + expect /load-failed file-not-found .*/ + + send "load ${scripts.path}/indent.et" + expect /load-done/ diff --git a/test/script/run.et b/test/script/run.et new file mode 100644 index 0000000..dc2b812 --- /dev/null +++ b/test/script/run.et @@ -0,0 +1,120 @@ +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-ignore" ] + let should_fail = [ "bool" ] + 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 + shell on n: + cp ${scripts.path}/erebos-tester.yaml . + mkdir tools + cp ${scripts.path}/tools/echo.sh ./tools/tool + mkdir scripts + # TODO: it seems that namespaces are not properly cleaned up after the failed test + #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 + 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 A" + expect /match-fail guard failed/ + expect /match-fail-line .*\/callstack.et:3:5: .*/ + expect /match-fail-var x 1/ + local: + expect /(run-.*)/ capture done + guard (done == "run-failed") diff --git a/test/script/shell.et b/test/script/shell.et new file mode 100644 index 0000000..2fe4ec3 --- /dev/null +++ b/test/script/shell.et @@ -0,0 +1,80 @@ +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 /run-all-done/ |