diff options
47 files changed, 2719 insertions, 864 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. @@ -248,10 +275,11 @@ In that case the expect command has to have the `capture` clause with matching n Results of the captures are then assigned to the newly created variables as strings. ``` -flush [from <proc>] +flush [from <proc>] [matching <regex>] ``` Flush memory of `<proc>` output, so no following `expect` command will match anything produced up to this point. +If the `matching` clause is used, discard only output lines matching `<regex>`. ``` guard <expr> @@ -309,12 +337,157 @@ with <expr>: Execute `<test block>` with `<expr>` as context. ``` +multiply_timeout by <multiplier> +``` + +Modify the timeout used for commands like `expect` by multiplying it with `<multiplier>`. +The effect lasts until the end of the block. + +``` wait ``` Wait for user input before continuing. Useful mostly for debugging or test development. +### Functions + +When calling a function, parameters are usually passed using argument keywords +(in the case of built-in commands, those keywords are typically prepositions +like `on`, `from`, etc.), and apart from those, there can be at most one +parameter passed without a keyword. This is done in order to avoid the need to +remember parameter order and to make the behavior of each call as clear as +possible, even without looking up the documentation. + +To make the syntax unambiguous, the keywordless parameter can be passed as +a literal (number, string, etc.), or using parentheses. So this is ok: + +``` +expect /something/ from p +``` + +but if the regular expression is stored in a variable, the parameter needs to +be enclosed in parentheses: +``` +expect (re) from p +``` +or in a literal: +``` +expect /$re/ from p +``` + +### Defining functions + +Custom functions can be defined on the top level using `def` keyword, and with +the parameters either followed by `=` sign to return a value: +``` +def quadruple of x = 4 * x +``` + +or followed by `:` to define test block: +``` +def say_hello to p: + send "hello" to p + expect /hi/ from p +``` + +Those then can be invoked elsewhere: +``` +test: + spawn as p + say_hello to p +``` + +When defining a function, the unnamed parameter, if any, must be enclosed in +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 c3a49e6..4fa1939 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,12 +28,14 @@ flag ci source-repository head type: git - location: git://erebosprotocol.net/tester + location: https://code.erebosprotocol.net/tester -common common +executable erebos-tester ghc-options: -Wall -fdefer-typed-holes + -threaded + -no-hs-main if flag(ci) ghc-options: @@ -41,80 +43,73 @@ common common -- sometimes needed for backward/forward compatibility: -Wno-error=unused-imports - build-depends: - base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 }, + main-is: + Main.hs -executable erebos-tester - import: common - ghc-options: - -- disable interval timer to avoid spawing thread that breaks unshare(CLONE_NEWUSER) - -with-rtsopts=-V0 - if impl(ghc >= 9.8) - ghc-options: - -- no multithreading is allowed for unshare(CLONE_NEWUSER) - -single-threaded + 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 + Script.Expr + Script.Expr.Class + Script.Module + Script.Object + Script.Shell + Script.Var + Test + Test.Builtins + TestMode + Util + Version + Version.Git - main-is: Wrapper.hs - -- other-modules: - -- other-extensions: - build-depends: - directory >=1.3 && <1.4, - filepath ^>= { 1.4.2.1, 1.5.2 }, - linux-namespaces^>=0.1.3, - process ^>=1.6.9, - unix >=2.7 && <2.9, - hs-source-dirs: src - default-language: Haskell2010 - -executable erebos-tester-core - import: common - ghc-options: - -threaded + autogen-modules: + Paths_erebos_tester - main-is: Main.hs + c-sources: + src/main.c - 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-extensions: + CPP + TemplateHaskell + default-extensions: + DefaultSignatures + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + TypeApplications + TypeFamilies + TypeOperators - autogen-modules: Paths_erebos_tester - - other-extensions: TemplateHaskell - default-extensions: ExistentialQuantification - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - OverloadedStrings - RankNTypes - RecordWildCards - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators - build-depends: + 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.3 }, directory ^>=1.3.6.0, filepath ^>= { 1.4.2.1, 1.5.2 }, Glob >=0.10 && <0.11, @@ -126,10 +121,11 @@ executable erebos-tester-core 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) @@ -75,7 +75,7 @@ gdbStart onCrash = do let process = Process { procName = ProcNameGDB - , procHandle = handle + , procHandle = Left handle , procStdin = hin , procOutput = pout , procKillWith = Nothing @@ -144,7 +144,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 61afbd8..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,30 +152,57 @@ 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 - - tests <- forM files $ \(path, mbTestName) -> do - Module { .. } <- parseTestFile path - return $ case mbTestName of - Nothing -> moduleTests - Just name -> filter ((==name) . testName) moduleTests - - ok <- allM (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 () +testerMain :: IO () +testerMain = main diff --git a/src/Network.hs b/src/Network.hs index aa06952..e12231d 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -5,6 +5,7 @@ module Network ( NodeName(..), textNodeName, unpackNodeName, nextNodeName, + rootNetworkVar, newInternet, delInternet, newSubnet, newNode, @@ -25,7 +26,8 @@ import System.FilePath import System.Process import Network.Ip -import Test +import Script.Expr +import Script.Expr.Class {- NETWORK STRUCTURE @@ -107,11 +109,15 @@ 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 ) ] +rootNetworkVar :: TypedVarName Network +rootNetworkVar = TypedVarName (VarName "$ROOT_NET") + nextPrefix :: IpPrefix -> [Word8] -> Word8 nextPrefix _ used = maximum (0 : used) + 1 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 135e6e0..7c4a8a5 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -1,14 +1,14 @@ module Output ( - Output, OutputType(..), + Output, OutputStyle(..), OutputType(..), MonadOutput(..), startOutput, + resetOutputTime, outLine, outPromptGetLine, outPromptGetLineCompletion, ) where import Control.Concurrent.MVar -import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader @@ -17,16 +17,21 @@ 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.IO + +import Text.Printf data Output = Output { outState :: MVar OutputState , outConfig :: OutputConfig + , outStartedAt :: MVar TimeSpec } data OutputConfig = OutputConfig - { outVerbose :: Bool + { outStyle :: OutputStyle , outUseColor :: Bool } @@ -35,15 +40,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 + | OutputError + | OutputAlways + | OutputTestRaw class MonadIO m => MonadOutput m where getOutput :: m Output @@ -51,10 +64,17 @@ class MonadIO m => MonadOutput m where instance MonadIO m => MonadOutput (ReaderT Output m) where getOutput = ask -startOutput :: Bool -> Bool -> IO Output -startOutput outVerbose outUseColor = Output - <$> newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory } - <*> pure OutputConfig { .. } +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 () +resetOutputTime Output {..} = do + modifyMVar_ outStartedAt . const $ getTime Monotonic outColor :: OutputType -> Text outColor OutputChildStdout = T.pack "0" @@ -66,6 +86,7 @@ outColor OutputMatch = T.pack "32" outColor OutputMatchFail = T.pack "31" outColor OutputError = T.pack "31" outColor OutputAlways = "0" +outColor OutputTestRaw = "0" outSign :: OutputType -> Text outSign OutputChildStdout = T.empty @@ -77,11 +98,25 @@ outSign OutputMatch = 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 @@ -96,10 +131,20 @@ 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 - [ if outUseColor (outConfig out) + [ [ 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 ] @@ -109,6 +154,16 @@ outLine otype prompt line = ioWithOutput $ \out -> else [] ] + testOutput out = do + withMVar (outState out) $ \st -> do + outPrint st $ case otype of + OutputTestRaw -> TL.fromStrict line + _ -> TL.fromChunks + [ outTestLabel otype, " " + , maybe "-" id prompt, " " + , line + ] + outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text) outPromptGetLine = outPromptGetLineCompletion noCompletion diff --git a/src/Parser.hs b/src/Parser.hs index 6d6809b..9f1a0e3 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,77 +1,224 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Parser ( - parseTestFile, + parseTestFiles, + CustomTestError(..), ) where import Control.Monad +import Control.Monad.Except import Control.Monad.State -import Control.Monad.Writer +import Data.IORef import Data.Map qualified as M import Data.Maybe +import Data.Proxy import Data.Set qualified as S import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.IO qualified as TL +import Data.Void import Text.Megaparsec hiding (State) 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 -parseTestDefinition :: TestParser () +parseTestDefinition :: TestParser Toplevel parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do - block (\name steps -> return $ Test name $ concat steps) header testStep - where header = do - wsymbol "test" - lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') + localState $ do + modify $ \s -> s + { testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar + } + block (\name steps -> return $ Test name $ Scope <$> mconcat steps) header testStep + where + header = do + wsymbol "test" + lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') + +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, ( LocalVarName vname, ExprTypeVar tvar )) : testVars s } + return ( off, vname, tvar ) + SomeExpr expr <- choice + [ do + osymbol ":" + scn + ref <- L.indentGuard scn GT href + SomeExpr <$> testBlock ref + , do + osymbol "=" + someExpr <* eol + ] + scn + atypes' <- getInferredTypes atypes + sexpr <- SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr + return ( name, sexpr ) + modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } + return def + where + getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do + let err msg = do + registerParseError . FancyError off . S.singleton . ErrorFail $ T.unpack msg + return ( vname, SomeArgumentType (OptionalArgument @DynamicType) ) + gets (M.lookup tvar . testTypeUnif) >>= \case + Just (ExprTypePrim (_ :: Proxy a)) -> return ( vname, SomeArgumentType (RequiredArgument @a) ) + Just (ExprTypeVar (TypeVar tvar')) -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvar' <> "’" + Just (ExprTypeFunction {}) -> err $ "unsupported function type of ‘" <> textVarName vname <> "’" + Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’" + + replaceDynArgs :: forall a. Expr a -> TestParser (Expr a) + replaceDynArgs expr = do + unif <- gets testTypeUnif + return $ mapExpr (go unif) expr + where + go :: forall b. M.Map TypeVar SomeExprType -> Expr b -> Expr b + go unif = \case + ArgsApp args body -> ArgsApp (fmap replaceArgs args) body + where + replaceArgs (SomeExpr (DynVariable tvar sline vname)) + | Just (ExprTypePrim (Proxy :: Proxy v)) <- M.lookup tvar unif + = SomeExpr (Variable sline vname :: Expr v) + replaceArgs (SomeExpr e) = SomeExpr (go unif e) + 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 ref <|> parseAsset ref + return [ ToplevelDefinition def, ToplevelExport name ] + , do + names <- listOf varName + eol >> scn + return $ map ToplevelExport names + ] + +parseImport :: TestParser [ Toplevel ] +parseImport = label "import declaration" $ toplevel (\() -> []) $ do + wsymbol "import" + 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" off <- stateOffset <$> getParserState - x <- identifier - name <- (x:) <$> many (symbol "." >> identifier) - when (or (zipWith (/=) (reverse name) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do + name@(ModuleName tname) <- parseModuleName + when (or (zipWith (/=) (reverse tname) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "module name does not match file path" eol >> scn return name , do - return $ [ T.pack $ takeBaseName absPath ] + return $ ModuleName [ T.pack $ takeBaseName absPath ] ] - (_, toplevels) <- listen $ many $ choice - [ parseTestDefinition + modify $ \s -> s { testCurrentModuleName = moduleName } + toplevels <- fmap concat $ many $ choice + [ (: []) <$> parseTestDefinition + , (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1) + , (: []) <$> toplevel ToplevelDefinition (parseAsset pos1) + , parseExport + , parseImport ] - let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; {- _ -> Nothing -}) toplevels + let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; _ -> Nothing) toplevels + moduleDefinitions = catMaybes $ map (\case ToplevelDefinition x -> Just x; _ -> Nothing) toplevels + moduleExports = catMaybes $ map (\case ToplevelExport x -> Just x; _ -> Nothing) toplevels eof - return Module { .. } + return Module {..} -parseTestFile :: FilePath -> IO Module -parseTestFile path = do - content <- TL.readFile path - absPath <- makeAbsolute path - let initState = TestParserState - { testVars = concat - [ map (fmap someVarValueType) builtins - ] - , testContext = SomeExpr RootNetwork - , testNextTypeVar = 0 - , testTypeUnif = M.empty - } - (res, _) = runWriter $ flip (flip runParserT path) content $ flip evalStateT initState $ parseTestModule absPath +parseTestFiles :: [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] )) +parseTestFiles paths = do + parsedModules <- newIORef [] + runExceptT $ do + requestedModules <- reverse <$> foldM (go parsedModules) [] paths + allModules <- map snd <$> liftIO (readIORef parsedModules) + return ( requestedModules, allModules ) + where + go parsedModules res path = do + liftIO (parseTestFile parsedModules Nothing path) >>= \case + Left err -> do + throwError err + Right cur -> do + return $ cur : res - case res of - Left err -> putStr (errorBundlePretty err) >> exitFailure - Right testModule -> return testModule +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 + { 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 = 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 (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 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 $ maybe (FileNotFound path) ModuleNotFound mbModuleName diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index cb66529..132dbc8 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -1,8 +1,8 @@ module Parser.Core where +import Control.Applicative import Control.Monad import Control.Monad.State -import Control.Monad.Writer import Data.Map (Map) import Data.Map qualified as M @@ -11,29 +11,72 @@ import Data.Set qualified as S import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Typeable -import Data.Void import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Network () +import Script.Expr +import Script.Module import Test -type TestParser = StateT TestParserState (ParsecT Void TestStream (Writer [ Toplevel ])) +newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a) + deriving + ( Functor, Applicative, Alternative, Monad + , MonadState TestParserState + , MonadPlus + , MonadFail + , MonadIO + , MonadParsec CustomTestError TestStream + ) type TestStream = TL.Text -type TestParseError = ParseError TestStream Void +type TestParseError = ParseError TestStream CustomTestError + +data CustomTestError + = ModuleNotFound ModuleName + | FileNotFound FilePath + | ImportModuleError (ParseErrorBundle TestStream CustomTestError) + deriving (Eq) + +instance Ord CustomTestError where + compare (ModuleNotFound a) (ModuleNotFound b) = compare a b + 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 (FileNotFound path) = "file ‘" <> path <> "’ not found" + showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle + +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 + | ToplevelDefinition ( VarName, SomeExpr ) + | ToplevelExport VarName + | ToplevelImport ( ModuleName, VarName ) data TestParserState = TestParserState - { testVars :: [ ( VarName, SomeExprType ) ] + { testSourcePath :: FilePath + , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ] , testContext :: SomeExpr , testNextTypeVar :: Int , testTypeUnif :: Map TypeVar SomeExprType + , testCurrentModuleName :: ModuleName + , testParseModule :: ModuleName -> ModuleName -> IO (Either CustomTestError Module) } newTypeVar :: TestParser TypeVar @@ -42,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 @@ -188,11 +242,12 @@ localState :: TestParser a -> TestParser a localState inner = do s <- get x <- inner - put s + s' <- get + put s { testNextTypeVar = testNextTypeVar s', testTypeUnif = testTypeUnif s' } return x -toplevel :: (a -> Toplevel) -> TestParser a -> TestParser () -toplevel f = tell . (: []) . f <=< L.nonIndented scn +toplevel :: (a -> b) -> TestParser a -> TestParser b +toplevel f = return . f <=< L.nonIndented scn block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c block merge header item = L.indentBlock scn $ do @@ -208,6 +263,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 @@ -217,3 +284,12 @@ getSourceLine = do , T.pack ": " , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate ] + + +getOrParseModule :: ModuleName -> TestParser Module +getOrParseModule name = do + current <- gets testCurrentModuleName + parseModule <- gets testParseModule + (TestParser $ lift $ lift $ parseModule current name) >>= \case + Right parsed -> return parsed + Left err -> customFailure err diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index 4ed0215..b9b5f01 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -1,5 +1,6 @@ module Parser.Expr ( identifier, + parseModuleName, varName, newVarName, @@ -10,6 +11,8 @@ module Parser.Expr ( literal, variable, + stringExpansion, + checkFunctionArguments, functionArguments, ) where @@ -33,18 +36,34 @@ import Data.Void import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L -import Text.Regex.TDFA qualified as RE -import Text.Regex.TDFA.Text qualified as RE +import Text.Megaparsec.Error.Builder qualified as Err import Parser.Core -import Test +import Script.Expr +import Script.Expr.Class + +reservedWords :: [ Text ] +reservedWords = + [ "test", "def", "let" + , "module", "export", "import" + ] identifier :: TestParser Text identifier = label "identifier" $ do - lexeme $ do + lexeme $ try $ do + off <- stateOffset <$> getParserState lead <- lowerChar rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_') - return $ TL.toStrict $ TL.fromChunks $ (T.singleton lead :) $ TL.toChunks rest + let ident = TL.toStrict $ TL.fromChunks $ (T.singleton lead :) $ TL.toChunks rest + when (ident `elem` reservedWords) $ parseError $ Err.err off $ mconcat + [ Err.utoks $ TL.fromStrict ident + ] + return ident + +parseModuleName :: TestParser ModuleName +parseModuleName = do + x <- identifier + ModuleName . (x :) <$> many (symbol "." >> identifier) varName :: TestParser VarName varName = label "variable name" $ VarName <$> identifier @@ -62,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 @@ -71,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 @@ -84,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 @@ -96,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 '"' @@ -112,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 @@ -134,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 () @@ -221,7 +241,7 @@ someExpr = join inner <?> "expression" term = label "term" $ choice [ parens inner , return <$> literal - , return <$> variable + , return <$> functionCall ] table = [ [ prefix "-" $ [ SomeUnOp (negate @Integer) @@ -248,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) @@ -334,6 +356,7 @@ typedExpr = do literal :: TestParser SomeExpr literal = label "literal" $ choice [ numberLiteral + , boolLiteral , SomeExpr <$> quotedString , SomeExpr <$> regex , list @@ -344,43 +367,46 @@ variable = label "variable" $ do off <- stateOffset <$> getParserState sline <- getSourceLine name <- varName - lookupVarExpr off sline name >>= \case + e <- lookupVarExpr off sline name + recordSelector e <|> return e + +functionCall :: TestParser SomeExpr +functionCall = do + sline <- getSourceLine + variable >>= \case SomeExpr e'@(FunVariable argTypes _ _) -> do let check = checkFunctionArguments argTypes args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff sline . VarName) return $ SomeExpr $ ArgsApp args e' - e -> do - recordSelector e <|> return e + e -> return e +recordSelector :: SomeExpr -> TestParser SomeExpr +recordSelector (SomeExpr expr) = do + void $ osymbol "." + off <- stateOffset <$> getParserState + m <- identifier + let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat + [ T.pack "value of type ", textExprType expr, T.pack " does not have member '", m, T.pack "'" ] + e' <- maybe err return $ applyRecordSelector m expr <$> lookup m recordMembers + recordSelector e' <|> return e' where - recordSelector :: SomeExpr -> TestParser SomeExpr - recordSelector (SomeExpr e) = do - void $ osymbol "." - off <- stateOffset <$> getParserState - m <- identifier - let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat - [ T.pack "value of type ", textExprType e, T.pack " does not have member '", m, T.pack "'" ] - e' <- maybe err return $ applyRecordSelector m e <$> lookup m recordMembers - recordSelector e' <|> return e' - applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e 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) @@ -399,22 +425,10 @@ functionArguments check param lit promote = do [ T.pack "multiple unnamed parameters" ] parseArgs False - ,do off <- stateOffset <$> getParserState - x <- identifier - choice - [do off' <- stateOffset <$> getParserState - y <- pparam <|> (promote off' =<< identifier) - checkAndInsert off' (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed - - ,if allowUnnamed - then do - y <- promote off x - checkAndInsert off Nothing y $ return M.empty - else do - registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat - [ T.pack "multiple unnamed parameters" ] - return M.empty - ] + ,do x <- identifier + off <- stateOffset <$> getParserState + y <- pparam <|> (promote off =<< identifier) + checkAndInsert off (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed ,do return M.empty ] diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs new file mode 100644 index 0000000..89595e8 --- /dev/null +++ b/src/Parser/Shell.hs @@ -0,0 +1,81 @@ +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 + , escapedChar + , stringExpansion + , unquotedString + ] + where + specialChars = [ '\"', '\\', '$' ] + + unquotedString :: TestParser (Expr Text) + unquotedString = do + Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars) + + doubleQuotedString :: TestParser (Expr Text) + doubleQuotedString = do + void $ char '"' + let inner = choice + [ char '"' >> return [] + , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner + , (:) <$> escapedChar <*> inner + , (:) <$> stringExpansion <*> inner + ] + App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner + + singleQuotedString :: TestParser (Expr Text) + singleQuotedString = do + Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'') + + escapedChar :: TestParser (Expr Text) + escapedChar = do + void $ char '\\' + Pure <$> choice + [ char '\\' >> return "\\" + , char '"' >> return "\"" + , char '$' >> return "$" + , char 'n' >> return "\n" + , char 'r' >> return "\r" + , char 't' >> return "\t" + ] + +parseArguments :: TestParser (Expr [ Text ]) +parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument + +shellStatement :: TestParser (Expr [ ShellStatement ]) +shellStatement = label "shell statement" $ do + line <- getSourceLine + command <- parseArgument + args <- parseArguments + return $ fmap (: []) $ ShellStatement + <$> command + <*> args + <*> pure line + +shellScript :: TestParser (Expr ShellScript) +shellScript = do + indent <- L.indentLevel + fmap ShellScript <$> blockOf indent shellStatement diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index c7cdf5a..474fa03 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -1,16 +1,19 @@ module Parser.Statement ( testStep, + testBlock, ) where import Control.Monad import Control.Monad.Identity import Control.Monad.State +import Data.Bifunctor import Data.Kind import Data.Maybe import Data.Set qualified as S import Data.Text qualified as T import Data.Typeable +import Data.Void import Text.Megaparsec hiding (State) import Text.Megaparsec.Char @@ -19,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 [TestStep] +letStatement :: TestParser (Expr (TestBlock ())) letStatement = do line <- getSourceLine indent <- L.indentLevel @@ -38,11 +44,10 @@ 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 [TestStep] +forStatement :: TestParser (Expr (TestBlock ())) forStatement = do - line <- getSourceLine ref <- L.indentLevel wsymbol "for" voff <- stateOffset <$> getParserState @@ -62,26 +67,70 @@ forStatement = do let tname = TypedVarName name addVarName voff tname body <- testBlock indent - return [For line tname (unpack <$> e) body] + return $ (\xs f -> mconcat $ map f xs) + <$> (unpack <$> e) + <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body) + +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 [ TestStep ] +exprStatement :: TestParser (Expr (TestBlock ())) exprStatement = do ref <- L.indentLevel off <- stateOffset <$> getParserState SomeExpr expr <- someExpr choice - [ do - continuePartial off ref expr - , do - stmt <- unifyExpr off Proxy expr - return [ ExprStatement stmt ] + [ continuePartial off ref expr + , unifyExpr off Proxy expr ] where - continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser [ TestStep ] + 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 @@ -91,7 +140,7 @@ exprStatement = do let fun' = ArgsApp args fun choice [ continuePartial coff indent fun' - , (: []) . ExprStatement <$> unifyExpr coff Proxy fun' + , unifyExpr coff Proxy fun' ] class (Typeable a, Typeable (ParamRep a)) => ParamType a where @@ -104,9 +153,18 @@ class (Typeable a, Typeable (ParamRep a)) => ParamType a where paramDefault :: proxy a -> TestParser (ParamRep a) paramDefault _ = mzero + paramNewVariables :: proxy a -> ParamRep a -> NewVariables + paramNewVariables _ _ = NoNewVariables + paramNewVariablesEmpty :: proxy a -> NewVariables + paramNewVariablesEmpty _ = NoNewVariables -- to keep type info for optional parameters + paramFromSomeExpr :: proxy a -> SomeExpr -> Maybe (ParamRep a) paramFromSomeExpr _ (SomeExpr e) = cast e + paramExpr :: ParamRep a -> Expr a + default paramExpr :: ParamRep a ~ a => ParamRep a -> Expr a + paramExpr = Pure + instance ParamType SourceLine where parseParam _ = mzero showParamType _ = "<source line>" @@ -114,11 +172,13 @@ instance ParamType SourceLine where instance ExprType a => ParamType (TypedVarName a) where parseParam _ = newVarName showParamType _ = "<variable>" + paramNewVariables _ var = SomeNewVariables [ var ] + paramNewVariablesEmpty _ = SomeNewVariables @a [] instance ExprType a => ParamType (Expr a) where parseParam _ = do off <- stateOffset <$> getParserState - SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr + SomeExpr e <- literal <|> between (symbol "(") (symbol ")") someExpr unifyExpr off Proxy e showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" @@ -127,14 +187,20 @@ instance ParamType a => ParamType [a] where parseParam _ = listOf (parseParam @a Proxy) showParamType _ = showParamType @a Proxy ++ " [, " ++ showParamType @a Proxy ++ " ...]" paramDefault _ = return [] + paramNewVariables _ = foldr (<>) (paramNewVariablesEmpty @a Proxy) . fmap (paramNewVariables @a Proxy) + paramNewVariablesEmpty _ = paramNewVariablesEmpty @a Proxy paramFromSomeExpr _ se@(SomeExpr e) = cast e <|> ((:[]) <$> paramFromSomeExpr @a Proxy se) + paramExpr = sequenceA . fmap paramExpr instance ParamType a => ParamType (Maybe a) where type ParamRep (Maybe a) = Maybe (ParamRep a) parseParam _ = Just <$> parseParam @a Proxy showParamType _ = showParamType @a Proxy paramDefault _ = return Nothing + paramNewVariables _ = foldr (<>) (paramNewVariablesEmpty @a Proxy) . fmap (paramNewVariables @a Proxy) + paramNewVariablesEmpty _ = paramNewVariablesEmpty @a Proxy paramFromSomeExpr _ se = Just <$> paramFromSomeExpr @a Proxy se + paramExpr = sequenceA . fmap paramExpr instance (ParamType a, ParamType b) => ParamType (Either a b) where type ParamRep (Either a b) = Either (ParamRep a) (ParamRep b) @@ -147,62 +213,106 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where (_ : _) -> fail "" showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy paramFromSomeExpr _ se = (Left <$> paramFromSomeExpr @a Proxy se) <|> (Right <$> paramFromSomeExpr @b Proxy se) + paramExpr = either (fmap Left . paramExpr) (fmap Right . paramExpr) + +instance ExprType a => ParamType (Traced a) where + type ParamRep (Traced a) = Expr a + parseParam _ = parseParam (Proxy @(Expr a)) + showParamType _ = showParamType (Proxy @(Expr a)) + paramExpr = Trace data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a)) -data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> a) +data NewVariables + = NoNewVariables + | forall a. ExprType a => SomeNewVariables [ TypedVarName a ] + +instance Semigroup NewVariables where + NoNewVariables <> x = x + x <> NoNewVariables = x + SomeNewVariables (xs :: [ TypedVarName a ]) <> SomeNewVariables (ys :: [ TypedVarName b ]) + | Just (Refl :: a :~: b) <- eqT = SomeNewVariables (xs <> ys) + | otherwise = error "new variables with different types" + +instance Monoid NewVariables where + mempty = NoNewVariables + +someParamVars :: Foldable f => SomeParam f -> NewVariables +someParamVars (SomeParam proxy rep) = foldr (\x nvs -> paramNewVariables proxy x <> nvs) (paramNewVariablesEmpty proxy) rep + +data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> Expr a) instance Functor CommandDef where - fmap f (CommandDef types ctor) = CommandDef types (f . ctor) + fmap f (CommandDef types ctor) = CommandDef types (fmap f . ctor) instance Applicative CommandDef where - pure x = CommandDef [] (\case [] -> x; _ -> error "command arguments mismatch") - CommandDef types1 ctor1 <*> CommandDef types2 ctor2 = - CommandDef (types1 ++ types2) $ \params -> - let (params1, params2) = splitAt (length types1) params - in ctor1 params1 $ ctor2 params2 + pure x = CommandDef [] (\case [] -> Pure x; _ -> error "command arguments mismatch") + CommandDef types1 ctor1 <*> CommandDef types2 ctor2 = + CommandDef (types1 ++ types2) $ \params -> + let (params1, params2) = splitAt (length types1) params + in ctor1 params1 <*> ctor2 params2 param :: forall a. ParamType a => String -> CommandDef a param name = CommandDef [(name, SomeParam (Proxy @a) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x + [SomeParam Proxy (Identity x)] -> paramExpr $ fromJust $ cast x _ -> error "command arguments mismatch" -data ParamOrContext a +newtype ParamOrContext a = ParamOrContext { fromParamOrContext :: a } + deriving (Functor, Foldable, Traversable) instance ParamType a => ParamType (ParamOrContext a) where - type ParamRep (ParamOrContext a) = ParamRep a - parseParam _ = parseParam @a Proxy + type ParamRep (ParamOrContext a) = ParamOrContext (ParamRep a) + parseParam _ = ParamOrContext <$> parseParam @a Proxy showParamType _ = showParamType @a Proxy paramDefault _ = gets testContext >>= \case se@(SomeExpr ctx) - | Just e <- paramFromSomeExpr @a Proxy se -> return e + | Just e <- paramFromSomeExpr @a Proxy se -> return (ParamOrContext e) | otherwise -> fail $ showParamType @a Proxy <> " not available from context type '" <> T.unpack (textExprType ctx) <> "'" + paramExpr = sequenceA . fmap paramExpr paramOrContext :: forall a. ParamType a => String -> CommandDef a -paramOrContext name = CommandDef [(name, SomeParam (Proxy @(ParamOrContext a)) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x - _ -> error "command arguments mismatch" +paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" -data InnerBlock +newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } -instance ParamType InnerBlock where - type ParamRep InnerBlock = [TestStep] +instance ExprType a => ParamType (InnerBlock a) where + type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr (TestBlock ()) ) parseParam _ = mzero showParamType _ = "<code block>" + paramExpr ( vars, expr ) = fmap InnerBlock $ helper vars $ const <$> expr + where + helper :: ExprType a => [ TypedVarName a ] -> Expr ([ a ] -> b) -> Expr ([ a ] -> b) + helper ( v : vs ) = fmap combine . LambdaAbstraction v . helper vs + helper [] = id -instance ParamType TestStep where - parseParam _ = mzero - showParamType _ = "<code line>" + combine f (x : xs) = f x xs + combine _ [] = error "inner block parameter count mismatch" -innerBlock :: CommandDef [TestStep] -innerBlock = CommandDef [("", SomeParam (Proxy @InnerBlock) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x - _ -> error "command arguments mismatch" +innerBlock :: CommandDef (TestStep ()) +innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun + +innerBlockFun :: ExprType a => CommandDef (a -> TestStep ()) +innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList + +innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ()) +innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param "" + +newtype ExprParam a = ExprParam { fromExprParam :: a } + deriving (Functor, Foldable, Traversable) + +instance ExprType a => ParamType (ExprParam a) where + type ParamRep (ExprParam a) = Expr a + parseParam _ = do + off <- stateOffset <$> getParserState + SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr + unifyExpr off Proxy e + showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" + paramExpr = fmap ExprParam -command :: String -> CommandDef TestStep -> TestParser [TestStep] +command :: String -> CommandDef (TestStep ()) -> TestParser (Expr (TestBlock ())) command name (CommandDef types ctor) = do indent <- L.indentLevel line <- getSourceLine @@ -210,19 +320,24 @@ 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 [TestStep] + 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 iparams <- forM params $ \case (_, SomeParam (p :: Proxy p) Nothing) | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line - | Just (Refl :: p :~: InnerBlock) <- eqT -> SomeParam p . Identity <$> restOfParts cmdi partials + + | SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables + , Just (Refl :: p :~: InnerBlock a) <- eqT + -> SomeParam p . Identity . ( vars, ) <$> restOfParts cmdi partials + (sym, SomeParam p Nothing) -> choice [ SomeParam p . Identity <$> paramDefault p , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p ] (_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x - return [ctor iparams] + return $ (TestBlockStep EmptyTestBlock) <$> ctor iparams ,do symbol ":" scn @@ -232,16 +347,16 @@ command name (CommandDef types ctor) = do ,do tryParams cmdi partials line [] params ] - restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser [TestStep] + restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr (TestBlock ())) restOfParts cmdi [] = testBlock cmdi restOfParts cmdi partials@((partIndent, params) : rest) = do scn pos <- L.indentLevel line <- getSourceLine optional eof >>= \case - Just _ -> return [] + Just _ -> return $ Pure mempty _ | pos < partIndent -> restOfParts cmdi rest - | pos == partIndent -> (++) <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials + | pos == partIndent -> mappend <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials | otherwise -> L.incorrectIndent EQ partIndent pos tryParam sym (SomeParam (p :: Proxy p) cur) = do @@ -258,7 +373,7 @@ command name (CommandDef types ctor) = do ] tryParams _ _ _ _ [] = mzero -testLocal :: TestParser [TestStep] +testLocal :: TestParser (Expr (TestBlock ())) testLocal = do ref <- L.indentLevel wsymbol "local" @@ -266,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 [TestStep] +testWith :: TestParser (Expr (TestBlock ())) testWith = do ref <- L.indentLevel wsymbol "with" @@ -292,75 +408,65 @@ 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 [TestStep] +testSubnet :: TestParser (Expr (TestBlock ())) testSubnet = command "subnet" $ Subnet <$> param "" - <*> paramOrContext "of" - <*> innerBlock + <*> (fromExprParam <$> paramOrContext "of") + <*> innerBlockFun -testNode :: TestParser [TestStep] +testNode :: TestParser (Expr (TestBlock ())) testNode = command "node" $ DeclNode <$> param "" - <*> paramOrContext "on" - <*> innerBlock + <*> (fromExprParam <$> paramOrContext "on") + <*> innerBlockFun -testSpawn :: TestParser [TestStep] +testSpawn :: TestParser (Expr (TestBlock ())) testSpawn = command "spawn" $ Spawn <$> param "as" - <*> paramOrContext "on" - <*> innerBlock + <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") + <*> (maybe [] fromExprParam <$> param "args") + <*> innerBlockFun -testExpect :: TestParser [TestStep] +testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect <$> cmdLine - <*> paramOrContext "from" + <*> (fromExprParam <$> paramOrContext "from") <*> param "" <*> param "capture" - <*> innerBlock + <*> innerBlockFunList -testDisconnectNode :: TestParser [TestStep] +testDisconnectNode :: TestParser (Expr (TestBlock ())) testDisconnectNode = command "disconnect_node" $ DisconnectNode - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectNodes :: TestParser [TestStep] +testDisconnectNodes :: TestParser (Expr (TestBlock ())) testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectUpstream :: TestParser [TestStep] +testDisconnectUpstream :: TestParser (Expr (TestBlock ())) testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testPacketLoss :: TestParser [TestStep] +testPacketLoss :: TestParser (Expr (TestBlock ())) testPacketLoss = command "packet_loss" $ PacketLoss - <$> param "" - <*> paramOrContext "on" + <$> (fromExprParam <$> paramOrContext "") + <*> (fromExprParam <$> paramOrContext "on") <*> innerBlock -testBlock :: Pos -> TestParser [ TestStep ] +testBlock :: Pos -> TestParser (Expr (TestBlock ())) testBlock indent = blockOf indent testStep -blockOf :: Pos -> TestParser [ a ] -> TestParser [ a ] -blockOf indent step = concat <$> go - where - go = do - scn - pos <- L.indentLevel - optional eof >>= \case - Just _ -> return [] - _ | pos < indent -> return [] - | pos == indent -> (:) <$> step <*> go - | otherwise -> L.incorrectIndent EQ indent pos - -testStep :: TestParser [TestStep] +testStep :: TestParser (Expr (TestBlock ())) testStep = choice [ letStatement , forStatement + , shellStatement , testLocal , testWith , testSubnet diff --git a/src/Process.hs b/src/Process.hs index 48ed40f..31641c9 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -7,6 +7,7 @@ module Process ( lineReadingLoop, spawnOn, closeProcess, + closeTestProcess, withProcess, ) where @@ -18,11 +19,15 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Function +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,11 +38,11 @@ import Network import Network.Ip import Output import Run.Monad -import Test +import Script.Expr.Class data Process = Process { procName :: ProcName - , procHandle :: ProcessHandle + , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode ) , procStdin :: Handle , procOutput :: TVar [Text] , procKillWith :: Maybe Signal @@ -89,27 +94,40 @@ lineReadingLoop process h act = spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process spawnOn target pname killWith 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 - , env = Just [("EREBOS_DIR", either netDir nodeDir target)] - } + currentEnv <- liftIO $ getEnvironment + (Just hin, 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 + } pout <- liftIO $ newTVarIO [] let process = Process { procName = pname - , procHandle = handle + , procHandle = Left handle , procStdin = hin , procOutput = pout , procKillWith = killWith , procNode = either (const undefined) id target } - forkTest $ lineReadingLoop process hout $ \line -> do + void $ forkTest $ lineReadingLoop process hout $ \line -> do outProc OutputChildStdout process line liftIO $ atomically $ modifyTVar pout (++[line]) - forkTest $ lineReadingLoop process herr $ \line -> do + void $ forkTest $ lineReadingLoop process herr $ \line -> do case pname of ProcNameTcpdump -> return () _ -> outProc OutputChildStderr process line @@ -120,24 +138,29 @@ spawnOn target pname killWith cmd = do 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 @@ -147,5 +170,5 @@ 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 @@ -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,25 @@ import System.Posix.Process import System.Posix.Signals import System.Process +import Text.Megaparsec (errorBundlePretty, showErrorComponent) + import GDB import Network import Network.Ip import Output +import Parser import Process import Run.Monad +import Script.Expr +import Script.Module +import Script.Object +import Script.Shell import Test import Test.Builtins -runTest :: Output -> TestOptions -> Test -> IO Bool -runTest out opts test = 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 +57,9 @@ runTest out opts test = 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,12 +71,14 @@ runTest out opts test = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teNextObjId = objIdVar , teProcesses = procVar + , teTimeout = timeoutVar , teGDB = fst <$> mgdb } tstate = TestState - { tsNetwork = error "network not initialized" - , tsVars = builtins + { tsGlobals = gdefs + , tsLocals = [] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty @@ -69,7 +87,7 @@ runTest out opts test = 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 @@ -83,16 +101,17 @@ runTest out opts test = do Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing - res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do + resetOutputTime out + ( res, [] ) <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do withInternet $ \_ -> do - evalSteps (testSteps test) + runStep =<< eval (testSteps test) when (optWait opts) $ do void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." 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) @@ -100,101 +119,112 @@ runTest out opts test = do (Right (), Nothing) -> do when (not $ optKeep opts) $ removeDirectoryRecursive testDir return True - _ -> return False - -evalSteps :: [TestStep] -> TestRun () -evalSteps = mapM_ $ \case - Let (SourceLine sline) (TypedVarName name) expr inner -> do - cur <- asks (lookup name . tsVars . snd) - when (isJust cur) $ do - outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline - throwError Failed - value <- eval expr - withVar name value $ evalSteps inner - - For (SourceLine sline) (TypedVarName name) expr inner -> do - cur <- asks (lookup name . tsVars . snd) - when (isJust cur) $ do - outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline - throwError Failed - value <- eval expr - forM_ value $ \i -> do - withVar name i $ evalSteps inner - - ExprStatement expr -> do - TestBlock steps <- eval expr - evalSteps steps - - Subnet name@(TypedVarName vname) parentExpr inner -> do - parent <- eval parentExpr - withSubnet parent (Just name) $ \net -> do - withVar vname net $ evalSteps inner - - DeclNode name@(TypedVarName vname) net inner -> do - withNode net (Left name) $ \node -> do - withVar vname node $ evalSteps inner - - Spawn tvname@(TypedVarName vname@(VarName tname)) target inner -> do + _ -> 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 ] + + Subnet name parent inner -> do + withSubnet parent (Just name) $ runStep . inner + + DeclNode name net inner -> do + withNode net (Left name) $ runStep . inner + + Spawn tvname@(TypedVarName (VarName tname)) target args inner -> do case target of Left net -> withNode net (Right tvname) go - Right node -> go =<< eval node + Right node -> go node where go node = do opts <- asks $ teOptions . fst let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) - withProcess (Right node) pname Nothing tool $ \p -> do - withVar vname p (evalSteps inner) + cmd = unwords $ tool : map (T.unpack . escape) args + escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" + withProcess (Right node) pname Nothing cmd $ runStep . inner - Send pname expr -> do - p <- eval pname - line <- eval expr + 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 pname expr captures inner -> do - p <- eval pname - expect line p expr captures $ evalSteps inner + Expect line p expr captures inner -> do + expect line p expr captures $ runStep . inner - Flush pname expr -> do - p <- eval pname - flush p expr + Flush p regex -> do + flush p regex - Guard line expr -> do - testStepGuard line expr + Guard line vars expr -> do + testStepGuard line vars expr DisconnectNode node inner -> do - n <- eval node - withDisconnectedUp (nodeUpstream n) $ evalSteps inner + withDisconnectedUp (nodeUpstream node) $ runStep inner DisconnectNodes net inner -> do - n <- eval net - withDisconnectedBridge (netBridge n) $ evalSteps inner + withDisconnectedBridge (netBridge net) $ runStep inner DisconnectUpstream net inner -> do - n <- eval net - case netUpstream n of - Just link -> withDisconnectedUp link $ evalSteps inner - Nothing -> evalSteps inner + case netUpstream net of + Just link -> withDisconnectedUp link $ runStep inner + Nothing -> runStep inner PacketLoss loss node inner -> do - l <- eval loss - n <- eval node - withNodePacketLoss n l $ evalSteps inner + withNodePacketLoss node loss $ runStep inner Wait -> do void $ outPromptGetLine "Waiting..." -withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a -withVar name value = local (fmap $ \s -> s { tsVars = ( name, SomeVarValue mempty $ const $ const value ) : tsVars s }) - withInternet :: (Network -> TestRun a) -> TestRun a withInternet inner = do testDir <- asks $ optTestDir . teOptions . fst inet <- newInternet testDir res <- withNetwork (inetRoot inet) $ \net -> do - local (fmap $ \s -> s { tsNetwork = net }) $ inner net + withTypedVar rootNetworkVar net $ do + inner net delInternet inet return res @@ -207,14 +237,13 @@ withNetwork :: Network -> (Network -> TestRun a) -> TestRun a withNetwork net inner = do tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination) - (path ++ " -i br0 -w '" ++ netDir net ++ "/br0.pcap' -U -Z root") . const + (path ++ " -i br0 -w './br0.pcap' -U -Z root") . const Nothing -> id tcpdump $ inner net -withNode :: Expr Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a -withNode netexpr tvname inner = do - net <- eval netexpr +withNode :: Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a +withNode net tvname inner = do node <- newNode net (either fromTypedVarName fromTypedVarName tvname) either (flip withVar node . fromTypedVarName) (const id) tvname $ inner node @@ -273,22 +302,20 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just ( | otherwise = fmap (x:) <$> tryMatch re xs tryMatch _ [] = Nothing -exprFailed :: Text -> SourceLine -> Maybe ProcName -> Expr a -> TestRun () -exprFailed desc (SourceLine sline) pname expr = do +exprFailed :: Text -> SourceLine -> Maybe ProcName -> EvalTrace -> TestRun () +exprFailed desc sline pname exprVars = do let prompt = maybe T.empty textProcName pname - exprVars <- gatherVars expr - outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline] + 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 (SourceLine sline) value + [ " ", textFqVarName name, T.concat (map ("."<>) sel) + , " = ", textSomeVarValue sline value ] throwError Failed -expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun () -expect (SourceLine sline) p expr tvars inner = do - re <- eval expr - timeout <- asks $ optTimeout . teOptions . fst +expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun () +expect sline p (Traced trace re) tvars inner = do + timeout <- liftIO . readMVar =<< asks (teTimeout . fst) delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do line <- readTVar (procOutput p) @@ -302,29 +329,21 @@ expect (SourceLine sline) p expr 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` sline + outProc OutputMatchFail 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` sline - throwError Failed - outProc OutputMatch p line - local (fmap $ \s -> s { tsVars = zip vars (map (SomeVarValue mempty . const . const) capture) ++ tsVars s }) inner + inner capture - Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr + Nothing -> exprFailed (T.pack "expect") sline (Just $ procName p) trace -flush :: Process -> Maybe (Expr Regex) -> TestRun () -flush p mbexpr = do - mbre <- sequence $ fmap eval mbexpr +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) -testStepGuard :: SourceLine -> Expr Bool -> TestRun () -testStepGuard sline expr = do - x <- eval expr - when (not x) $ exprFailed (T.pack "guard") sline Nothing expr +testStepGuard :: SourceLine -> EvalTrace -> Bool -> TestRun () +testStepGuard sline vars x = do + when (not x) $ exprFailed (T.pack "guard") sline Nothing vars diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 9ec9065..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,33 +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 {-# SOURCE #-} Network 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 - { tsNetwork :: Network - , tsVars :: [(VarName, SomeVarValue)] + { tsGlobals :: GlobalDefs + , tsLocals :: [ ( VarName, SomeVarValue ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific @@ -93,8 +102,9 @@ instance MonadError Failed TestRun where catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler instance MonadEval TestRun where - lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd) - rootNetwork = asks $ tsNetwork . snd + 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 @@ -109,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/Script/Expr.hs b/src/Script/Expr.hs new file mode 100644 index 0000000..ced807c --- /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, 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 => 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 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) + + + +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 + +isInternalVar :: FqVarName -> Bool +isInternalVar (GlobalVarName {}) = False +isInternalVar (LocalVarName (VarName name)) + | Just ( '$', _ ) <- T.uncons name = True + | otherwise = False + + +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 sline name -> fromSomeVarValue sline name =<< lookupVar name + DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’" + FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name + ArgsReq (FunctionArguments req) efun -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ FunctionType $ \(FunctionArguments args) -> + let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req + FunctionType fun = runSimpleEval (eval efun) gdefs (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 + 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 (const 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 (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 :: SourceLine -> 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) => SourceLine -> FqVarName -> 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 '", textFqVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] + +fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m a +fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do + 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 '", textFqVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] + +textSomeVarValue :: SourceLine -> SomeVarValue -> Text +textSomeVarValue sline (SomeVarValue (VarValue _ args value)) + | anull args = textExprValue $ value sline mempty + | 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) => SourceLine -> FqVarName -> SomeVarValue -> m (FunctionType a) +funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do + maybe (fail err) return $ do + FunctionType <$> cast (value sline) + where + err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has ", + (if anull args then "type " else "function type returting ") <> textExprType @b Proxy ] + +data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a) + +data ArgumentType a + = RequiredArgument + | OptionalArgument + | ExprDefault (Expr a) + | ContextDefault + + +data Traced a = Traced EvalTrace a + +type VarNameSelectors = ( FqVarName, [ 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 ( 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..9bbf06c --- /dev/null +++ b/src/Script/Shell.hs @@ -0,0 +1,94 @@ +module Script.Shell ( + ShellStatement(..), + ShellScript(..), + withShellProcess, +) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Reader + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T + +import System.Exit +import System.IO +import System.Process hiding (ShellCommand) + +import Network +import Network.Ip +import Output +import Process +import Run.Monad +import Script.Var + + +data ShellStatement = ShellStatement + { shellCommand :: Text + , shellArguments :: [ Text ] + , shellSourceLine :: SourceLine + } + +newtype ShellScript = ShellScript [ ShellStatement ] + + +executeScript :: Node -> ProcName -> MVar ExitCode -> Handle -> Handle -> Handle -> ShellScript -> TestRun () +executeScript node pname statusVar pstdin pstdout pstderr (ShellScript statements) = do + setNetworkNamespace $ getNetns node + forM_ statements $ \ShellStatement {..} -> case shellCommand of + "echo" -> liftIO $ do + T.hPutStrLn pstdout $ T.intercalate " " shellArguments + hFlush pstdout + cmd -> do + (_, _, _, phandle) <- liftIO $ createProcess_ "shell" + (proc (T.unpack cmd) (map T.unpack shellArguments)) + { std_in = UseHandle pstdin + , std_out = UseHandle pstdout + , std_err = UseHandle pstderr + , cwd = Just (nodeDir node) + , env = Just [] + } + liftIO (waitForProcess phandle) >>= \case + ExitSuccess -> return () + status -> do + outLine OutputChildFail (Just $ textProcName pname) $ "failed at: " <> textSourceLine shellSourceLine + liftIO $ putMVar statusVar status + throwError Failed + liftIO $ putMVar statusVar ExitSuccess + +spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process +spawnShell procNode procName script = do + procOutput <- liftIO $ newTVarIO [] + statusVar <- liftIO $ newEmptyMVar + ( pstdin, procStdin ) <- liftIO $ createPipe + ( hout, pstdout ) <- liftIO $ createPipe + ( herr, pstderr ) <- liftIO $ createPipe + procHandle <- fmap (Right . (, statusVar)) $ forkTestUsing forkOS $ do + executeScript procNode procName statusVar pstdin pstdout pstderr script + + let procKillWith = Nothing + let process = Process {..} + + void $ forkTest $ lineReadingLoop process hout $ \line -> do + outProc OutputChildStdout process line + liftIO $ atomically $ modifyTVar procOutput (++ [ line ]) + void $ forkTest $ lineReadingLoop process herr $ \line -> do + outProc OutputChildStderr process line + + return process + +withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a +withShellProcess node pname script inner = do + procVar <- asks $ teProcesses . fst + + process <- spawnShell node pname script + liftIO $ modifyMVar_ procVar $ return . (process:) + + inner process `finally` do + ps <- liftIO $ takeMVar procVar + closeTestProcess process `finally` do + liftIO $ putMVar procVar $ filter (/=process) ps 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 719e3e2..3e98efa 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,340 +1,81 @@ module Test ( - Module(..), Test(..), TestStep(..), TestBlock(..), - SourceLine(..), - MonadEval(..), - VarName(..), TypedVarName(..), textVarName, unpackVarName, - ExprType(..), SomeExpr(..), - TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, - FunctionType, DynamicType, - SomeVarValue(..), fromSomeVarValue, textSomeVarValue, someVarValueType, - RecordSelector(..), - ExprListUnpacker(..), - ExprEnumerator(..), - Expr(..), eval, gatherVars, evalSome, - 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.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 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 :: [ Text ] - , moduleTests :: [ Test ] - } +import Network +import Output +import Process +import Run.Monad +import Script.Expr +import Script.Object +import Script.Shell data Test = Test { testName :: Text - , testSteps :: [TestStep] + , testSteps :: Expr (TestStep ()) } -newtype TestBlock = TestBlock [ TestStep ] - -data TestStep = forall a. ExprType a => Let SourceLine (TypedVarName a) (Expr a) [TestStep] - | forall a. ExprType a => For SourceLine (TypedVarName a) (Expr [a]) [TestStep] - | ExprStatement (Expr TestBlock) - | Subnet (TypedVarName Network) (Expr Network) [TestStep] - | DeclNode (TypedVarName Node) (Expr Network) [TestStep] - | Spawn (TypedVarName Process) (Either (Expr Network) (Expr Node)) [TestStep] - | Send (Expr Process) (Expr Text) - | Expect SourceLine (Expr Process) (Expr Regex) [TypedVarName Text] [TestStep] - | Flush (Expr Process) (Maybe (Expr Regex)) - | Guard SourceLine (Expr Bool) - | DisconnectNode (Expr Node) [TestStep] - | DisconnectNodes (Expr Network) [TestStep] - | DisconnectUpstream (Expr Network) [TestStep] - | PacketLoss (Expr Scientific) (Expr Node) [TestStep] - | Wait - -newtype SourceLine = SourceLine Text - - -class MonadFail m => MonadEval m where - lookupVar :: VarName -> m SomeVarValue - rootNetwork :: m Network - - -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 - - -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 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 :: SourceLine -> EvalTrace -> 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 SomeExpr -> 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 (DynVariable tvar _ _)) = ExprTypeVar tvar -someExprType (SomeExpr fun@(FunVariable params _ _)) = ExprTypeFunction params (proxyOfFunctionType fun) - where - proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a - proxyOfFunctionType _ = Proxy -someExprType (SomeExpr (_ :: Expr a)) = ExprTypePrim (Proxy @a) - -textSomeExprType :: SomeExprType -> Text -textSomeExprType (ExprTypePrim p) = textExprType p -textSomeExprType (ExprTypeVar (TypeVar name)) = name -textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r - - -data SomeVarValue = forall a. ExprType a => SomeVarValue (FunctionArguments SomeArgumentType) (SourceLine -> FunctionArguments SomeExpr -> a) - -fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m a -fromSomeVarValue sline name (SomeVarValue args (value :: SourceLine -> args -> 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 args value) - | anull args = textExprValue $ value sline mempty - | otherwise = "<function>" - -someVarValueType :: SomeVarValue -> SomeExprType -someVarValueType (SomeVarValue args (_ :: SourceLine -> args -> 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 - Variable :: ExprType a => SourceLine -> VarName -> Expr a - DynVariable :: TypeVar -> SourceLine -> VarName -> Expr DynamicType - FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> VarName -> Expr (FunctionType a) - ArgsApp :: FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) - FunctionEval :: Expr (FunctionType a) -> Expr a - Pure :: a -> Expr a - App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b - Concat :: [Expr Text] -> Expr Text - Regex :: [Expr Regex] -> Expr Regex - RootNetwork :: Expr Network - Undefined :: String -> Expr 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 - -eval :: MonadEval m => Expr a -> m a -eval (Variable sline name) = fromSomeVarValue sline name =<< lookupVar name -eval (DynVariable _ _ _) = fail "ambiguous type" -eval (FunVariable _ sline name) = funFromSomeVarValue sline name =<< lookupVar name -eval (ArgsApp args efun) = do - FunctionType fun <- eval efun - return $ FunctionType $ \args' -> fun (args <> args') -eval (FunctionEval efun) = do - FunctionType fun <- eval efun - return $ fun mempty -eval (Pure value) = return value -eval (App _ f x) = eval f <*> eval x -eval (Concat xs) = T.concat <$> mapM eval xs -eval (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 -eval (RootNetwork) = rootNetwork -eval (Undefined err) = fail err - -evalSome :: MonadEval m => SomeExpr -> m SomeVarValue -evalSome (SomeExpr expr) = SomeVarValue mempty . const . const <$> eval expr - -gatherVars :: forall a m. MonadEval m => Expr a -> m [((VarName, [Text]), SomeVarValue)] -gatherVars = fmap (uniqOn fst . sortOn fst) . helper - where - helper :: forall b. Expr b -> m [((VarName, [Text]), SomeVarValue)] - helper (Variable _ var) = (:[]) . ((var, []),) <$> lookupVar var - helper (DynVariable _ _ var) = (:[]) . ((var, []),) <$> lookupVar var - helper (FunVariable _ _ var) = (:[]) . ((var, []),) <$> lookupVar var - helper (ArgsApp (FunctionArguments args) fun) = do - v <- helper fun - vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args - return $ concat (v : vs) - helper (FunctionEval efun) = helper efun - helper (Pure _) = return [] - helper e@(App (AnnRecord sel) _ x) - | Just (var, sels) <- gatherSelectors x - = do val <- SomeVarValue mempty . const . const <$> eval e - return [((var, sels ++ [sel]), val)] - | otherwise = helper x - helper (App _ f x) = (++) <$> helper f <*> helper x - helper (Concat es) = concat <$> mapM helper es - helper (Regex es) = concat <$> mapM helper es - helper (RootNetwork) = return [] - helper (Undefined {}) = return [] - - 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) - -anull :: FunctionArguments a -> Bool -anull (FunctionArguments args) = M.null args - -exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType -exprArgs (FunVariable args _ _) = args -exprArgs (ArgsApp (FunctionArguments applied) expr) = - let FunctionArguments args = exprArgs expr - in FunctionArguments (args `M.difference` applied) -exprArgs _ = error "exprArgs on unexpected type" - -funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m (FunctionType a) -funFromSomeVarValue sline name (SomeVarValue args (value :: SourceLine -> args -> 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 6c6c2f0..6dba707 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -4,31 +4,39 @@ module Test.Builtins ( import Data.Map qualified as M import Data.Maybe +import Data.Proxy +import Data.Scientific import Data.Text (Text) -import Data.Typeable import Process (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 "guard" builtinGuard + , fq "multiply_timeout" builtinMultiplyTimeout + , fq "wait" builtinWait ] + where + fq name impl = (( ModuleName [ "$" ], VarName name ), impl ) -getArg :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> (Expr a) +getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a getArg args = fromMaybe (error "parameter mismatch") . getArgMb args -getArgMb :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> Maybe (Expr a) +getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a getArgMb (FunctionArguments args) kw = do - SomeExpr expr <- M.lookup kw args - cast expr + fromSomeVarValue SourceLineBuiltin (LocalVarName (VarName "")) =<< M.lookup kw args + +getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( FqVarName, [ Text ] ), SomeVarValue ) ] +getArgVars (FunctionArguments args) kw = do + maybe [] svvVariables $ M.lookup kw args builtinSend :: SomeVarValue -builtinSend = SomeVarValue (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ] +builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ + \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing) where atypes = [ ( Just "to", SomeArgumentType (ContextDefault @Process) ) @@ -36,17 +44,21 @@ builtinSend = SomeVarValue (FunctionArguments $ M.fromList atypes) $ ] builtinFlush :: SomeVarValue -builtinFlush = SomeVarValue (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args Nothing) ] +builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ + \_ args -> TestBlockStep EmptyTestBlock $ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) where atypes = [ ( Just "from", SomeArgumentType (ContextDefault @Process) ) - , ( Nothing, SomeArgumentType (OptionalArgument @Regex) ) + , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) ) ] builtinGuard :: SomeVarValue -builtinGuard = SomeVarValue (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ - \sline args -> TestBlock [ Guard sline (getArg args Nothing) ] +builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ + \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (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 = SomeVarValue mempty $ const . const $ 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" diff --git a/src/Wrapper.hs b/src/Wrapper.hs deleted file mode 100644 index 544e37c..0000000 --- a/src/Wrapper.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Main where - -import Control.Monad - -import GHC.Environment - -import System.Directory -import System.Environment -import System.FilePath -import System.Linux.Namespaces -import System.Posix.Process -import System.Posix.User -import System.Process - -main :: IO () -main = do - -- we must get uid/gid before unshare - uid <- getEffectiveUserID - gid <- getEffectiveGroupID - - unshare [User, Network, Mount] - writeUserMappings Nothing [UserMapping 0 uid 1] - writeGroupMappings Nothing [GroupMapping 0 gid 1] True - - -- needed for creating /run/netns - callCommand "mount -t tmpfs tmpfs /run" - - epath <- takeDirectory <$> getExecutablePath -- directory containing executable - fpath <- map takeDirectory . filter (any isPathSeparator) . take 1 <$> getFullArgs - -- directory used for invocation, can differ from above for symlinked executable - - let dirs = concat - [ [ epath ] - , [ epath </> "../../../erebos-tester-core/build/erebos-tester-core" ] - , fpath - ] - - args <- getArgs - mapM_ (\file -> executeFile file False args Nothing) =<< - findExecutablesInDirectories dirs "erebos-tester-core" - when (null fpath) $ - mapM_ (\file -> executeFile file False args Nothing) =<< - findExecutables "erebos-tester-core" - - fail "core binary not found" diff --git a/src/main.c b/src/main.c new file mode 100644 index 0000000..98daf2c --- /dev/null +++ b/src/main.c @@ -0,0 +1,81 @@ +#include "HsFFI.h" + +#if defined(__GLASGOW_HASKELL__) +#include "Main_stub.h" +#endif + +#include <errno.h> +#include <fcntl.h> +#include <sched.h> +#include <stdbool.h> +#include <stdio.h> +#include <string.h> +#include <sys/mount.h> +#include <unistd.h> + +/* + * The unshare call with CLONE_NEWUSER needs to happen before starting + * additional threads, which means before initializing the Haskell RTS. + * To achieve that, replace Haskell main with a custom one here that does + * the unshare work and then executes the Haskell code. + */ + +static bool writeProcSelfFile( const char * file, const char * data, size_t size ) +{ + char path[ 256 ]; + if( snprintf( path, sizeof( path ), "/proc/self/%s", file ) + >= sizeof( path ) ){ + fprintf( stderr, "buffer too small\n" ); + return false; + } + + int fd = open( path, O_WRONLY ); + if( fd < 0 ){ + fprintf( stderr, "failed to open %s: %s", path, strerror( errno )); + return false; + } + + ssize_t written = write( fd, data, size ); + if( written < 0 ) + fprintf( stderr, "failed to write to %s: %s\n", path, strerror( errno )); + + close( fd ); + return written == size; +} + +int main( int argc, char * argv[] ) +{ + uid_t uid = geteuid(); + gid_t gid = getegid(); + unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS ); + + char buf[ 256 ]; + int len; + + len = snprintf( buf, sizeof( buf ), "%d %d %d\n", 0, uid, 1 ); + if( len >= sizeof( buf ) ){ + fprintf( stderr, "buffer too small\n" ); + return 1; + } + if ( ! writeProcSelfFile( "uid_map", buf, len ) ) + return 1; + + if ( ! writeProcSelfFile( "setgroups", "deny\n", 5 ) ) + return 1; + + len = snprintf( buf, sizeof( buf ), "%d %d %d\n", 0, gid, 1 ); + if( len >= sizeof( buf ) ){ + fprintf( stderr, "buffer too small\n" ); + return 1; + } + if ( ! writeProcSelfFile( "gid_map", buf, len ) ) + return 1; + + mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" ); + + hs_init( &argc, &argv ); + testerMain(); + hs_exit(); + + return 0; +} 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/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/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..7cc1670 --- /dev/null +++ b/test/script/run.et @@ -0,0 +1,105 @@ +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" ] + 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/ |