diff options
82 files changed, 6200 insertions, 1110 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 74ef7be..66fa169 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,75 @@ # Revision history for erebos-tester +## 0.3.6 -- 2026-09-08 + +* Added reporting-related command-line options: + * `--keep-going` to continue after test failure, + * `--report` to print summary of passed/failed tests, + * `--junit-report` to generate test report in JUnit XML format. +* Explicit type annotation can now be added to expressions and to arguments in function definition using the `:` notation. +* Test dir subdirectory that includes the test module and name is now created for each test. +* Tests can now be selected (or excluded) using module names and fully-qualified names of Tests and Tags. +* In the built-in shell interpreter is now implemented: + * working directory handling with `pwd` and `cd` commands, + * `set +e`/`-e` command to change fail-on-error behavior, + * negation using the `!` operator, + * dollar-expansion for lists to provide list of shell command arguments. +* Fixed parsing of disconnect and packet-loss commands. + +## 0.3.5 -- 2026-05-31 + +* Added tags to group and filter tests. +* Initial support for polymorphic types. +* Added `concat` function and `++` operator to concatenate lists, and support for empty list expression. +* Added `killwith` clause to set a signal used to terminate `spawn`ed process. +* Added `pid` member to the `Process` type to get its system PID. +* Added command-line options to set path of tcpdump or disable its use. + +## 0.3.4 -- 2026-01-15 + +* Show call stack in error messages. +* Verbose output now includes test names, command and arguments for spawned processes, and marks flushed/ignored output lines. +* Added `ignore` builtin command. +* Added `timeout` argument for the `expect` command. +* Support zero as a timeout multiplier. +* Make host filesystems read-only for the test process (except for test dir). +* Implemented pipes and input/output redirection in shell scripts. +* Support for GHC up to 9.14. + +## 0.3.3 -- 2025-06-25 + +* Added optional `timeout` setting to config file +* Added `multiply_timeout` command +* Added `True` and `False` literals, and comparison operators for boolean values +* Added `--exclude` command-line option to exclude tests +* Execute shell commands in appropriate network namespace +* Show name of failed test in output + +## 0.3.2 -- 2025-05-16 + +* Asset files and directories for use during tests +* Select tests from project configuration using only test name on command line without script path +* Added `args` parameter to `spawn` command to pass extra command-line arguments to the spawned tool +* Experimental shell interpreter + +## 0.3.1 -- 2025-03-03 + +* Fix executing test tool given with relative path + +## 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 @@ -31,17 +31,15 @@ Usage ----- The `erebos-tester` tool, when executed without any arguments, -looks for a `erebos-tester.yaml` file in the current or any parent directory (see below for details). -Run `erebos-tester --help` for details about command-line parameters. +looks for an `erebos-tester.yaml` file in the current or any parent directory (see below for details). +Run `erebos-tester --help` for details about available command-line parameters. -The tester can be installed from sources or directly via cabal: -``` -cabal install erebos-tester -``` +### Examples -When available in the `PATH`, it can be run to test the [Haskell Erebos implementation](https://erebosprotocol.net/erebos): +When available in the `PATH`, it can be run, for example, to test +the [Haskell Erebos implementation](https://erebosprotocol.net/erebos): ``` -git clone git://erebosprotocol.net/erebos +git clone https://code.erebosprotocol.net/erebos cd erebos cabal build erebos-tester --tool="$(cabal list-bin erebos) test" --verbose @@ -49,23 +47,51 @@ erebos-tester --tool="$(cabal list-bin erebos) test" --verbose or the [C++ one](https://erebosprotocol.net/cpp): ``` -git clone git://erebosprotocol.net/cpp +git clone https://code.erebosprotocol.net/cpp cd cpp cmake -B build cmake --build build erebos-tester --verbose ``` -To run tests from a given test file, pass it as command-line argument: +### Running + +To run all tests from project configuration (see below), run the tester without any argument: +``` +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.test +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 ``` +### Reports + +By default, `erebos-tester` stops when a test fails, showing backtrace and +values of used variables. That can be changed with the following command-line +options: + +* `--report`: run all the tests, continuing even in the case of error, and + print a short summary of the number of passed and failed test, and a list of + those that failed. + +* `--junit-report=<path>`: run all the tests, and write the report to the file + in `<path>` using the JUnit XML format. + + Configuration ------------- @@ -76,6 +102,11 @@ 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. +* `select`: tests or tags to be selected for running by default (if not provided, all tests will be executed); + given as a single `string` or a list of `string`s. +* `exclude`: tests or tags to be excluded from running (unless requested explicitly on command line); + given as a single `string` or a list of `string`s. +* `timeout`: initial timeout in seconds for test steps like `expect`, given as `int` or `float`; defaults to `1` if not specified. Script language --------------- @@ -106,7 +137,14 @@ The script language is strictly typed without any implicit conversions, although types can not be (as of now) declared explicitly and are always inferred. Each expression has specific concrete type, polymorphic types are not supported (yet). -#### integer +Generally, types of expressions should be inferred, but they can also be given +explicitly to any (sub)expression using the `:` notation: +``` +let x = 1 : Integer +let y = (2 : Integer) + (x : Integer) +``` + +#### `Integer` Integer numbers. Entered as decimal literals and used in arithmetic expressions: ``` @@ -115,7 +153,7 @@ let y = 3 let z = x * 2 + y ``` -#### number +#### `Number` Arbitrary-precision numbers. Entered as literals with decimal point or percentage and used in arithmetic expressions: ``` @@ -124,7 +162,7 @@ let y = 34% let z = x * 2.0 + y ``` -#### string +#### `String` String literals are enclosed in double quotes (`"`), using backslash to escape special characters (`"`, `\` and `$`) @@ -147,7 +185,7 @@ let b = 3 let s = "abc ${2*a + b}" # = "abc 7" ``` -#### regex +#### `Regex` Regular expression literals are enclosed in slash characters (`/`): ``` @@ -163,28 +201,32 @@ let re1 = /./ let re2 = /$str$re1/ # match '.' followed by any character ``` -#### boolean +#### `Bool` Result of comparison operators `==` and `/=`. +Values are `True` and `False`. -#### network +#### `Network` Represents network/subnet, created by `subnet` command and used by `subnet`, `node`, `spawn` and network configuration commands. -#### node +#### `Node` Represents network node, created by `node` command or implicitly by `spawn`, 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. +: The network which the node belongs to. -#### process +#### `Process` Represents running process. Created by `spawn`, used by `send` and `expect` commands. @@ -193,18 +235,44 @@ Members: `node` : Node on which the process is running. +`pid` +: PID of the corresponding system process, `0` if there is none. + +#### `Asset` + +Represents an asset (file or directory), which can be used during test execution. + +Members: + +`path` +: Path to the asset valid during the test execution. + +#### `Tag` + +Tag, which can be assigned to a test using the `tag: <Tag>` declaration. + +#### `Signal` + +Type representing unix signals sent to processes. Values are `SIGINT`, `SIGTERM`, etc. + #### list -Lists are written using bracket notation: +Lists are written using bracket notation, and brackets are also used to express the type: ``` -let numbers = [1, 2, 4] +let numbers = [1, 2, 4] : [Integer] ``` List elements can be of any type, but all elements of a particular list must have the same type. +They can be concatenated using the `concat` function, which takes a list of lists as argument: +``` +let list = concat [[1], [2, 3], [4]] # = [1, 2, 3, 4] +``` +Or with the `++` operator: +``` +let list = [1] ++ [2, 3] ++ [4] # = [1, 2, 3, 4] +``` -Used in the `for` command. - -### Build-in commands +### Built-in commands ``` subnet <name> [of <network>] @@ -219,13 +287,15 @@ node <name> [on <network>] Create a node on network `<network>` (or context network if omitted) and assign the new node to the variable `<name>`. ``` -spawn as <name> [on (<node> | <network>)] +spawn as <name> [on (<node> | <network>)] [args <arguments>] [killwith <signal>] ``` Spawn a new test process on `<node>` or `<network>` (or one from context) and assign the new process to variable `<name>`. When spawning on network, create a new node for this process. +Extra `<arguments>` to the tool can be given as a list of strings using the `args` keyword. The process is terminated when the variable `<name>` goes out of scope (at the end of the block in which it was created) by closing its stdin. +If the `killwith` clause is present, it is also sent the given `<signal>` at that point. When the process fails to terminate successfully within a timeout, the test fails. ``` @@ -234,7 +304,7 @@ send <string> to <process> Send line with `<string>` to the standard input of `<process>`. ``` -expect <regex> from <process> [capture <var1> [, <var2> ... ]] +expect <regex> from <process> [timeout <timeout>] [capture <var1> [, <var2> ... ]] ``` Check whether `<process>` produces line matching `<regex>` on standard output, and if this does not happen within current timeout, the test fails. Output lines produced before starting this command and not matched by some previous `expect` are accepted as well. @@ -247,11 +317,24 @@ The regular expression can contain capture groups – parts enclosed in parenthe In that case the expect command has to have the `capture` clause with matching number of variable names. Results of the captures are then assigned to the newly created variables as strings. +If the `timeout` clause is used, the current timeout value is multiplied by the given `<timeout>` for this `expect` call. +Timeout of zero can be used to expect a matching output line to have been already produced in the past. + ``` -flush [from <proc>] +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>`. + +``` +ignore [from <proc>] [matching <regex>] +``` + +Ignore output lines from `<proc>` (or context process) that match the given +`<regex>` (or all lines if the `matching` clause is not used). Affects both +past and future output of the process; the effect lasts until the end of +the block. ``` guard <expr> @@ -309,12 +392,224 @@ with <expr>: Execute `<test block>` with `<expr>` as context. ``` +multiply_timeout by <multiplier> +``` + +Modify the timeout used for commands like `expect` by multiplying it with `<multiplier>`. +The effect lasts until the end of the block. + +``` wait ``` Wait for user input before continuing. Useful mostly for debugging or test development. +### Shell interpreter + +**Experimental feature**: Functionality is not fully implemented and behavior may change in incompatible ways between releases. + +Using the `shell` expression, it's possible to embed a shell script inside a test script. +The shell script is not passed to an external interpreter, but rather executed by the tester itself, +which allows the use of variables from the rest of the test script: + +``` +test: + node some_node + let x = "abc" + shell as sh on some_node: + echo $x > some_file + echo ${some_node.ip} >> some_file + cat some_file | sed 's/a/A/' > other_file +``` + +The syntax is intended to be generally similar to the classic Bourne shell, +however, only limited functionality is implemented so far (that includes executing commands, pipelines or input/output redirection). + +The general form of the `shell` expression is: + +``` +shell [as <name>] on <node>: + <shell commands> +``` + +Where `<node>` is the network node on which to run the script (it will be run in the network namespace of the node, and with working directory set to the node root), +and `<name>`, if given, is the name of the variable that will refer to the shell process (this can be used e.g. in the `expect` command to check the standard output of the script). +As with the `spawn` command, the resulting process is terminated at the end of the current scope. + +By default the shell process exists with failure whenever any command exits with non-zero status. +This behavior can be disabled using the `set +e` command (and re-enabled with `set -e`). + + +### 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 +``` + +Type of a given parameter can be also given explicitly using the `:` notation: +``` +def say (what : String) to (p : Process): + send what to p +``` + +### 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 as 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 +``` + +### Tags + +Tags are a way to refer to a group of tests, instead of needing to list all their names individually; +for example to mark broken tests, which can then be easily excluded from running until fixed. +Tags are declared using the `tag` keyword on the top level of a module, +and need to be `export`ed if they are to be referenced from outside of that module: + +``` +export tag Broken +``` + +Tags can be assigned to tests in a the test preamble before the first test steps +using `tag: <Tag>` declaration, which can also be given multiple times: + +``` +test SomeBrokenTest: + tag: Broken + tag: OtherTag + spawn as p + ... +``` + +Such tags can then be used instead of test names to select or exclude tests on +command line or in the configuration file. + + Optional dependencies --------------------- diff --git a/erebos-tester.cabal b/erebos-tester.cabal index c3a49e6..05aee55 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -1,14 +1,17 @@ cabal-version: 3.0 name: erebos-tester -version: 0.2.4 -synopsis: Test framework with virtual network using Linux namespaces +version: 0.3.6 +synopsis: Test framework able to run given program on multiple nodes in virtual network description: This framework is intended mainly for networking libraries/applications and can run multiple concurrent instances of the tested application on different nodes, possibly within separate subnets, on the virtual network. Each instance can receive its own commands and produce output to be checked via standard input/output, as defined using custom script language. + + The virtual network is created using Linux namespaces, so the framework + is Linux-specific. homepage: https://erebosprotocol.net/tester -- bug-reports: license: GPL-3.0-only @@ -21,100 +24,93 @@ extra-doc-files: README.md CHANGELOG.md -flag ci - description: Options for CI testing - default: False - manual: True - 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: - -Werror - -- sometimes needed for backward/forward compatibility: - -Wno-error=unused-imports - - build-depends: - base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 }, - -executable erebos-tester - import: common - ghc-options: - -- disable interval timer to avoid spawing thread that breaks unshare(CLONE_NEWUSER) - -with-rtsopts=-V0 - if impl(ghc >= 9.8) - ghc-options: - -- no multithreading is allowed for unshare(CLONE_NEWUSER) - -single-threaded - - main-is: Wrapper.hs - -- other-modules: - -- other-extensions: - build-depends: - directory >=1.3 && <1.4, - filepath ^>= { 1.4.2.1, 1.5.2 }, - linux-namespaces^>=0.1.3, - process ^>=1.6.9, - unix >=2.7 && <2.9, - hs-source-dirs: src - default-language: Haskell2010 + main-is: + Main.hs -executable erebos-tester-core - import: common - ghc-options: - -threaded + other-modules: + Asset + Config + GDB + JUnit + Network + Network.Ip + Output + Parser + Parser.Core + Parser.Expr + Parser.Shell + Parser.Statement + Paths_erebos_tester + Process + Process.Signal + Run + Run.Builtins + Run.Monad + Sandbox + Script.Expr + Script.Expr.Class + Script.Module + Script.Object + Script.Shell + Script.Var + Test + Test.Builtins + TestMode + TextFormat + TextFormat.Ansi + TextFormat.Types + Util + Version + Version.Git - main-is: Main.hs + autogen-modules: + Paths_erebos_tester - 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 + c-sources: + src/main.c + src/shell.c - autogen-modules: Paths_erebos_tester + other-extensions: + CPP + TemplateHaskell + default-extensions: + DefaultSignatures + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + QuantifiedConstraints + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + TypeApplications + TypeFamilies + TypeOperators - 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, 4.22 }, bytestring ^>= { 0.10, 0.11, 0.12 }, - containers ^>= { 0.6.2.1, 0.7 }, + containers ^>= { 0.6.2.1, 0.7, 0.8 }, + clock ^>= { 0.8.3 }, directory ^>=1.3.6.0, filepath ^>= { 1.4.2.1, 1.5.2 }, Glob >=0.10 && <0.11, @@ -126,10 +122,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, 2.24 }, 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..d381817 100644 --- a/minici.yaml +++ b/minici.yaml @@ -1,3 +1,13 @@ job build: + shell: | + cabal build --ghc-options='-Werror -Wno-error=unused-imports' --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: - - cabal build -fci + - 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..2b14dcf --- /dev/null +++ b/src/Asset.hs @@ -0,0 +1,33 @@ +module Asset ( + Asset(..), + AssetPath(..), textAssetPath, +) 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..af2161a 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -2,11 +2,14 @@ module Config ( Config(..), findConfig, parseConfig, + getConfigTestFiles, ) where import Control.Monad.Combinators import Data.ByteString.Lazy qualified as BS +import Data.Scientific +import Data.Text (Text) import Data.Text qualified as T import Data.YAML @@ -16,31 +19,41 @@ import System.FilePath import System.FilePath.Glob data Config = Config - { configTool :: Maybe FilePath - , configTests :: [Pattern] + { configDir :: FilePath + , configTool :: Maybe FilePath + , configTests :: [ Pattern ] + , configSelect :: Maybe [ Text ] + , configExclude :: [ Text ] + , 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 ] ) + configSelect <- foldr1 (<|>) + [ fmap (Just . (: [])) (m .: "select") -- single item + , m .:? "select" -- list of items + ] + configExclude <- foldr1 (<|>) + [ fmap (: []) (m .: "exclude") -- single item + , m .:? "exclude" .!= [] -- list of items + ] + 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 +76,7 @@ parseConfig path = do Left (pos, err) -> do putStr $ prettyPosWithSource pos contents err exitFailure - Right conf -> return conf + Right conf -> return $ conf $ takeDirectory path + +getConfigTestFiles :: Config -> IO [ FilePath ] +getConfigTestFiles config = concat <$> mapM (flip globDir1 $ configDir config) (configTests config) @@ -72,14 +72,19 @@ gdbStart onCrash = do { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } pout <- liftIO $ newTVarIO [] + ignore <- liftIO $ newTVarIO ( 0, [] ) + pid <- liftIO $ getPid handle let process = Process - { procName = ProcNameGDB - , procHandle = handle + { procId = ProcessId (-2) + , procName = ProcNameGDB + , procHandle = Left handle , procStdin = hin , procOutput = pout + , procIgnore = ignore , procKillWith = Nothing , procNode = undefined + , procPid = pid } gdb <- GDB <$> pure process @@ -144,7 +149,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/JUnit.hs b/src/JUnit.hs new file mode 100644 index 0000000..03e07ec --- /dev/null +++ b/src/JUnit.hs @@ -0,0 +1,60 @@ +module JUnit ( + writeJUnitReport, +) where + +import Control.Monad + +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as BC +import Data.Function +import Data.List.NonEmpty qualified as NE +import Data.Scientific +import Data.Text qualified as T +import Data.Text.Encoding + +import System.Directory +import System.FilePath +import System.IO + +import Run +import Script.Var + + +showTime :: Scientific -> B.ByteString +showTime = BC.pack . formatScientific Fixed Nothing + +writeJUnitReport :: FilePath -> Report -> IO () +writeJUnitReport path Report {..} = do + createDirectoryIfMissing True $ takeDirectory path + withFile path WriteMode $ \h -> do + B.hPutStr h $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" + B.hPutStr h $ "<testsuites time=\"" <> showTime reportTotalTime <> "\">\n" + forM_ (NE.groupBy ((==) `on` (testNameModule . reportTestName)) reportTests) $ \grp -> do + B.hPutStr h $ "<testsuite name=\"" <> encodeUtf8 (textModuleName $ testNameModule $ reportTestName $ NE.head grp) <> "\" time=\"" <> showTime (sum $ map reportTime $ NE.toList grp) <> "\">" + forM_ grp $ \SingleTestReport {..} -> do + B.hPutStr h $ B.concat + [ "<testcase name=\"", encodeUtf8 (testNameBase reportTestName), "\"" + , " classname=\"", encodeUtf8 (textModuleName $ testNameModule reportTestName), "\"" + , " time=\"", showTime reportTime, "\">" + , "<system-out>" + , encodeUtf8 $ escape reportOutput + , "</system-out>" + , case reportTestFailed of + Nothing -> do + "" + Just Failed -> do + "<failure message=\"Test failed\">" <> encodeUtf8 (escape reportOutputError) <> "</failure>" + Just (ProcessCrashed _) -> do + "<error message=\"Process crashed\">" <> encodeUtf8 (escape reportOutputError) <> "</error>" + , "</testcase>" + ] + + B.hPutStr h $ "</testsuite>" + B.hPutStr h $ "</testsuites>\n" + + where + escape = T.concatMap $ \case + '&' -> "&" + '<' -> "<" + '>' -> ">" + c -> T.singleton c diff --git a/src/Main.hs b/src/Main.hs index 61afbd8..3bc9e22 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,10 +1,14 @@ module Main (main) where import Control.Monad +import Control.Monad.Reader +import Data.Char import Data.Maybe -import qualified Data.Text as T +import Data.Text (Text) +import Data.Text qualified as T +import Text.Printf import Text.Read (readMaybe) import System.Console.GetOpt @@ -12,40 +16,54 @@ 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 JUnit import Output -import Parser +import Parser.Core import Process -import Run -import Test -import Util +import Run.Builtins +import TestMode +import TextFormat import Version data CmdlineOptions = CmdlineOptions { optTest :: TestOptions - , optRepeat :: Int + , optExclude :: [ Text ] , optVerbose :: Bool + , optReport :: Bool + , optJUnitReport :: Maybe FilePath , optColor :: Maybe Bool , optShowHelp :: Bool , optShowVersion :: Bool + , optTestMode :: Bool + , optCmdlineTcpdump :: TcpdumpOption } defaultCmdlineOptions :: CmdlineOptions defaultCmdlineOptions = CmdlineOptions { optTest = defaultTestOptions - , optRepeat = 1 + , optExclude = [] , optVerbose = False + , optReport = False + , optJUnitReport = Nothing , optColor = Nothing , optShowHelp = False , optShowVersion = False + , optTestMode = False + , optCmdlineTcpdump = TcpdumpAuto } -options :: [OptDescr (CmdlineOptions -> CmdlineOptions)] +data TcpdumpOption + = TcpdumpAuto + | TcpdumpManual FilePath + | TcpdumpOff + + +options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] options = [ Option ['T'] ["tool"] (ReqArg (\str -> to $ \opts -> case break (==':') str of @@ -77,11 +95,29 @@ options = (NoArg $ to $ \opts -> opts { optKeep = True }) "keep test directory even if all tests succeed" , Option ['r'] ["repeat"] - (ReqArg (\str opts -> opts { optRepeat = read str }) "<count>") + (ReqArg (\str -> to $ \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|tag>") + "exclude given test or test tag from execution" + , Option [] [ "keep-going" ] + (NoArg $ to $ \opts -> opts { optKeepGoing = True }) + "keep going after a failed test" + , Option [] [ "report" ] + (NoArg $ \opts -> opts { optReport = True, optTest = (optTest opts) { optKeepGoing = True } }) + "print summary of passing and failing tests (implies --keep-going)" + , Option [] [ "junit-report" ] + (ReqArg (\str opts -> opts { optJUnitReport = Just str, optTest = (optTest opts) { optKeepGoing = True } }) "<path>") + "write test report in JUnit XML format to <path> (implies --keep-going)" , Option [] ["wait"] (NoArg $ to $ \opts -> opts { optWait = True }) "wait at the end of each test" + , Option [] [ "no-tcpdump" ] + (NoArg (\opts -> opts { optCmdlineTcpdump = TcpdumpOff })) + "do not run tcpdump to capture network traffic" + , Option [] [ "tcpdump" ] + (OptArg (\str opts -> opts { optCmdlineTcpdump = maybe TcpdumpAuto TcpdumpManual str }) "<path>") + "use tcpdump to capture network traffic, at given <path> or found in PATH" , Option ['h'] ["help"] (NoArg $ \opts -> opts { optShowHelp = True }) "show this help and exit" @@ -92,11 +128,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 +147,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 +179,88 @@ 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 + let outputStyle + | optVerbose opts = OutputStyleVerbose + | otherwise = OutputStyleQuiet + out <- startOutput outputStyle useColor + + lm@LoadedModules {..} <- exitOnError =<< loadModules files + + let tfSelect = if null otests then Nothing else Just otests + tfExclude = optExclude opts + tfilter = maybe mempty testFilterFromConfig config <> TestFilter {..} + tests <- exitOnError $ filterTests tfilter lm - tests <- forM files $ \(path, mbTestName) -> do - Module { .. } <- parseTestFile path - return $ case mbTestName of - Nothing -> moduleTests - Just name -> filter ((==name) . testName) moduleTests + tcpdump <- case optCmdlineTcpdump opts of + TcpdumpAuto -> findExecutable "tcpdump" + TcpdumpManual path -> return (Just path) + TcpdumpOff -> return Nothing + + let topts = (optTest opts) + { optTcpdump = tcpdump + } + + report@Report {..} <- runTests out topts lmGlobalDefs tests + + when (optReport opts) $ flip runReaderT out $ do + outLineF OutputGlobalSummary Nothing $ "Total tests: " <> plainText (T.pack (show reportTotalCount)) + let ( mins, secs ) = (floor reportTotalTime :: Integer) `quotRem` 60 + csecs = floor (reportTotalTime * 100) `rem` 100 :: Integer + outLineF OutputGlobalSummary Nothing $ "Total time: " <> plainText (T.pack $ printf "%d:%02d.%02d" mins secs csecs) + outLineF OutputGlobalSummary Nothing $ mconcat + [ "Passed tests: " + , withStyle (if (reportPassedCount > 0) then setForegroundColor Green noStyle else noStyle) $ + plainText $ T.pack $ show reportPassedCount + ] + outLineF OutputGlobalSummary Nothing $ mconcat + [ "Failed tests: " + , withStyle (if (reportFailedCount > 0) then setForegroundColor Red noStyle else noStyle) $ + plainText (T.pack (show reportFailedCount)) + ] + when (reportFailedCount > 0) $ do + outLine OutputGlobalSummary Nothing "" + outLineF OutputGlobalSummary Nothing $ withStyle (setForegroundColor BrightRed noStyle) $ "Failed tests:" + forM_ reportFailedList $ \tname -> do + outLineF OutputGlobalSummary Nothing $ + withStyle (setForegroundColor Red noStyle) $ + plainText $ textTestName tname + + forM_ (optJUnitReport opts) $ \path -> writeJUnitReport path report + + when (reportFailedCount > 0) exitFailure + +exitOnError :: Either CustomTestError a -> IO a +exitOnError (Left err) = do + hPutStrLn stderr $ capitalize $ showCustomTestError err + exitFailure + where + capitalize (c : cs) = toUpper c : cs + capitalize [] = [] +exitOnError (Right x) = do + return x - ok <- allM (runTest out $ optTest opts) $ - concat $ replicate (optRepeat opts) $ concat tests - when (not ok) exitFailure +foreign export ccall testerMain :: IO () +testerMain :: IO () +testerMain = main diff --git a/src/Network.hs b/src/Network.hs index aa06952..b48a233 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 @@ -99,28 +101,33 @@ instance HasNetns Network where getNetns = netNetns instance HasNetns Node where getNetns = nodeNetns instance ExprType Network where - textExprType _ = T.pack "network" - textExprValue n = "s:" <> textNetworkName (netPrefix n) + textExprType _ = T.pack "Network" + textExprValue n = "<network:" <> textNetworkName (netPrefix n) <> ">" instance ExprType Node where - textExprType _ = T.pack "node" - textExprValue n = T.pack "n:" <> textNodeName (nodeName n) + textExprType _ = T.pack "Node" + textExprValue n = T.pack "<node:" <> 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 newInternet :: MonadIO m => FilePath -> m Internet newInternet dir = do + adir <- liftIO $ makeAbsolute dir atomicallyWithIO $ do Internet - <$> pure dir - <*> newNetwork (IpPrefix [1]) dir + <$> pure adir + <*> newNetwork (IpPrefix [1]) adir delInternet :: MonadIO m => Internet -> m () delInternet _ = liftIO $ do 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..b0744d4 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -1,10 +1,15 @@ module Output ( - Output, OutputType(..), + Output, OutputStyle(..), OutputType(..), MonadOutput(..), startOutput, + resetOutputTime, + getElapsedTime, outLine, + outLineF, outPromptGetLine, outPromptGetLineCompletion, + collectOutput, + collectErrorOutput, ) where import Control.Concurrent.MVar @@ -12,38 +17,65 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader +import Data.Scientific import Data.Text (Text) 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 + +import Script.Expr + +import TextFormat +import TextFormat.Ansi + data Output = Output { outState :: MVar OutputState , outConfig :: OutputConfig + , outStartedAt :: MVar TimeSpec } data OutputConfig = OutputConfig - { outVerbose :: Bool + { outStyle :: OutputStyle , outUseColor :: Bool } data OutputState = OutputState { outPrint :: TL.Text -> IO () , outHistory :: History + , outLines :: [ Text ] + , outErrLines :: [ Text ] } -data OutputType = OutputChildStdout - | OutputChildStderr - | OutputChildStdin - | OutputChildInfo - | OutputChildFail - | OutputMatch - | OutputMatchFail - | OutputError - | OutputAlways +data OutputStyle + = OutputStyleQuiet + | OutputStyleVerbose + | OutputStyleTest + deriving (Eq) + +data OutputType + = OutputGlobalInfo + | OutputGlobalError + | OutputGlobalSummary + | OutputChildStdout + | OutputChildStderr + | OutputChildStdin + | OutputChildExec + | OutputChildInfo + | OutputChildFail + | OutputMatch + | OutputMatchFail CallStack + | OutputIgnored + | OutputError + | OutputAlways + | OutputTestRaw class MonadIO m => MonadOutput m where getOutput :: m Output @@ -51,64 +83,201 @@ 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 + , outLines = [] + , outErrLines = [] + } + outConfig <- pure OutputConfig {..} + outStartedAt <- newMVar =<< getTime Monotonic + hSetBuffering stdout LineBuffering + return Output {..} + +resetOutputTime :: Output -> IO () +resetOutputTime Output {..} = do + modifyMVar_ outStartedAt . const $ getTime Monotonic + +getElapsedTime :: Output -> IO Scientific +getElapsedTime Output {..} = do + stime <- readMVar outStartedAt + (/ 1000000000) . fromIntegral . toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic + outColor :: OutputType -> Text -outColor OutputChildStdout = T.pack "0" -outColor OutputChildStderr = T.pack "31" -outColor OutputChildStdin = T.pack "0" -outColor OutputChildInfo = T.pack "0" -outColor OutputChildFail = T.pack "31" -outColor OutputMatch = T.pack "32" -outColor OutputMatchFail = T.pack "31" -outColor OutputError = T.pack "31" -outColor OutputAlways = "0" +outColor = \case + OutputGlobalInfo -> "0" + OutputGlobalError -> "31" + OutputGlobalSummary -> "0" + OutputChildStdout -> "0" + OutputChildStderr -> "31" + OutputChildStdin -> "0" + OutputChildExec -> "33" + OutputChildInfo -> "0" + OutputChildFail -> "31" + OutputMatch -> "32" + OutputMatchFail {} -> "31" + OutputIgnored -> "90" + OutputError -> "31" + OutputAlways -> "0" + OutputTestRaw -> "0" outSign :: OutputType -> Text -outSign OutputChildStdout = T.empty -outSign OutputChildStderr = T.pack "!" -outSign OutputChildStdin = T.empty -outSign OutputChildInfo = T.pack "." -outSign OutputChildFail = T.pack "!!" -outSign OutputMatch = T.pack "+" -outSign OutputMatchFail = T.pack "/" -outSign OutputError = T.pack "!!" -outSign OutputAlways = T.empty +outSign = \case + OutputGlobalInfo -> "" + OutputGlobalError -> "" + OutputGlobalSummary -> "" + OutputChildStdout -> " " + OutputChildStderr -> "!" + OutputChildStdin -> T.empty + OutputChildExec -> "*" + OutputChildInfo -> "." + OutputChildFail -> "!!" + OutputMatch -> "+" + OutputMatchFail {} -> "/" + OutputIgnored -> "-" + OutputError -> "!!" + OutputAlways -> T.empty + OutputTestRaw -> T.empty outArr :: OutputType -> Text -outArr OutputChildStdin = "<" -outArr _ = ">" +outArr = \case + OutputGlobalInfo -> "" + OutputGlobalError -> "" + OutputGlobalSummary -> "" + OutputChildStdin -> "<" + _ -> ">" + +outTestLabel :: OutputType -> Text +outTestLabel = \case + OutputGlobalInfo -> "global-info" + OutputGlobalError -> "global-error" + OutputGlobalSummary -> "global-summary" + OutputChildStdout -> "child-stdout" + OutputChildStderr -> "child-stderr" + OutputChildStdin -> "child-stdin" + OutputChildExec -> "child-exec" + OutputChildInfo -> "child-info" + OutputChildFail -> "child-fail" + OutputMatch -> "match" + OutputMatchFail {} -> "match-fail" + OutputIgnored -> "ignored" + OutputError -> "error" + OutputAlways -> "other" + OutputTestRaw -> "" printWhenQuiet :: OutputType -> Bool printWhenQuiet = \case + OutputGlobalSummary -> True + OutputAlways -> True + t -> printIsError t + +printIsError :: OutputType -> Bool +printIsError = \case + OutputGlobalError -> True OutputChildStderr -> True OutputChildFail -> True - OutputMatchFail -> True + OutputMatchFail {} -> True OutputError -> True - OutputAlways -> True _ -> False +includeTestTime :: OutputType -> Bool +includeTestTime = \case + OutputGlobalInfo -> False + OutputGlobalError -> False + OutputGlobalSummary -> False + _ -> True + ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a 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 - withMVar (outState out) $ \st -> do - outPrint st $ TL.fromChunks $ concat - [ if outUseColor (outConfig out) +outLine otype prompt line = outLineF otype prompt (plainText line) + +outLineF :: MonadOutput m => OutputType -> Maybe Text -> FormattedText -> m () +outLineF otype prompt line = ioWithOutput $ \out -> + case outStyle (outConfig out) of + OutputStyleQuiet -> normalOutput (printWhenQuiet otype) out + OutputStyleVerbose -> normalOutput True out + OutputStyleTest -> testOutput out + where + normalOutput normal out = do + secs <- getElapsedTime out + + let formatLine color line' = T.concat $ concat + [ if includeTestTime otype + then [ T.pack $ printf "[% 2d.%03d] " (floor secs :: Integer) (floor (secs * 1000) `rem` 1000 :: Integer) ] + else [] + , if color then [ T.pack "\ESC[", outColor otype, T.pack "m" ] else [] , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ] - , [ line ] - , if outUseColor (outConfig out) + , [ line' ] + , if color then [ T.pack "\ESC[0m" ] else [] ] + modifyMVar_ (outState out) $ \ost -> do + (\f -> foldM f ost (normalOutputLines otype $ renderLine out line)) $ \st line' -> do + when normal $ do + outPrint st $ TL.fromStrict $ formatLine (outUseColor (outConfig out)) line' + return st + { outLines = formatLine False line' : outLines st + , outErrLines = (if printIsError otype + then (formatLine False line' :) + else id) $ outErrLines st + } + + renderLine out + | outUseColor (outConfig out) = fromAnsiText . renderAnsiText + | otherwise = renderPlainText + + testOutput out = do + let pline = renderPlainText line + withMVar (outState out) $ \st -> do + case otype of + OutputTestRaw -> outPrint st $ TL.fromStrict pline + _ -> forM_ (testOutputLines otype (maybe "-" id prompt) pline) $ outPrint st . TL.fromStrict + + +normalOutputLines :: OutputType -> Text -> [ Text ] +normalOutputLines (OutputMatchFail (CallStack stack)) msg = concat + [ msg <> " on " <> textSourceLine stackTopLine : showVars stackTopVars + , concat $ flip map stackRest $ \( sline, vars ) -> + " called from " <> textSourceLine sline : showVars vars + ] + where + showVars = + map $ \(( name, sel ), value ) -> T.concat + [ " ", textFqVarName name, T.concat (map ("."<>) sel) + , " = ", textSomeVarValue value + ] + (( stackTopLine, stackTopVars ), stackRest ) = + case stack of + (stop : srest) -> ( stop, srest ) + [] -> (( SourceLine "unknown", [] ), [] ) +normalOutputLines _ msg = [ msg ] + + +testOutputLines :: OutputType -> Text -> Text -> [ Text ] +testOutputLines otype@(OutputMatchFail (CallStack stack)) _ msg = concat + [ [ T.concat [ outTestLabel otype, " ", msg ] ] + , concat $ flip map stack $ \( sline, vars ) -> + T.concat [ outTestLabel otype, "-line ", textSourceLine sline ] : showVars vars + , [ T.concat [ outTestLabel otype, "-done" ] ] + ] + where + showVars = + map $ \(( name, sel ), value ) -> T.concat + [ outTestLabel otype, "-var ", textFqVarName name, T.concat (map ("."<>) sel) + , " ", textSomeVarValue value + ] +testOutputLines otype prompt msg = [ T.concat [ outTestLabel otype, " ", prompt, " ", msg ] ] + + outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text) outPromptGetLine = outPromptGetLineCompletion noCompletion @@ -125,3 +294,14 @@ outPromptGetLineCompletion compl prompt = ioWithOutput $ \out -> do return (x, st' { outPrint = outPrint st, outHistory = hist' }) putMVar (outState out) st' return $ fmap T.pack x + + +collectOutput :: Output -> IO Text +collectOutput Output {..} = do + modifyMVar outState $ \st -> do + return ( st { outLines = [] }, T.unlines $ reverse $ outLines st ) + +collectErrorOutput :: Output -> IO Text +collectErrorOutput Output {..} = do + modifyMVar outState $ \st -> do + return ( st { outErrLines = [] }, T.unlines $ reverse $ outErrLines st ) diff --git a/src/Parser.hs b/src/Parser.hs index 6d6809b..cba119b 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,77 +1,270 @@ {-# 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 + } + href <- L.indentLevel + testNameBase <- header + testNameModule <- gets testCurrentModuleName + let testName = TestName {..} + + osymbol ":" <* eol <* scn + + ref <- L.indentGuard scn GT href + testTags <- preamble ref + testSteps <- fmap Scope <$> testBlock ref + return Test {..} + + where + header = do + wsymbol "test" + lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') + + preamble :: Pos -> TestParser [ Expr Tag ] + preamble ref = fmap catMaybes $ many $ do + void $ L.indentGuard scn EQ ref + off <- stateOffset <$> getParserState + name <- try $ identifier <* osymbol ":" + <* ((eol >> mzero) <|> return ()) -- continue only if not on EOL + case name of + "tag" -> do + Just <$> typedExpr FunctionTerm <* eol <* scn + _ -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "unexpected test metadata ‘" <> T.unpack name <> "’" + takeWhileP Nothing (/= '\n') *> eol *> scn *> return Nothing + + +parseDefinition :: Pos -> TestParser ( VarName, SomeExpr ) +parseDefinition href = label "symbol definition" $ do + def@( name, expr ) <- localState $ do + wsymbol "def" + name <- varName + argsDecl <- functionArguments (\off _ -> return . ( off, )) + (typeAnnotated varName) mzero (\_ -> return . (, Nothing) . VarName) + atypes <- forM argsDecl $ \( off, ( vname :: VarName, mbstype :: Maybe SomeExprType ) ) -> do + stype <- maybe (ExprTypeVar <$> newTypeVar) return mbstype + modify $ \s -> s { testVars = ( vname, ( LocalVarName vname, stype )) : testVars s } + return ( off, vname, stype ) + SomeExpr expr <- choice + [ do + osymbol ":" + scn + ref <- L.indentGuard scn GT href + SomeExpr <$> testBlock ref + , do + osymbol "=" + someExpr FunctionTerm <* 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 $ \( _, vname, stype ) -> do + ( vname, ) . SomeArgumentType OptionalArgument <$> typeClosure stype + + 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 (ExprTypeVar tvar) sline vname)) + | Just (ExprTypePrim (Proxy :: Proxy v)) <- M.lookup tvar unif + = SomeExpr (Variable sline vname :: Expr v) + replaceArgs (SomeExpr e) = SomeExpr (go unif e) + e -> e + + typeAnnotated p = do + x <- p + choice + [ do + void $ osymbol ":" + stype <- typeExpr + return ( x, Just stype ) + + , do + return ( x, Nothing ) + ] + +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 ) + +parseTag :: Pos -> TestParser ( VarName, SomeExpr ) +parseTag _ = label "tag definition" $ do + wsymbol "tag" + name <- constrName + void eol + cmn <- gets testCurrentModuleName + let expr = SomeExpr $ Pure $ Tag cmn name + modify $ \s -> s { testVars = ( name, ( GlobalVarName cmn name, someExprType expr )) : testVars s } + scn + 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 <|> parseTag 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) + , (: []) <$> toplevel ToplevelDefinition (parseTag 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 :: [ SomePrimType ] -> [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] )) +parseTestFiles builtinTypes paths = do + parsedModules <- newIORef [] + runExceptT $ do + requestedModules <- reverse <$> foldM (go parsedModules) [] paths + allModules <- map snd <$> liftIO (readIORef parsedModules) + return ( requestedModules, allModules ) + where + builtinTypes' = map (\(SomePrimType p) -> ( VarName (textExprType p), ExprTypePrim p )) builtinTypes + go parsedModules res path = do + liftIO (parseTestFile builtinTypes' 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 :: [ ( VarName, SomeExprType ) ] -> IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module) +parseTestFile builtinTypes 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, someExprType value ))) $ M.toList builtins + ] + , testTypeVars = builtinTypes + , 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 builtinTypes 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..78fc666 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -1,39 +1,106 @@ module Parser.Core where +import Control.Applicative +import Control.Arrow import Control.Monad import Control.Monad.State import Control.Monad.Writer +import Data.List import Data.Map (Map) import Data.Map qualified as M import Data.Maybe import Data.Set qualified as S +import Data.Text (Text) 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.Expr.Class +import Script.Module import Test - -type TestParser = StateT TestParserState (ParsecT Void TestStream (Writer [ Toplevel ])) +import Util + +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 + | TestNotFound Text (Maybe FilePath) + | TestOrTagNotFound Text (Maybe 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 + + compare (TestNotFound a a') (TestNotFound b b') = compare ( a, a' ) ( b, b' ) + compare (TestNotFound _ _ ) _ = LT + compare _ (TestNotFound _ _ ) = GT + + compare (TestOrTagNotFound a a') (TestOrTagNotFound b b') = compare ( a, a' ) ( b, b' ) + compare (TestOrTagNotFound _ _ ) _ = LT + compare _ (TestOrTagNotFound _ _ ) = 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 (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle + showErrorComponent err = showCustomTestError err + +showCustomTestError :: CustomTestError -> String +showCustomTestError = \case + ModuleNotFound name -> "module ‘" <> T.unpack (textModuleName name) <> "’ not found" + FileNotFound path -> "file ‘" <> path <> "’ not found" + TestNotFound tname mbpath -> "test ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath + TestOrTagNotFound tname mbpath -> "test or tag ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath + ImportModuleError bundle -> 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 )) ] + , testTypeVars :: [ ( VarName, SomeExprType ) ] , testContext :: SomeExpr , testNextTypeVar :: Int , testTypeUnif :: Map TypeVar SomeExprType + , testCurrentModuleName :: ModuleName + , testParseModule :: ModuleName -> ModuleName -> IO (Either CustomTestError Module) } newTypeVar :: TestParser TypeVar @@ -42,25 +109,77 @@ 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) + ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType) + ExprTypeFunction args (ExprTypePrim (_ :: Proxy a)) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a)) + stype -> return $ SomeExpr $ DynVariable stype sline fqn + +lookupScalarVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr +lookupScalarVarExpr off sline name = do + ( fqn, etype ) <- lookupVarType off name + case etype of + ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a) + ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType) + ExprTypeFunction args (ExprTypePrim (pa :: Proxy a)) -> do + SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a)) + stype -> return $ SomeExpr $ DynVariable stype sline fqn + +lookupType :: Int -> VarName -> TestParser SomeExprType +lookupType off name = do + gets (lookup name . testTypeVars) >>= \case + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ + "type not in scope: ‘" <> textVarName name <> "’" + return $ ExprTypeVar (TypeVar $ textVarName name) + Just x -> return x + + +resolveKnownTypeVars :: SomeExprType -> TestParser ( SomeExprType, [ TypeVar ] ) +resolveKnownTypeVars = fmap (fmap (uniq . sort)) . runWriterT . go + where + go stype = case stype of + ExprTypePrim {} -> return stype + ExprTypeConstr1 {} -> return stype + ExprTypeVar tvar -> do + gets (M.lookup tvar . testTypeUnif) >>= \case + Just stype' -> go stype' + Nothing -> tell [ tvar ] >> return stype + ExprTypeFunction args body -> ExprTypeFunction <$> go args <*> go body + ExprTypeArguments args -> ExprTypeArguments <$> mapM (\(SomeArgumentType a t) -> SomeArgumentType a <$> go t) args + ExprTypeApp ctor params -> do + ctor' <- go ctor + params' <- mapM go params + return $ case ( ctor', params' ) of + ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] ) + -> ExprTypePrim (Proxy :: Proxy (c' p')) + _ -> ExprTypeApp ctor' params' + ExprTypeForall tvar inner -> ExprTypeForall tvar <$> go inner + +typeClosure :: SomeExprType -> TestParser SomeExprType +typeClosure stype = do + ( stype', freeVars ) <- resolveKnownTypeVars stype + return $ go freeVars stype' + where + go [] t = t + go (v : vs) t = ExprTypeForall v $ go vs t unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do @@ -117,9 +236,53 @@ unify _ res@(ExprTypePrim (Proxy :: Proxy a)) (ExprTypePrim (Proxy :: Proxy b)) | Just (Refl :: a :~: b) <- eqT = return res +unify _ res@(ExprTypeConstr1 (Proxy :: Proxy a)) (ExprTypeConstr1 (Proxy :: Proxy b)) + | Just (Refl :: a :~: b) <- eqT + = return res + +unify off (ExprTypeFunction args res) (ExprTypeFunction args' res') + = ExprTypeFunction + <$> unify off args args' + <*> unify off res res' + +unify off (ExprTypeApp ac aparams) (ExprTypeApp bc bparams) + | length aparams == length bparams + = do + c <- unify off ac bc + params <- zipWithM (unify off) aparams bparams + return $ case ( c, params ) of + ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] ) + -> ExprTypePrim (Proxy :: Proxy (c' p')) + _ -> ExprTypeApp c params + +unify off a@(ExprTypeApp {}) (ExprTypePrim bproxy) + | TypeDeconstructor1 c p <- matchTypeConstructor bproxy + = unify off a (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ]) + +unify off (ExprTypePrim aproxy) b@(ExprTypeApp {}) + | TypeDeconstructor1 c p <- matchTypeConstructor aproxy + = unify off (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ]) b + unify off a b = do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "couldn't match expected type `" <> textSomeExprType a <> "' with actual type `" <> textSomeExprType b <> "'" + "couldn't match expected type ‘" <> textSomeExprType a <> "’ with actual type ‘" <> textSomeExprType b <> "’" + + +unifyArguments + :: FunctionArguments SomeArgumentType + -> FunctionArguments ( Int, SomeExpr ) + -> TestParser ( FunctionArguments SomeExpr, ( FunctionArguments SomeArgumentType, FunctionArguments ( Int, SomeExpr ) ) ) +unifyArguments (FunctionArguments am) (FunctionArguments bm) = (toArgs *** (toArgs *** toArgs)) <$> go (M.toAscList am) (M.toAscList bm) + where + toArgs = FunctionArguments . M.fromAscList + go [] bs = return ( [], ( [], bs ) ) + go as [] = return ( [], ( as, [] ) ) + go (a@( ak, SomeArgumentType _ at ) : as) (b@( bk, ( off, expr ) ) : bs) + | ak < bk = second (first (a :)) <$> go as (b : bs) + | bk < ak = second (second (b :)) <$> go (a : as) bs + | otherwise = do + expr' <- unifySomeExpr off at expr + first (( ak, expr' ) :) <$> go as bs unifyExpr :: forall a b proxy. (ExprType a, ExprType b) => Int -> proxy a -> Expr b -> TestParser (Expr a) @@ -127,27 +290,33 @@ unifyExpr off pa expr = if | Just (Refl :: a :~: b) <- eqT -> return expr - | DynVariable tvar sline name <- expr + | DynVariable stype sline name <- expr + , ExprTypeForall qvar itype <- stype + -> do + tvar <- newTypeVar + res <- unify off (ExprTypePrim (Proxy :: Proxy a)) $ renameVarInType qvar tvar itype + rtype <- M.lookup tvar <$> gets testTypeUnif + return $ ExposePrimType $ TypeApp res (fromMaybe (ExprTypeVar tvar) rtype) (Variable sline name) + + | DynVariable stype sline name <- expr -> do - _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar) + _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) stype return $ Variable sline name - | Just (Refl :: FunctionType a :~: b) <- eqT + | HidePrimType (_ :: Expr b') <- expr + -> unifyExpr off pa (ExposePrimType expr :: Expr b') + + | HideFunType args (_ :: Expr (FunctionType b')) <- expr + -> unifyExpr off pa (ExposeFunType args expr :: Expr (FunctionType b')) + + | TypeLambda tvar t f <- expr -> do - let FunctionArguments remaining = exprArgs expr - showType ( Nothing, SomeArgumentType atype ) = "`<" <> textExprType atype <> ">'" - showType ( Just (ArgumentKeyword kw), SomeArgumentType atype ) = "`" <> kw <> " <" <> textExprType atype <> ">'" - err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack - - defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case - arg@(_, SomeArgumentType RequiredArgument) -> err $ "missing " <> showType arg <> " argument" - (_, SomeArgumentType OptionalArgument) -> return Nothing - (kw, SomeArgumentType (ExprDefault def)) -> return $ Just ( kw, SomeExpr def ) - (kw, SomeArgumentType atype@ContextDefault) -> do - SomeExpr context <- gets testContext - context' <- unifyExpr off atype context - return $ Just ( kw, SomeExpr context' ) - return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) + _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) t + Just (ExprTypePrim pt) <- M.lookup tvar <$> gets testTypeUnif + unifyExpr off pa (f $ ExprTypePrim pt) + + | Just (Refl :: FunctionType a :~: b) <- eqT + -> evalRemainingArguments off (exprArgs expr) expr | Just (Refl :: DynamicType :~: b) <- eqT , Undefined msg <- expr @@ -157,7 +326,79 @@ unifyExpr off pa expr = if | otherwise -> do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'" + "couldn't match expected type ‘" <> textExprType pa <> "’ with actual type ‘" <> textExprType expr <> "’" + + +evalRemainingArguments :: ExprType a => Int -> FunctionArguments SomeArgumentType -> Expr (FunctionType a) -> TestParser (Expr a) +evalRemainingArguments off (FunctionArguments remaining) expr = do + let showType ( Nothing, SomeArgumentType _ stype ) = "‘<" <> textSomeExprType stype <> ">’" + showType ( Just (ArgumentKeyword kw), SomeArgumentType _ stype ) = "‘" <> kw <> " <" <> textSomeExprType stype <> ">’" + err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack + + defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case + arg@( _, SomeArgumentType RequiredArgument _ ) -> err $ "missing " <> showType arg <> " argument" + ( _, SomeArgumentType OptionalArgument _ ) -> return Nothing + ( kw, SomeArgumentType (ExprDefault def) _ ) -> return $ Just ( kw, def ) + ( kw, SomeArgumentType ContextDefault atype ) -> do + context <- unifySomeExpr off atype =<< gets testContext + return $ Just ( kw, context ) + sline <- getSourceLine + return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) + + +unifySomeExpr :: Int -> SomeExprType -> SomeExpr -> TestParser SomeExpr +unifySomeExpr off stype sexpr@(SomeExpr (expr :: Expr a)) + | ExprTypePrim pa <- stype + = SomeExpr <$> unifyExpr off pa expr + + | ExprTypeConstr1 {} <- stype + = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "unification with incomplete type" + + | ExprTypeVar tvar <- stype + = do + _ <- unify off (ExprTypeVar tvar) (someExprType sexpr) + return sexpr + + | Just (Refl :: a :~: DynamicType) <- eqT + , ExprTypeForall qvar itype <- someExprType sexpr + = do + tvar <- newTypeVar + itype' <- unify off stype $ renameVarInType qvar tvar itype + rtype <- M.lookup tvar <$> gets testTypeUnif + return $ SomeExpr (TypeApp itype' (fromMaybe (ExprTypeVar tvar) rtype) expr) + + | ExprTypeFunction args res <- stype + = case someExprType sexpr of + ExprTypeFunction args' res' -> do + _ <- unify off args args' + _ <- unify off res res' + return sexpr + _ -> do + _ <- unify off args (ExprTypeArguments mempty) + SomeExpr expr' <- unifySomeExpr off res sexpr + return $ SomeExpr $ FunctionAbstraction expr' + + | ExprTypeApp _ _ <- stype + , ExprTypeFunction args' res' <- someExprType sexpr + = do + ( _, ( remaining, _ ) ) <- case args' of + ExprTypeArguments args'' -> do + unifyArguments args'' mempty + _ -> do + _ <- unify off (ExprTypeArguments mempty) args' + return ( mempty, ( mempty, mempty ) ) + unify off stype res' >>= \case + ExprTypePrim (Proxy :: Proxy r) | Just (Refl :: a :~: FunctionType r) <- eqT -> + SomeExpr <$> evalRemainingArguments off remaining expr + _ | Just (Refl :: a :~: FunctionType DynamicType) <- eqT -> + SomeExpr <$> evalRemainingArguments off remaining expr + _ -> + error $ "expecting function type, got: " <> show (typeRep expr) + + | otherwise + = do + _ <- unify off stype (someExprType sexpr) + return sexpr skipLineComment :: TestParser () @@ -181,33 +422,37 @@ osymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy operatorChar) wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) -operatorChar = satisfy $ (`elem` ['.', '+', '-', '*', '/', '=']) +operatorChar = satisfy $ (`elem` [ '!', '%', '&', '*', '+', '-', '.', '/', ':', '<', '=', '>', '?', '@', '^', '|', '~' ]) {-# INLINE operatorChar #-} localState :: TestParser a -> TestParser a 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 - -block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c -block merge header item = L.indentBlock scn $ do - h <- header - choice - [ do symbol ":" - return $ L.IndentSome Nothing (merge h) item - , L.IndentNone <$> merge h [] - ] +toplevel :: (a -> b) -> TestParser a -> TestParser b +toplevel f = return . f <=< L.nonIndented scn listOf :: TestParser a -> TestParser [a] 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 +462,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..b2c6b84 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -1,17 +1,27 @@ module Parser.Expr ( identifier, + parseModuleName, varName, newVarName, - addVarName, + addVarName, addVarNameType, + constrName, + TermComplexity(..), someExpr, typedExpr, literal, variable, + constructor, + + someExpansion, expansionTypeCheck, + expressionExpansion, + stringExpansion, - checkFunctionArguments, functionArguments, + applyFunctionArguments, + + typeExpr, ) where import Control.Applicative (liftA2) @@ -33,18 +43,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 @@ -57,12 +83,22 @@ newVarName = do return name addVarName :: forall a. ExprType a => Int -> TypedVarName a -> TestParser () -addVarName off (TypedVarName name) = do +addVarName off tname = addVarNameType off tname (ExprTypePrim @a Proxy) + +addVarNameType :: forall a. ExprType a => Int -> TypedVarName a -> SomeExprType -> TestParser () +addVarNameType off (TypedVarName name) stype = do gets (lookup name . testVars) >>= \case Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.pack "variable '" <> textVarName name <> T.pack "' already exists" Nothing -> return () - modify $ \s -> s { testVars = ( name, ExprTypePrim @a Proxy ) : testVars s } + modify $ \s -> s { testVars = ( name, ( LocalVarName name, stype )) : testVars s } + +constrName :: TestParser VarName +constrName = label "contructor name" $ do + lexeme $ try $ do + lead <- upperChar + rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_') + return $ VarName $ TL.toStrict $ TL.fromChunks $ T.singleton lead : TL.toChunks rest someExpansion :: TestParser SomeExpr someExpansion = do @@ -71,20 +107,26 @@ someExpansion = do [do off <- stateOffset <$> getParserState sline <- getSourceLine name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') - lookupVarExpr off sline name - , between (char '{') (char '}') someExpr + lookupScalarVarExpr off sline name + , between (char '{') (char '}') (someExpr FunctionTerm) ] -stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a) -stringExpansion tname conv = do - off <- stateOffset <$> getParserState - SomeExpr e <- someExpansion +expansionTypeCheck :: forall a. ExprType a => Int -> Text -> SomeExpr -> TestParser (Expr a) +expansionTypeCheck off tname (SomeExpr e) = do let err = do registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ] return $ 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 ] + +expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a) +expressionExpansion tname = do + off <- stateOffset <$> getParserState + expansionTypeCheck off tname =<< someExpansion + +stringExpansion :: TestParser (Expr Text) +stringExpansion = expressionExpansion "string" numberLiteral :: TestParser SomeExpr numberLiteral = label "number" $ lexeme $ do @@ -96,6 +138,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 +161,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 @@ -124,7 +169,7 @@ quotedString = label "string" $ lexeme $ do regex :: TestParser (Expr Regex) regex = label "regular expression" $ lexeme $ do off <- stateOffset <$> getParserState - void $ char '/' + void $ try $ char '/' <* notFollowedBy (char '=') -- TODO: better parsing rules for regexes let inner = choice [ char '/' >> return [] , takeWhile1P Nothing (`notElem` ['/', '\\', '$']) >>= \s -> (Pure (RegexPart (TL.toStrict s)) :) <$> inner @@ -134,19 +179,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 () @@ -155,40 +195,51 @@ regex = label "regular expression" $ lexeme $ do list :: TestParser SomeExpr list = label "list" $ do symbol "[" - SomeExpr x <- someExpr - let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "list range enumeration not defined for '" <> textExprType x <> "'" - let exprList = foldr (liftA2 (:)) (Pure []) - SomeExpr <$> choice + choice [do symbol "]" - return $ exprList [x] - - ,do off <- stateOffset <$> getParserState - osymbol ".." - ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x - y <- typedExpr - symbol "]" - return $ fromTo <$> x <*> y - - ,do symbol "," - y <- typedExpr - - choice + tvar <- newTypeVar + return $ SomeExpr $ + TypeLambda tvar (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) $ + \case + (ExprTypePrim (Proxy :: Proxy a)) -> HidePrimType $ Pure ([] :: [ a ]) + _ -> Undefined "incomplete type" + + ,do SomeExpr x <- someExpr FunctionTerm + let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ + "list range enumeration not defined for ‘" <> textExprType x <> "’" + let exprList = foldr (liftA2 (:)) (Pure []) + + SomeExpr <$> choice [do symbol "]" - return $ exprList [x, y] + return $ exprList [ x ] ,do off <- stateOffset <$> getParserState osymbol ".." - ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x - z <- typedExpr + ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x + y <- typedExpr FunctionTerm symbol "]" - return $ fromThenTo <$> x <*> y <*> z + return $ fromTo <$> x <*> y ,do symbol "," - xs <- listOf typedExpr - symbol "]" - return $ exprList (x:y:xs) + y <- typedExpr FunctionTerm + + choice + [do symbol "]" + return $ exprList [ x, y ] + + ,do off <- stateOffset <$> getParserState + osymbol ".." + ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x + z <- typedExpr FunctionTerm + symbol "]" + return $ fromThenTo <$> x <*> y <*> z + + ,do symbol "," + xs <- listOf (typedExpr FunctionTerm) + symbol "]" + return $ exprList (x : y : xs) + ] ] ] @@ -211,17 +262,31 @@ applyBinOp off op x y = do y' <- unifyExpr off (Proxy @b) y return $ op <$> x' <*> y' -someExpr :: TestParser SomeExpr -someExpr = join inner <?> "expression" +data TermComplexity + = SimpleTerm -- variable name, literal or more complex term in parentheses + | FunctionTerm -- simple term or function call + +someExpr :: TermComplexity -> TestParser SomeExpr +someExpr complexity = label "expression" $ do + case complexity of + SimpleTerm -> join termSimple + FunctionTerm -> join inner where - inner = makeExprParser term table + inner = typeAnnotated $ makeExprParser termFunction table parens = between (symbol "(") (symbol ")") - term = label "term" $ choice + termSimple = label "term" $ choice [ parens inner , return <$> literal , return <$> variable + , return <$> constructor + ] + + termFunction = label "term" $ choice + [ parens inner + , return <$> literal + , return <$> functionCall ] table = [ [ prefix "-" $ [ SomeUnOp (negate @Integer) @@ -244,15 +309,30 @@ someExpr = join inner <?> "expression" , SomeBinOp ((-) @Scientific) ] ] + , [ let tvar = TypeVar "a" + targs = FunctionArguments $ M.fromList + [ ( Just "$l", ( VarName "$l", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) ) + , ( Just "$r", ( VarName "$r", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) ) + ] + in infixrExpr "++" $ SomeExpr $ TypeLambda tvar (ExprTypeFunction (ExprTypeArguments $ fmap snd targs) (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ])) $ \case + ExprTypePrim (Proxy :: Proxy a) -> + HideFunType (fmap snd targs) $ ArgsReq targs $ + FunctionAbstraction $ ((++) @a) + <$> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$l") + <*> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$r") + t -> Undefined ("ambiguous type ‘" <> T.unpack (textSomeExprType t) <> "’ for operator ‘++’") :: Expr DynamicType + ] , [ binary' "==" (\op xs ys -> length xs == length ys && and (zipWith op xs ys)) $ [ 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) @@ -285,6 +365,17 @@ someExpr = join inner <?> "expression" choice $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp off op e) ops + infixrExpr :: String -> SomeExpr -> Operator TestParser (TestParser SomeExpr) + infixrExpr name fun = InfixR $ do + void $ osymbol name + return $ \p q -> do + loff <- stateOffset <$> getParserState + l <- p + roff <- stateOffset <$> getParserState + r <- q + applyFunctionArguments (FunctionArguments $ M.fromList [ ( Just "$l", ( loff, l ) ), ( Just "$r", ( roff, r ) ) ]) fun + + binary :: String -> [SomeBinOp] -> Operator TestParser (TestParser SomeExpr) binary name = binary' name (undefined :: forall a b. (a -> b -> Void) -> [a] -> [b] -> Integer) -- use 'Void' that can never match actually used type to disable recursion @@ -325,15 +416,34 @@ someExpr = join inner <?> "expression" region (const err) $ foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops -typedExpr :: forall a. ExprType a => TestParser (Expr a) -typedExpr = do + typeAnnotated :: TestParser (TestParser SomeExpr) -> TestParser (TestParser SomeExpr) + typeAnnotated p = do + off <- stateOffset <$> getParserState + p' <- p + choice + [ do + -- colon starts a type annotation, except when at the end of line + void $ try $ (string ":" <* notFollowedBy operatorChar <* sc <* notFollowedBy eol) + stype <- typeExpr + return $ do + se <- p' + unifySomeExpr off stype se + + , do + return p' + ] + + +typedExpr :: forall a. ExprType a => TermComplexity -> TestParser (Expr a) +typedExpr complexity = do off <- stateOffset <$> getParserState - SomeExpr e <- someExpr + SomeExpr e <- someExpr complexity unifyExpr off Proxy e literal :: TestParser SomeExpr literal = label "literal" $ choice [ numberLiteral + , boolLiteral , SomeExpr <$> quotedString , SomeExpr <$> regex , list @@ -344,45 +454,37 @@ variable = label "variable" $ do off <- stateOffset <$> getParserState sline <- getSourceLine name <- varName - lookupVarExpr off sline name >>= \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 <- lookupVarExpr off sline name + 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' +constructor :: TestParser SomeExpr +constructor = label "constructor" $ do + off <- stateOffset <$> getParserState + sline <- getSourceLine + name <- constrName + lookupVarExpr off sline name + +functionCall :: TestParser SomeExpr +functionCall = do + sline <- getSourceLine + fun <- variable <|> constructor + args <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName) + applyFunctionArguments args fun +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 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 - case M.lookup kw argTypes of - Just (SomeArgumentType (_ :: ArgumentType expected)) -> do - withRecovery registerParseError $ do - void $ unify poff (ExprTypePrim (Proxy @expected)) (someExprType expr) - return expr - Nothing -> do - registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $ - case kw of - Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword `" <> tkw <> "'" - Nothing -> "unexpected parameter" - return expr - - functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b) functionArguments check param lit promote = do args <- parseArgs True @@ -399,22 +501,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 ] @@ -422,3 +512,65 @@ functionArguments check param lit promote = do pparam = between (symbol "(") (symbol ")") param <|> lit checkAndInsert off kw x cont = M.insert kw <$> check off kw x <*> cont + + +applyFunctionArguments :: FunctionArguments ( Int, SomeExpr ) -> SomeExpr -> TestParser SomeExpr +applyFunctionArguments (FunctionArguments margs) sexpr + | M.null margs = return sexpr +applyFunctionArguments args sexpr@(SomeExpr (expr :: Expr a)) + | Just (Refl :: a :~: DynamicType) <- eqT + , ExprTypeForall qvar itype <- someExprType sexpr + = do + tvar <- newTypeVar + case renameVarInType qvar tvar itype of + ExprTypeFunction (ExprTypeArguments args') res' -> do + ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args + unexpectedArguments unexpectedArgs + t <- fromMaybe (ExprTypeVar tvar) . M.lookup tvar <$> gets testTypeUnif + resolveKnownTypeVars res' >>= \case + ( res''@(ExprTypePrim (Proxy :: Proxy r)), _ ) -> + return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp res'' t expr) :: Expr (FunctionType r))) + ( r, _ ) -> + return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp r t expr) :: Expr (FunctionType DynamicType))) + _ -> do + unexpectedArguments args + return sexpr + + | otherwise + = case someExprType sexpr of + ExprTypeFunction (ExprTypeArguments args') res' -> do + ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args + unexpectedArguments unexpectedArgs + resolveKnownTypeVars res' >>= \case + ( ExprTypePrim (Proxy :: Proxy r), _ ) + | Just (Refl :: a :~: FunctionType r) <- eqT + -> return $ SomeExpr (ArgsApp used expr) + _ + | Just (Refl :: a :~: FunctionType DynamicType) <- eqT + -> return $ SomeExpr (ArgsApp used expr) + _ -> + error $ "expecting function type, got: " <> show (typeRep expr) + _ -> do + unexpectedArguments args + return sexpr + where + unexpectedArguments (FunctionArguments amap) = do + forM_ (M.toAscList amap) $ \( kw, ( poff, _ ) ) -> + registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $ + case kw of + Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’" + Nothing -> "unexpected parameter" + + +typeExpr :: TestParser SomeExprType +typeExpr = do + off <- stateOffset <$> getParserState + choice + [ do + name <- constrName <?> "type constructor name" + lookupType off name + , do + between (symbol "[") (symbol "]") $ do + inner <- typeExpr + return $ ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ inner ] + ] diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs new file mode 100644 index 0000000..2d6026a --- /dev/null +++ b/src/Parser/Shell.hs @@ -0,0 +1,170 @@ +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 + +parseTextArgument :: TestParser (Expr Text) +parseTextArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice + [ doubleQuotedString + , singleQuotedString + , standaloneEscapedChar + , stringExpansion + , unquotedString + ] + where + specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']'{-, '{', '}' -}, '(', ')'{-, '*', '?', '~', '&', '!' -} ] + + stringSpecialChars = [ '"', '\\', '$' ] + + unquotedString :: TestParser (Expr Text) + unquotedString = do + Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars) + + doubleQuotedString :: TestParser (Expr Text) + doubleQuotedString = do + void $ char '"' + let inner = choice + [ char '"' >> return [] + , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` stringSpecialChars)) <*> inner + , (:) <$> stringEscapedChar <*> inner + , (:) <$> stringExpansion <*> inner + ] + App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner + + singleQuotedString :: TestParser (Expr Text) + singleQuotedString = do + Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'') + + stringEscapedChar :: TestParser (Expr Text) + stringEscapedChar = do + void $ char '\\' + fmap Pure $ choice $ + map (\c -> char c >> return (T.singleton c)) stringSpecialChars ++ + [ char 'n' >> return "\n" + , char 'r' >> return "\r" + , char 't' >> return "\t" + , return "\\" + ] + + standaloneEscapedChar :: TestParser (Expr Text) + standaloneEscapedChar = do + void $ char '\\' + fmap T.singleton . Pure <$> printChar + +parseRedirection :: TestParser (Expr ShellArgument) +parseRedirection = choice + [ do + rsymbol "<" + fmap ShellRedirectStdin <$> parseTextArgument + , do + rsymbol ">" + fmap (ShellRedirectStdout False) <$> parseTextArgument + , do + rsymbol ">>" + fmap (ShellRedirectStdout True) <$> parseTextArgument + , do + rsymbol "2>" + fmap (ShellRedirectStderr False) <$> parseTextArgument + , do + rsymbol "2>>" + fmap (ShellRedirectStderr True) <$> parseTextArgument + ] + where + rsymbol str = void $ try $ (string str <* notFollowedBy (satisfy $ (`elem` [ '<', '>', '|' ]))) <* sc + +parseArgument :: TestParser (Expr ShellArgument) +parseArgument = choice + [ parseRedirection + , expressionExpansion "shell argument" <* sc + , fmap ShellArgument <$> parseTextArgument + ] + +parseArguments :: TestParser (Expr ShellArguments) +parseArguments = do + arglists <- many $ choice + [ do + off <- stateOffset <$> getParserState + se <- someExpansion + choice + [ do + notFollowedBy space1 + arg <- expansionTypeCheck off "shell argument" se + txt <- parseTextArgument + return $ joinArgument <$> arg <*> txt + , do + expansionTypeCheck off "shell arguments" se <* sc + ] + , fmap (ShellArguments . (: [])) <$> parseArgument + ] + return $ fmap mconcat $ foldr (liftA2 (:)) (Pure []) $ arglists + where + joinArgument (ShellArgument x) y = ShellArguments [ ShellArgument (x <> y) ] + joinArgument ax y = ShellArguments [ ax, ShellArgument y ] + +parseCommand :: TestParser (Expr ShellCommand) +parseCommand = label "shell statement" $ do + line <- getSourceLine + choice + [ do + args <- expressionExpansion "shell command" <* sc + args' <- parseArguments + return $ commandFromArgLists line <$> args <*> args' + , do + command <- parseTextArgument + args <- parseArguments + return $ ShellCommand + <$> command + <*> args + <*> pure line + ] + + where + commandFromArgLists line (ShellArguments (ShellArgument cmd : args)) (ShellArguments args') = + ShellCommand cmd (ShellArguments (args ++ args')) line + commandFromArgLists line (ShellArguments args) (ShellArguments args') = + ShellCommand "" (ShellArguments (args ++ args')) line + +parsePipeline :: Maybe (Expr ShellPipeline) -> TestParser (Expr ShellPipeline) +parsePipeline mbupper = do + cmd <- parseCommand + let pipeline = + case mbupper of + Nothing -> fmap (\ecmd -> ShellPipeline ecmd Nothing) cmd + Just upper -> liftA2 (\ecmd eupper -> ShellPipeline ecmd (Just eupper)) cmd upper + choice + [ do + psymbol "|" + parsePipeline (Just pipeline) + + , do + return pipeline + ] + where + psymbol str = void $ try $ (string str <* notFollowedBy (satisfy $ (`elem` [ '<', '>', '|', '&' ]))) <* sc + +parseStatement :: TestParser (Expr [ ShellStatement ]) +parseStatement = do + line <- getSourceLine + fmap ((: []) . flip ShellStatement line) <$> parsePipeline Nothing + +shellScript :: TestParser (Expr ShellScript) +shellScript = do + indent <- L.indentLevel + fmap ShellScript <$> blockOf indent parseStatement diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index c7cdf5a..1c1b805 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 @@ -31,18 +37,17 @@ letStatement = do off <- stateOffset <$> getParserState name <- varName osymbol "=" - SomeExpr e <- someExpr + se@(SomeExpr e) <- someExpr FunctionTerm localState $ do let tname = TypedVarName name - addVarName off tname + addVarNameType off tname (someExprType se) void $ eol body <- testBlock indent - return [Let line tname e body] + return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body) -forStatement :: TestParser [TestStep] +forStatement :: TestParser (Expr (TestBlock ())) forStatement = do - line <- getSourceLine ref <- L.indentLevel wsymbol "for" voff <- stateOffset <$> getParserState @@ -50,7 +55,8 @@ forStatement = do wsymbol "in" loff <- stateOffset <$> getParserState - SomeExpr e <- someExpr + tvar <- newTypeVar + SomeExpr e <- unifySomeExpr loff (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) =<< someExpr FunctionTerm let err = parseError $ FancyError loff $ S.singleton $ ErrorFail $ T.unpack $ "expected a list, expression has type '" <> textExprType e <> "'" ExprListUnpacker unpack _ <- maybe err return $ exprListUnpacker e @@ -62,36 +68,80 @@ 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 SimpleTerm + parseParams ref mbpname (Just node) -exprStatement :: TestParser [ TestStep ] + , do + off <- stateOffset <$> getParserState + symbol ":" + node <- case mbnode of + Just node -> return node + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "missing parameter with keyword ‘on’" + return $ Undefined "" + + void eol + void $ L.indentGuard scn GT ref + script <- shellScript + cont <- fmap Scope <$> testBlock ref + let expr | Just pname <- mbpname = LambdaAbstraction pname cont + | otherwise = const <$> cont + return $ TestBlockStep EmptyTestBlock <$> + (SpawnShell mbpname <$> node <*> script <*> expr) + ] + +exprStatement :: TestParser (Expr (TestBlock ())) exprStatement = do ref <- L.indentLevel off <- stateOffset <$> getParserState - SomeExpr expr <- someExpr + SomeExpr expr <- someExpr FunctionTerm choice - [ 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 coff <- stateOffset <$> getParserState sline <- getSourceLine - args <- functionArguments (checkFunctionArguments (exprArgs fun)) someExpr literal (\poff -> lookupVarExpr poff sline . VarName) - let fun' = ArgsApp args fun + args <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName) + SomeExpr fun' <- applyFunctionArguments args (SomeExpr 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,37 +154,53 @@ 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>" +instance ParamType CallStack where + type ParamRep CallStack = Expr CallStack + parseParam _ = mzero + showParamType _ = "<call stack>" + paramExpr = id + instance ExprType a => ParamType (TypedVarName a) where parseParam _ = newVarName showParamType _ = "<variable>" - -instance ExprType a => ParamType (Expr a) where - parseParam _ = do - off <- stateOffset <$> getParserState - SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr - unifyExpr off Proxy e - showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" + paramNewVariables _ var = SomeNewVariables [ var ] + paramNewVariablesEmpty _ = SomeNewVariables @a [] instance ParamType a => ParamType [a] where type ParamRep [a] = [ParamRep a] 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,109 @@ 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 @(ExprParam a)) + showParamType _ = showParamType (Proxy @(ExprParam 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 +callStack :: CommandDef CallStack +callStack = param "" -instance ParamType InnerBlock where - type ParamRep InnerBlock = [TestStep] +newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } + +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 ])) <$> innerBlockFunList + +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 <- someExpr SimpleTerm + 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 +323,28 @@ 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 + | Just (Refl :: p :~: CallStack) <- eqT -> return $ SomeParam p $ Identity $ Variable line callStackFqVarName + + | SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables + , Just (Refl :: p :~: InnerBlock a) <- eqT + -> SomeParam p . Identity . ( vars, ) <$> restOfParts cmdi partials + + | Just (Refl :: p :~: InnerBlock Void) <- eqT + -> SomeParam p . Identity . ( [], ) <$> 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 +354,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 +380,7 @@ command name (CommandDef types ctor) = do ] tryParams _ _ _ _ [] = mzero -testLocal :: TestParser [TestStep] +testLocal :: TestParser (Expr (TestBlock ())) testLocal = do ref <- L.indentLevel wsymbol "local" @@ -266,15 +388,16 @@ 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" off <- stateOffset <$> getParserState - ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr + ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr SimpleTerm let expected = [ ExprTypePrim @Network Proxy , ExprTypePrim @Node Proxy @@ -292,75 +415,68 @@ 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") + <*> (maybe Nothing (Just . fromExprParam) <$> param "killwith") + <*> innerBlockFun -testExpect :: TestParser [TestStep] +testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect - <$> cmdLine - <*> paramOrContext "from" + <$> callStack + <*> cmdLine + <*> (fromExprParam <$> paramOrContext "from") <*> param "" + <*> (maybe 1 fromExprParam <$> param "timeout") <*> 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..1c2dbe5 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -1,13 +1,19 @@ module Process ( Process(..), - ProcName(..), - textProcName, unpackProcName, + ProcessId(..), textProcId, + ProcName(..), textProcName, unpackProcName, + Signal, send, - outProc, + outProc, outProcName, lineReadingLoop, + startProcessIOLoops, spawnOn, closeProcess, + closeTestProcess, withProcess, + + IgnoreProcessOutput(..), + flushProcessOutput, ) where import Control.Arrow @@ -18,49 +24,67 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Function +import Data.List +import Data.Maybe +import Data.Scientific import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Data.Text qualified as T +import Data.Text.IO qualified as T +import System.Directory +import System.Environment import System.Exit +import System.FilePath import System.IO import System.IO.Error -import System.Posix.Signals +import System.Posix.Process import System.Process import {-# SOURCE #-} GDB import Network import Network.Ip import Output +import Process.Signal import Run.Monad -import Test +import Script.Expr +import Script.Expr.Class +import Script.Object data Process = Process - { procName :: ProcName - , procHandle :: ProcessHandle + { procId :: ProcessId + , procName :: ProcName + , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode ) , procStdin :: Handle - , procOutput :: TVar [Text] + , procOutput :: TVar [ Text ] + , procIgnore :: TVar ( Int, [ ( Int, Maybe Regex ) ] ) , procKillWith :: Maybe Signal , procNode :: Node + , procPid :: Maybe Pid } instance Eq Process where (==) = (==) `on` procStdin instance ExprType Process where - textExprType _ = T.pack "proc" - textExprValue n = T.pack "p:" <> textProcName (procName n) + textExprType _ = T.pack "Process" + textExprValue p = "<process:" <> textProcName (procName p) <> "#" <> textProcId (procId p) <> ">" recordMembers = map (first T.pack) - [ ("node", RecordSelector $ procNode) + [ ( "node", RecordSelector $ procNode ) + , ( "pid", RecordSelector $ maybe (0 :: Integer) fromIntegral . procPid ) ] +newtype ProcessId = ProcessId Int + data ProcName = ProcName Text | ProcNameTcpdump | ProcNameGDB deriving (Eq, Ord) +textProcId :: ProcessId -> Text +textProcId (ProcessId pid) = T.pack (show pid) + textProcName :: ProcName -> Text textProcName (ProcName name) = name textProcName ProcNameTcpdump = T.pack "tcpdump" @@ -75,69 +99,129 @@ send p line = liftIO $ do hFlush (procStdin p) outProc :: MonadOutput m => OutputType -> Process -> Text -> m () -outProc otype p line = outLine otype (Just $ textProcName $ procName p) line +outProc otype p line = outProcName otype (procName p) line + +outProcName :: MonadOutput m => OutputType -> ProcName -> Text -> m () +outProcName otype pname line = outLine otype (Just $ textProcName pname) line lineReadingLoop :: MonadOutput m => Process -> Handle -> (Text -> m ()) -> m () lineReadingLoop process h act = liftIO (tryIOError (T.hGetLine h)) >>= \case - Left err - | isEOFError err -> return () - | otherwise -> outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err + Left err -> do + when (not (isEOFError err)) $ do + outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err + liftIO $ hClose h Right line -> do act line lineReadingLoop process h act +startProcessIOLoops :: Process -> Handle -> Handle -> TestRun () +startProcessIOLoops process@Process {..} hout herr = do + + void $ forkTest $ lineReadingLoop process hout $ \line -> do + outProc OutputChildStdout process line + ignored <- liftIO $ atomically $ do + ignores <- map snd . snd <$> readTVar procIgnore + let ignored = any (matches line) ignores + when (not ignored) $ do + modifyTVar procOutput (++ [ line ]) + return ignored + when ignored $ do + outProc OutputIgnored process line + + void $ forkTest $ lineReadingLoop process herr $ \line -> do + case procName of + ProcNameTcpdump -> return () + _ -> outProc OutputChildStderr process line + + where + matches _ Nothing + = True + matches line (Just re) + | Right (Just _) <- regexMatch re line = True + | otherwise = False + spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process -spawnOn target pname killWith cmd = do +spawnOn target procName procKillWith cmd = do + -- When executing command given with relative path, turn it to absolute one, + -- because working directory will be changed for the 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 + + procId <- case procName of + ProcNameTcpdump -> return $ ProcessId (-1) + _ -> do + idVar <- asks $ teNextProcId . fst + liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x )) + let netns = either getNetns getNetns target - let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" " - (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)] - } - pout <- liftIO $ newTVarIO [] - - let process = Process - { procName = pname - , procHandle = handle - , procStdin = hin - , procOutput = pout - , procKillWith = killWith - , procNode = either (const undefined) id target + currentEnv <- liftIO $ getEnvironment + (Just procStdin, Just hout, Just herr, handle) <- liftIO $ do + runInNetworkNamespace netns $ createProcess (shell cmd') + { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe + , cwd = Just (either netDir nodeDir target) + , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv } + let procHandle = Left handle + procOutput <- liftIO $ newTVarIO [] + procIgnore <- liftIO $ newTVarIO ( 0, [] ) + let procNode = either (const undefined) id target + procPid <- liftIO $ getPid handle + let process = Process {..} - forkTest $ lineReadingLoop process hout $ \line -> do - outProc OutputChildStdout process line - liftIO $ atomically $ modifyTVar pout (++[line]) - forkTest $ lineReadingLoop process herr $ \line -> do - case pname of - ProcNameTcpdump -> return () - _ -> outProc OutputChildStderr process line + startProcessIOLoops process hout herr asks (teGDB . fst) >>= maybe (return Nothing) (liftIO . tryReadMVar) >>= \case - Just gdb | ProcName _ <- pname -> addInferior gdb process + Just gdb | ProcName _ <- procName -> addInferior gdb process _ -> return () return process -closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m () -closeProcess p = do +closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Scientific -> Process -> m () +closeProcess timeout p = do liftIO $ hClose $ procStdin p case procKillWith p of Nothing -> return () - Just sig -> liftIO $ getPid (procHandle p) >>= \case + Just sig -> case procPid p of Nothing -> return () Just pid -> signalProcess sig pid liftIO $ void $ forkIO $ do - threadDelay 1000000 - terminateProcess $ procHandle p - liftIO (waitForProcess (procHandle p)) >>= \case - ExitSuccess -> return () - ExitFailure code -> do - outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code + threadDelay $ floor $ 1000000 * timeout + either terminateProcess (killThread . fst) $ procHandle p + + status <- case procPid p of + Nothing -> Just . Exited <$> liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) + Just pid -> liftIO (getProcessStatus True False pid) + case status of + Just (Exited ExitSuccess) -> do + return () + Just (Exited (ExitFailure code)) -> do + outProc OutputChildFail p $ "exit code: " <> T.pack (show code) + throwError Failed + Just (Terminated sig _) + | Just (Signal sig) == procKillWith p -> return () + | otherwise -> do + outProc OutputChildFail p $ "killed with signal " <> T.pack (show sig) + throwError Failed + Just (Stopped sig) -> do + outProc OutputChildFail p $ "stopped with signal " <> T.pack (show sig) + throwError Failed + Nothing -> do + outProc OutputChildFail p $ "no exit status" throwError Failed +closeTestProcess :: Process -> TestRun () +closeTestProcess process = do + timeout <- getCurrentTimeout + closeProcess timeout process + withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a withProcess target pname killWith cmd inner = do procVar <- asks $ teProcesses . fst @@ -147,5 +231,36 @@ withProcess target pname killWith cmd inner = do inner process `finally` do ps <- liftIO $ takeMVar procVar - closeProcess process `finally` do + closeTestProcess process `finally` do liftIO $ putMVar procVar $ filter (/=process) ps + + +data IgnoreProcessOutput = IgnoreProcessOutput Process Int + +instance ObjectType TestRun IgnoreProcessOutput where + type ConstructorArgs IgnoreProcessOutput = ( Process, Maybe Regex ) + + textObjectType _ _ = "IgnoreProcessOutput" + textObjectValue _ (IgnoreProcessOutput _ _) = "<IgnoreProcessOutput>" + + createObject oid ( process@Process {..}, regex ) = do + ( obj, flushed ) <- liftIO $ atomically $ do + flushed <- flushProcessOutput process regex + ( iid, list ) <- readTVar procIgnore + writeTVar procIgnore ( iid + 1, ( iid, regex ) : list ) + return ( Object oid $ IgnoreProcessOutput process iid, flushed ) + mapM_ (outProc OutputIgnored process) flushed + return obj + + destroyObject Object { objImpl = IgnoreProcessOutput Process {..} iid } = do + liftIO $ atomically $ do + writeTVar procIgnore . fmap (filter ((iid /=) . fst)) =<< readTVar procIgnore + +flushProcessOutput :: Process -> Maybe Regex -> STM [ Text ] +flushProcessOutput p mbre = do + current <- readTVar (procOutput p) + let ( ignore, keep ) = case mbre of + Nothing -> ( current, [] ) + Just re -> partition (either error isJust . regexMatch re) current + writeTVar (procOutput p) keep + return ignore diff --git a/src/Process/Signal.hs b/src/Process/Signal.hs new file mode 100644 index 0000000..e57b68d --- /dev/null +++ b/src/Process/Signal.hs @@ -0,0 +1,88 @@ +module Process.Signal ( + Signal(..), + signalBuiltins, + signalProcess, +) where + +import Control.Monad.IO.Class + +import Data.Text (Text) +import Data.Text qualified as T + +import Script.Expr + +import System.Posix qualified as Posix + + +newtype Signal = Signal Posix.Signal + deriving (Eq, Ord) + +instance ExprType Signal where + textExprType _ = "Signal" + textExprValue (Signal sig) + | sig == Posix.sigHUP = "SIGHUP" + | sig == Posix.sigINT = "SIGINT" + | sig == Posix.sigQUIT = "SIGQUIT" + | sig == Posix.sigILL = "SIGILL" + | sig == Posix.sigTRAP = "SIGTRAP" + | sig == Posix.sigABRT = "SIGABRT" + | sig == Posix.sigBUS = "SIGBUS" + | sig == Posix.sigFPE = "SIGFPE" + | sig == Posix.sigKILL = "SIGKILL" + | sig == Posix.sigUSR1 = "SIGUSR1" + | sig == Posix.sigSEGV = "SIGSEGV" + | sig == Posix.sigUSR2 = "SIGUSR2" + | sig == Posix.sigPIPE = "SIGPIPE" + | sig == Posix.sigALRM = "SIGALRM" + | sig == Posix.sigTERM = "SIGTERM" + | sig == Posix.sigCHLD = "SIGCHLD" + | sig == Posix.sigCONT = "SIGCONT" + | sig == Posix.sigSTOP = "SIGSTOP" + | sig == Posix.sigTSTP = "SIGTSTP" + | sig == Posix.sigTTIN = "SIGTTIN" + | sig == Posix.sigTTOU = "SIGTTOU" + | sig == Posix.sigURG = "SIGURG" + | sig == Posix.sigXCPU = "SIGXCPU" + | sig == Posix.sigXFSZ = "SIGXFSZ" + | sig == Posix.sigVTALRM = "SIGVTALRM" + | sig == Posix.sigPROF = "SIGPROF" + | sig == Posix.sigPOLL = "SIGPOLL" + | sig == Posix.sigSYS = "SIGSYS" + | otherwise = "<SIG_" <> T.pack (show sig) <> ">" + + +signalBuiltins :: [ ( Text, SomeExpr ) ] +signalBuiltins = map (fmap $ SomeExpr . Pure) + [ ( "SIGHUP", Signal Posix.sigHUP ) + , ( "SIGINT", Signal Posix.sigINT ) + , ( "SIGQUIT", Signal Posix.sigQUIT ) + , ( "SIGILL", Signal Posix.sigILL ) + , ( "SIGTRAP", Signal Posix.sigTRAP ) + , ( "SIGABRT", Signal Posix.sigABRT ) + , ( "SIGBUS", Signal Posix.sigBUS ) + , ( "SIGFPE", Signal Posix.sigFPE ) + , ( "SIGKILL", Signal Posix.sigKILL ) + , ( "SIGUSR1", Signal Posix.sigUSR1 ) + , ( "SIGSEGV", Signal Posix.sigSEGV ) + , ( "SIGUSR2", Signal Posix.sigUSR2 ) + , ( "SIGPIPE", Signal Posix.sigPIPE ) + , ( "SIGALRM", Signal Posix.sigALRM ) + , ( "SIGTERM", Signal Posix.sigTERM ) + , ( "SIGCHLD", Signal Posix.sigCHLD ) + , ( "SIGCONT", Signal Posix.sigCONT ) + , ( "SIGSTOP", Signal Posix.sigSTOP ) + , ( "SIGTSTP", Signal Posix.sigTSTP ) + , ( "SIGTTIN", Signal Posix.sigTTIN ) + , ( "SIGTTOU", Signal Posix.sigTTOU ) + , ( "SIGURG", Signal Posix.sigURG ) + , ( "SIGXCPU", Signal Posix.sigXCPU ) + , ( "SIGXFSZ", Signal Posix.sigXFSZ ) + , ( "SIGVTALRM", Signal Posix.sigVTALRM ) + , ( "SIGPROF", Signal Posix.sigPROF ) + , ( "SIGPOLL", Signal Posix.sigPOLL ) + , ( "SIGSYS", Signal Posix.sigSYS ) + ] + + +signalProcess :: MonadIO m => Signal -> Posix.ProcessID -> m () +signalProcess (Signal sig) pid = liftIO $ Posix.signalProcess sig pid @@ -1,41 +1,119 @@ module Run ( module Run.Monad, + Report(..), SingleTestReport(..), + TestName, textTestName, + runTests, runTest, + + LoadedModules(..), + loadModules', + evalGlobalDefs, + + TestFilter(..), + testFilterFromConfig, + filterTests, ) where import Control.Applicative +import Control.Arrow import Control.Concurrent import Control.Concurrent.STM import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Control.Monad.Writer +import Data.Char +import Data.Either +import Data.List 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 Data.Typeable import System.Directory +import System.FilePath import System.Exit import System.IO.Error import System.Posix.Process import System.Posix.Signals import System.Process +import Config import GDB import Network import Network.Ip import Output +import Parser import Process +import Process.Signal import Run.Monad +import Sandbox +import Script.Expr +import Script.Module +import Script.Object +import Script.Shell import Test import Test.Builtins -runTest :: Output -> TestOptions -> Test -> IO Bool -runTest out opts test = do - let testDir = optTestDir opts + +data Report = Report + { reportTotalCount :: Int + , reportPassedCount :: Int + , reportSkippedCount :: Int + , reportFailedCount :: Int + , reportFailedList :: [ TestName ] + , reportTotalTime :: Scientific + , reportTests :: [ SingleTestReport ] + } + +data SingleTestReport = SingleTestReport + { reportTestName :: TestName + , reportTestFailed :: Maybe Failed + , reportTime :: Scientific + , reportOutput :: Text + , reportOutputError :: Text + } + +runTests :: Output -> TestOptions -> GlobalDefs -> [ Test ] -> IO Report +runTests out opts gdefs tests = do + go $ concat $ replicate (optRepeat opts) tests + where + go (t : ts) = do + single <- runTest out opts gdefs t + let failed = isJust (reportTestFailed single) + r <- if + | failed && not (optKeepGoing opts) + -> go [] + | otherwise + -> go ts + return Report + { reportTotalCount = 1 + reportTotalCount r + , reportPassedCount = (if failed then 0 else 1) + reportPassedCount r + , reportSkippedCount = reportSkippedCount r + , reportFailedCount = (if failed then 1 else 0) + reportFailedCount r + , reportFailedList = (if failed then (reportTestName single :) else id) $ reportFailedList r + , reportTotalTime = reportTime single + reportTotalTime r + , reportTests = single : reportTests r + } + go [] = return Report + { reportTotalCount = 0 + , reportPassedCount = 0 + , reportSkippedCount = 0 + , reportFailedCount = 0 + , reportFailedList = [] + , reportTotalTime = 0 + , reportTests = [] + } + + +runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO SingleTestReport +runTest out opts gdefs test = do + let testDir = optTestDir opts </> T.unpack (textTestName $ testName test) when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e -> if isDoesNotExistError e then return () else ioError e exists <- doesPathExist testDir @@ -43,7 +121,10 @@ runTest out opts test = do createDirectoryIfMissing True testDir failedVar <- newTVarIO Nothing + objIdVar <- newMVar 1 + procIdVar <- newMVar 1 procVar <- newMVar [] + timeoutVar <- newMVar ( optTimeout opts, 0 ) mgdb <- if optGDB opts then flip runReaderT out $ do @@ -55,21 +136,26 @@ runTest out opts test = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teTestDir = testDir + , teNextObjId = objIdVar + , teNextProcId = procIdVar , teProcesses = procVar + , teTimeout = timeoutVar , teGDB = fst <$> mgdb } tstate = TestState - { tsNetwork = error "network not initialized" - , tsVars = builtins + { tsGlobals = gdefs + , tsLocals = [ ( callStackVarName, SomeExpr $ Pure $ CallStack [] ) ] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty } - let sigHandler SignalInfo { siginfoSpecific = chld } = do + let sigHandler SignalInfo { siginfoSpecific = NoSignalSpecificInfo } = return () + sigHandler SignalInfo { siginfoSpecific = chld } = do processes <- readMVar procVar forM_ processes $ \p -> do - mbpid <- 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,120 +169,235 @@ 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 - withInternet $ \_ -> do - evalSteps (testSteps test) - when (optWait opts) $ do - void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + flip runReaderT out $ do + void $ outLine OutputGlobalInfo Nothing $ "Starting test ‘" <> textTestName (testName test) <> "’" + + resetOutputTime out + testRunResult <- newEmptyMVar + + void $ forkOS $ do + isolateFilesystem testDir >>= \case + True -> do + tres <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do + withInternet $ \_ -> do + runStep =<< eval (testSteps test) + when (optWait opts) $ do + void $ outPromptGetLine $ "Test ‘" <> textTestName (testName test) <> "’ completed, waiting..." + putMVar testRunResult tres + _ -> do + putMVar testRunResult ( Left Failed, [] ) + + ( res, [] ) <- takeMVar testRunResult + reportTime <- getElapsedTime out + reportOutput <- collectOutput out + reportOutputError <- collectErrorOutput out 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) - case (res, failed) of - (Right (), Nothing) -> do + reportTestFailed <- case ( res, failed ) of + ( 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 + return Nothing + _ -> do + flip runReaderT out $ do + void $ outLine OutputGlobalError Nothing $ "Test ‘" <> textTestName (testName test) <> "’ failed." + return $ either Just (const Nothing) res `mplus` failed + + (optHookTestResult opts) (testName test) (isNothing reportTestFailed) + let reportTestName = testName test + return SingleTestReport {..} + + +data LoadedModules = LoadedModules + { lmModules :: [ Module ] + , lmTags :: [ ( TestName, [ Tag ] ) ] + , lmGlobalDefs :: GlobalDefs + } + +loadModules' :: [ SomePrimType ] -> [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules) +loadModules' builtinTypes files = do + parseTestFiles builtinTypes (map fst files) >>= \case + Right ( modules, allModules ) -> return $ do + lmModules <- forM (zip files modules) $ \( ( path, tsel ), m ) -> do + tests <- case tsel of + Nothing -> return $ moduleTests m + Just tname + | Just test <- find ((tname ==) . testNameBase . testName) (moduleTests m) + -> return [ test ] + | otherwise + -> throwError $ TestNotFound tname (Just path) + return m { moduleTests = tests } + + let lmGlobalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules + evalTags test = map (\e -> runSimpleEval (eval e) lmGlobalDefs []) $ testTags test + lmTags = concatMap (\Module {..} -> map (\test -> ( testName test, evalTags test )) moduleTests) lmModules + Right $ LoadedModules {..} + Left err -> do + return $ Left err + + +evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs +evalGlobalDefs exprs = builtins `M.union` M.fromList exprs + + +data TestFilter = TestFilter + { tfSelect :: Maybe [ Text ] + , tfExclude :: [ Text ] + } + +instance Semigroup TestFilter where + a <> b + | isJust (tfSelect b) = b + | otherwise = a { tfExclude = tfExclude a <> tfExclude b } + +instance Monoid TestFilter where + mempty = TestFilter Nothing [] + +testFilterFromConfig :: Config -> TestFilter +testFilterFromConfig Config {..} = TestFilter + { tfSelect = configSelect + , tfExclude = configExclude + } + +filterTests :: TestFilter -> LoadedModules -> Either CustomTestError [ Test ] +filterTests TestFilter {..} LoadedModules {..} = do + let allTests = concatMap moduleTests lmModules + let evalTerm :: Text -> Either CustomTestError (Either TestName (Either Tag ModuleName)) + evalTerm term = + case (init &&& last) $ T.splitOn "." term of + ( [], name ) | maybe False (isUpper . fst) (T.uncons name) -> + case find ((VarName name ==) . snd . fst) $ M.toList lmGlobalDefs of + Just ( _, SomeExpr (expr :: Expr etype) ) + | Just (Refl :: etype :~: Tag) <- eqT + -> return $ Right $ Left $ runSimpleEval (eval expr) lmGlobalDefs [] + Nothing + | Just t <- find ((name ==) . testNameBase . testName) allTests + -> return $ Left $ testName t + Nothing + | mname <- ModuleName [ name ] + , Just _ <- find ((mname ==) . moduleName) lmModules + -> return $ Right $ Right mname + _ -> + throwError $ TestOrTagNotFound term Nothing + ( ms, name ) | maybe False (isUpper . fst) (T.uncons name) -> + case find ((( ModuleName ms, VarName name ) ==) . fst) $ M.toList lmGlobalDefs of + Just ( _, SomeExpr (expr :: Expr etype) ) + | Just (Refl :: etype :~: Tag) <- eqT + -> return $ Right $ Left $ runSimpleEval (eval expr) lmGlobalDefs [] + Nothing + | Just t <- find ((TestName (ModuleName ms) name ==) . testName) allTests + -> return $ Left $ testName t + Nothing + | mname <- ModuleName $ ms ++ [ name ] + , Just _ <- find ((mname ==) . moduleName) lmModules + -> return $ Right $ Right mname + _ -> + throwError $ TestOrTagNotFound term Nothing + ( ms, name ) | mname <- ModuleName $ ms ++ [ name ] -> + case find ((mname ==) . moduleName) lmModules of + Just _ -> return $ Right $ Right mname + _ -> throwError $ ModuleNotFound mname + + exclude <- fmap partitionEithers . partitionEithers <$> mapM evalTerm tfExclude + let matches ( tnames, ( tags, modules ) ) test = + testName test `elem` tnames + || maybe False (any (`elem` tags)) (lookup (testName test) lmTags) + || testNameModule (testName test) `elem` modules + filter (not . matches exclude) <$> case tfSelect of + Nothing -> return allTests + Just tnames -> do + selected <- fmap partitionEithers . partitionEithers <$> mapM evalTerm tnames + return $ filter (matches selected) allTests + + +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 killWith 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) - - Send pname expr -> do - p <- eval pname - line <- eval expr + cmd = T.unwords $ T.pack tool : map escape args + escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" + outProcName OutputChildExec pname cmd + withProcess (Right node) pname killWith (T.unpack cmd) $ runStep . inner + + SpawnShell mbname node script inner -> do + let tname | Just (TypedVarName (VarName name)) <- mbname = name + | otherwise = "shell" + let pname = ProcName tname + withShellProcess node pname script $ 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 stack line p expr timeout captures inner -> do + expect stack line p expr timeout captures $ runStep . inner - Flush pname expr -> do - p <- eval pname - flush p expr + Flush p regex -> do + mapM_ (outProc OutputIgnored p) =<< + atomicallyTest (flushProcessOutput p regex) - Guard line expr -> do - testStepGuard line expr + Guard stack expr -> do + testStepGuard stack 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 + testDir <- asks $ teTestDir . fst inet <- newInternet testDir - res <- withNetwork (inetRoot inet) $ \net -> do - local (fmap $ \s -> s { tsNetwork = net }) $ inner net - delInternet inet - return res + flip finally (delInternet inet) $ do + withNetwork (inetRoot inet) $ \net -> do + withTypedVar rootNetworkVar net $ do + inner net withSubnet :: Network -> Maybe (TypedVarName Network) -> (Network -> TestRun a) -> TestRun a withSubnet parent tvname inner = do @@ -205,16 +406,15 @@ withSubnet parent tvname inner = do withNetwork :: Network -> (Network -> TestRun a) -> TestRun a withNetwork net inner = do - tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case - Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination) - (path ++ " -i br0 -w '" ++ netDir net ++ "/br0.pcap' -U -Z root") . const + tcpdump <- asks (optTcpdump . teOptions . fst) >>= return . \case + Just path -> withProcess (Left net) ProcNameTcpdump (Just (Signal softwareTermination)) + (path ++ " -i br0 -w './br0.pcap' -U -Z root") . const Nothing -> id 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 +473,16 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just ( | otherwise = fmap (x:) <$> tryMatch re xs tryMatch _ [] = Nothing -exprFailed :: Text -> SourceLine -> Maybe ProcName -> Expr a -> TestRun () -exprFailed desc (SourceLine sline) pname expr = do +exprFailed :: Text -> CallStack -> Maybe ProcName -> TestRun () +exprFailed desc stack pname = do let prompt = maybe T.empty textProcName pname - exprVars <- gatherVars expr - outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline] - forM_ exprVars $ \((name, sel), value) -> - outLine OutputMatchFail (Just prompt) $ T.concat - [ " ", textVarName name, T.concat (map ("."<>) sel) - , " = ", textSomeVarValue (SourceLine sline) value - ] + outLine (OutputMatchFail stack) (Just prompt) $ desc <> " failed" 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 :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestRun ()) -> TestRun () +expect (CallStack cs) sline p (Traced trace re) etimeout tvars inner = do + let stack = CallStack (( sline, trace ) : cs) + timeout <- (etimeout *) <$> getCurrentTimeout delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do line <- readTVar (procOutput p) @@ -302,29 +496,14 @@ 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 stack) p $ T.pack "mismatched number of capture variables" 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 - - Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr - -flush :: Process -> Maybe (Expr Regex) -> TestRun () -flush p mbexpr = do - mbre <- sequence $ fmap eval mbexpr - 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 + inner capture + + Nothing -> exprFailed (T.pack "expect") stack (Just $ procName p) + +testStepGuard :: CallStack -> Bool -> TestRun () +testStepGuard stack x = do + when (not x) $ exprFailed (T.pack "guard") stack Nothing diff --git a/src/Run/Builtins.hs b/src/Run/Builtins.hs new file mode 100644 index 0000000..409e723 --- /dev/null +++ b/src/Run/Builtins.hs @@ -0,0 +1,43 @@ +module Run.Builtins ( + module Run, + loadModules, +) where + +import Data.Proxy +import Data.Scientific +import Data.Text (Text) +import Data.Void + +import Asset (Asset) +import Network (Network, Node) +import Parser (CustomTestError) +import Process (Process) +import Process.Signal (Signal) +import Run +import Script.Expr +import Test (Test, Tag) + + +builtinTypes :: [ SomePrimType ] +builtinTypes = + [ SomePrimType @() Proxy + , SomePrimType @Integer Proxy + , SomePrimType @Scientific Proxy + , SomePrimType @Bool Proxy + , SomePrimType @Text Proxy + , SomePrimType @Void Proxy + , SomePrimType @Regex Proxy + + , SomePrimType @Test Proxy + , SomePrimType @Tag Proxy + , SomePrimType @Asset Proxy + + , SomePrimType @Network Proxy + , SomePrimType @Node Proxy + + , SomePrimType @Process Proxy + , SomePrimType @Signal Proxy + ] + +loadModules :: [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules) +loadModules = loadModules' builtinTypes diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 9ec9065..8c772d5 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -7,6 +7,9 @@ module Run.Monad ( finally, forkTest, + forkTestUsing, + + getCurrentTimeout, ) where import Control.Concurrent @@ -14,33 +17,43 @@ 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] + , teTestDir :: FilePath + , teNextObjId :: MVar Int + , teNextProcId :: MVar Int + , teProcesses :: MVar [ Process ] + , teTimeout :: MVar ( Scientific, Integer ) -- ( positive timeout, number of zero multiplications ) , teGDB :: Maybe (MVar GDB) } data TestState = TestState - { tsNetwork :: Network - , tsVars :: [(VarName, SomeVarValue)] + { tsGlobals :: GlobalDefs + , tsLocals :: [ ( VarName, SomeExpr ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific @@ -51,10 +64,14 @@ data TestOptions = TestOptions , optProcTools :: [(ProcName, String)] , optTestDir :: FilePath , optTimeout :: Scientific + , optTcpdump :: Maybe FilePath , optGDB :: Bool , optForce :: Bool , optKeep :: Bool + , optRepeat :: Int + , optKeepGoing :: Bool , optWait :: Bool + , optHookTestResult :: TestName -> Bool -> IO () } defaultTestOptions :: TestOptions @@ -63,10 +80,14 @@ defaultTestOptions = TestOptions , optProcTools = [] , optTestDir = ".test" , optTimeout = 1 + , optTcpdump = Nothing , optGDB = False , optForce = False , optKeep = False + , optRepeat = 1 + , optKeepGoing = False , optWait = False + , optHookTestResult = \_ _ -> return () } data Failed = Failed @@ -93,8 +114,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 +131,20 @@ 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 () + +getCurrentTimeout :: TestRun Scientific +getCurrentTimeout = do + ( timeout, zeros ) <- liftIO . readMVar =<< asks (teTimeout . fst) + return $ if zeros > 0 then 0 + else timeout diff --git a/src/Sandbox.hs b/src/Sandbox.hs new file mode 100644 index 0000000..a05a455 --- /dev/null +++ b/src/Sandbox.hs @@ -0,0 +1,16 @@ +module Sandbox ( + isolateFilesystem, +) where + +import Foreign.C.String +import Foreign.C.Types + +import System.Directory + + +isolateFilesystem :: FilePath -> IO Bool +isolateFilesystem rwDir = do + absDir <- makeAbsolute rwDir + withCString absDir c_isolate_fs >>= return . (== 0) + +foreign import ccall unsafe "erebos_tester_isolate_fs" c_isolate_fs :: CString -> IO CInt diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs new file mode 100644 index 0000000..e6f945d --- /dev/null +++ b/src/Script/Expr.hs @@ -0,0 +1,599 @@ +module Script.Expr ( + Expr(..), varExpr, mapExpr, + + MonadEval(..), VariableDictionary, GlobalDefs, + lookupVar, tryLookupVar, withVar, withTypedVar, + eval, evalSome, evalSomeWith, + runSimpleEval, + + FunctionType, DynamicType, + ExprType(..), SomeExpr(..), + SomePrimType(..), + TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, + renameTypeVar, renameVarInType, + + VarValue(..), SomeVarValue(..), + svvVariables, svvArguments, + someConstValue, fromConstValue, + fromSomeVarValue, textSomeVarValue, someVarValueType, + + ArgumentKeyword(..), FunctionArguments(..), + anull, exprArgs, + SomeArgumentType(..), ArgumentType(..), + + Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars, + AppAnnotation(..), + callStackVarName, callStackFqVarName, + + module Script.Var, + + Regex(RegexPart, RegexString), + regexCompile, regexMatch, +) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader + +import Data.Char +import Data.Foldable +import Data.List +import Data.Map (Map) +import Data.Map qualified as M +import Data.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 :: SomeExprType -> SourceLine -> FqVarName -> Expr DynamicType + FunVariable :: ExprType a => SomeExprType -> SourceLine -> FqVarName -> Expr (FunctionType a) + OptVariable :: ExprType a => SourceLine -> FqVarName -> Expr (Maybe a) + ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a) + ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) + FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a) + FunctionEval :: ExprType a => SourceLine -> Expr (FunctionType a) -> Expr a + HidePrimType :: forall a. ExprType a => Expr a -> Expr DynamicType + HideFunType :: forall a. ExprType a => FunctionArguments SomeArgumentType -> Expr (FunctionType a) -> Expr DynamicType + ExposePrimType :: forall a. ExprType a => Expr DynamicType -> Expr a + ExposeFunType :: forall a. ExprType a => FunctionArguments SomeArgumentType -> Expr DynamicType -> Expr (FunctionType a) + TypeLambda :: TypeVar -> SomeExprType -> (SomeExprType -> Expr DynamicType) -> Expr DynamicType + TypeApp :: SomeExprType {- result type -} -> SomeExprType {- type argument -} -> Expr DynamicType -> Expr DynamicType + 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 + e@OptVariable {} -> f e + ArgsReq args expr -> f $ ArgsReq args (go expr) + ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr) + FunctionAbstraction expr -> f $ FunctionAbstraction (go expr) + FunctionEval sline expr -> f $ FunctionEval sline (go expr) + HidePrimType expr -> f $ HidePrimType $ go expr + HideFunType args expr -> f $ HideFunType args $ go expr + ExposePrimType expr -> f $ ExposePrimType $ go expr + ExposeFunType args expr -> f $ ExposeFunType args $ go expr + TypeLambda tvar stype efun -> TypeLambda tvar stype (go . efun) + TypeApp restype arg expr -> TypeApp restype arg (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 ) SomeExpr + +type VariableDictionary = [ ( VarName, SomeExpr ) ] + +lookupVar :: MonadEval m => FqVarName -> m SomeExpr +lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name + +tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeExpr) +tryLookupVar (LocalVarName name) = lookup name <$> askDictionary +tryLookupVar (GlobalVarName mname var) = M.lookup ( mname, var ) <$> askGlobalDefs + +withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a +withVar name value = withDictionary (( name, SomeExpr (Pure 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 (ReaderT ( GlobalDefs, VariableDictionary ) (Except String) a) + deriving (Functor, Applicative, Monad, MonadError String) + +runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a +runSimpleEval (SimpleEval x) gdefs dict = either error id $ runExcept $ runReaderT x ( gdefs, dict ) + +trySimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> Maybe a +trySimpleEval (SimpleEval x) gdefs dict = either (const Nothing) Just $ runExcept $ runReaderT x ( gdefs, dict ) + +instance MonadFail SimpleEval where + fail = throwError . ("eval failed: " <>) + +instance MonadEval SimpleEval where + askGlobalDefs = SimpleEval (asks fst) + askDictionary = SimpleEval (asks snd) + withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner) + +callStackVarName :: VarName +callStackVarName = VarName "$STACK" + +callStackFqVarName :: FqVarName +callStackFqVarName = LocalVarName callStackVarName + +eval :: forall m a. MonadEval m => Expr a -> m a +eval = \case + Let _ (TypedVarName name) valExpr expr -> do + val <- eval valExpr + withVar name val $ eval expr + Variable _ name -> evalSomeExpr name =<< lookupVar name + DynVariable _ _ name -> evalSomeExpr name =<< lookupVar name + FunVariable _ _ name -> evalSomeExpr name =<< lookupVar name + OptVariable _ name -> maybe (return Nothing) (fmap Just . evalSomeExpr name) =<< tryLookupVar name + ArgsReq (FunctionArguments req) efun -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ FunctionType $ \stack (FunctionArguments args) -> + let used = M.intersectionWith (\(SomeVarValue value) ( vname, _ ) -> ( vname, SomeExpr $ Pure $ vvFunction value (CallStack []) mempty )) args req + FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict) + in fun stack $ FunctionArguments $ args `M.difference` req + ArgsApp eargs efun -> do + FunctionType fun <- eval efun + args <- mapM evalSome eargs + return $ FunctionType $ \stack args' -> fun stack (args <> args') + FunctionAbstraction expr -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ FunctionType $ \stack _ -> + runSimpleEval (eval expr) gdefs (( callStackVarName, SomeExpr (Pure stack) ) : filter ((callStackVarName /=) . fst) dict) + FunctionEval sline efun -> do + vars <- gatherVars efun + CallStack cs <- maybe (return $ CallStack []) (evalSomeExpr callStackFqVarName) =<< tryLookupVar callStackFqVarName + let cs' = CallStack (( sline, vars ) : cs) + FunctionType fun <- withVar callStackVarName cs' $ eval efun + return $ fun cs' mempty + HidePrimType expr -> DynamicType <$> eval expr + HideFunType _ expr -> DynamicType <$> eval expr + ExposePrimType expr -> do + DynamicType x <- eval expr + case cast x of + Just x' -> return x' + n@Nothing -> fail $ "type error in expose primitive type result " <> show ( typeOf x, typeOf n ) + ExposeFunType _ expr -> do + DynamicType x <- eval expr + case cast x of + Just x' -> return x' + n@Nothing -> fail $ "type error in expose function type result " <> show ( typeOf x, typeOf n ) + TypeLambda _ _ f -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ DynamicType $ \t -> runSimpleEval (eval $ f t) gdefs dict + TypeApp _ arg expr -> do + DynamicType f <- eval expr + case cast f of + Just f' -> return (f' arg) + n@Nothing -> fail $ "type error in type application " <> show ( typeOf f, typeOf n ) + LambdaAbstraction (TypedVarName name) expr -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ \x -> runSimpleEval (eval expr) gdefs (( name, SomeExpr $ Pure 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 + +evalSomeExpr :: forall m a. (MonadEval m, ExprType a) => FqVarName -> SomeExpr -> m a +evalSomeExpr name (SomeExpr (e :: Expr b)) = do + maybe (fail err) eval $ cast e + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable ‘", textFqVarName name, T.pack "’ has type type ", + textExprType @b Proxy ] + +evalToVarValue :: MonadEval m => Expr a -> m (VarValue a) +evalToVarValue expr = do + VarValue + <$> gatherVars expr + <*> pure mempty + <*> (const . const <$> eval expr) + +evalFunToVarValue :: MonadEval m => Expr (FunctionType a) -> m (VarValue a) +evalFunToVarValue expr = do + FunctionType fun <- eval expr + VarValue + <$> gatherVars expr + <*> pure (exprArgs expr) + <*> pure fun + +evalSome :: MonadEval m => SomeExpr -> m SomeVarValue +evalSome (SomeExpr expr) + | IsFunType <- asFunType expr = SomeVarValue <$> evalFunToVarValue expr + | otherwise = SomeVarValue <$> evalToVarValue expr + +evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue +evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs [] + + +data FunctionType a = FunctionType (CallStack -> FunctionArguments SomeVarValue -> a) + +instance ExprType a => ExprType (FunctionType a) where + textExprType _ = "function type" + textExprValue _ = "<function type>" + +data DynamicType = forall a. Typeable a => DynamicType a + +instance ExprType DynamicType where + textExprType _ = "ambiguous type" + textExprValue _ = "<dynamic type>" + + +data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) + +data SomePrimType = forall a. ExprType a => SomePrimType (Proxy a) + +newtype TypeVar = TypeVar Text + deriving (Eq, Ord) + +data SomeExprType + = forall a. ExprType a => ExprTypePrim (Proxy a) + | forall a. ExprTypeConstr1 a => ExprTypeConstr1 (Proxy a) + | ExprTypeVar TypeVar + | ExprTypeFunction SomeExprType SomeExprType + | ExprTypeArguments (FunctionArguments SomeArgumentType) + | ExprTypeApp SomeExprType [ SomeExprType ] + | ExprTypeForall TypeVar SomeExprType + +someExprType :: SomeExpr -> SomeExprType +someExprType (SomeExpr expr) = go expr + where + go :: forall e. ExprType e => Expr e -> SomeExprType + go = \case + DynVariable stype _ _ -> stype + e@(FunVariable args _ _) -> ExprTypeFunction args (ExprTypePrim (proxyOfFunctionType e)) + HidePrimType (_ :: Expr a) -> ExprTypePrim (Proxy @a) + HideFunType args e -> ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (proxyOfFunctionType e)) + e@(ExposeFunType args _) -> ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (proxyOfFunctionType e)) + TypeLambda tvar stype _ -> ExprTypeForall tvar stype + TypeApp stype _ _ -> stype + + ArgsReq args inner -> exprTypeFunction (fmap snd args) (go inner) + ArgsApp (FunctionArguments used) inner + | ExprTypeFunction (ExprTypeArguments (FunctionArguments args)) x <- go inner + -> ExprTypeFunction (ExprTypeArguments (FunctionArguments (args `M.difference` used))) x + FunctionAbstraction inner -> exprTypeFunction mempty (go inner) + FunctionEval _ inner + | ExprTypeFunction _ x <- go inner -> x + + (_ :: Expr a) -> ExprTypePrim (Proxy @a) + + exprTypeFunction :: FunctionArguments SomeArgumentType -> SomeExprType -> SomeExprType + exprTypeFunction args (ExprTypeFunction (ExprTypeArguments args') inner) = ExprTypeFunction (ExprTypeArguments (args <> args')) inner + exprTypeFunction args inner = ExprTypeFunction (ExprTypeArguments args) inner + + proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a + proxyOfFunctionType _ = Proxy + + +renameTypeVar :: TypeVar -> TypeVar -> Expr a -> Expr a +renameTypeVar a b = go + where + go :: Expr e -> Expr e + go orig = case orig of + Let sline vname x y -> Let sline vname (go x) (go y) + Variable {} -> orig + DynVariable stype sline name -> DynVariable (renameVarInType a b stype) sline name + FunVariable {} -> orig + OptVariable {} -> orig + ArgsReq args body -> ArgsReq args (go body) + ArgsApp args fun -> ArgsApp (fmap (renameTypeVarInSomeExpr a b) args) (go fun) + FunctionAbstraction expr -> FunctionAbstraction (go expr) + FunctionEval sline expr -> FunctionEval sline (go expr) + HidePrimType expr -> HidePrimType (go expr) + HideFunType args expr -> HideFunType args (go expr) + ExposePrimType {} -> orig + ExposeFunType {} -> orig + TypeLambda tvar stype expr + | tvar == a -> orig + | tvar == b -> error "type var collision" + | otherwise -> TypeLambda tvar (renameVarInType a b stype) (go . expr) + TypeApp restype arg expr -> TypeApp (renameVarInType a b restype) (renameVarInType a b arg) (go expr) + LambdaAbstraction vname expr -> LambdaAbstraction vname (go expr) + Pure {} -> orig + App ann f x -> App ann (go f) (go x) + Concat xs -> Concat (map go xs) + Regex xs -> Regex (map go xs) + Undefined {} -> orig + Trace expr -> Trace (go expr) + +renameTypeVarInSomeExpr :: TypeVar -> TypeVar -> SomeExpr -> SomeExpr +renameTypeVarInSomeExpr a b (SomeExpr e) = SomeExpr (renameTypeVar a b e) + +renameVarInType :: TypeVar -> TypeVar -> SomeExprType -> SomeExprType +renameVarInType a b = go + where + go orig = case orig of + ExprTypePrim {} -> orig + ExprTypeConstr1 {} -> orig + ExprTypeVar tvar | tvar == a -> ExprTypeVar b + | otherwise -> orig + ExprTypeFunction args result -> ExprTypeFunction (go args) (go result) + ExprTypeArguments args -> ExprTypeArguments (fmap (\(SomeArgumentType atype stype) -> SomeArgumentType atype (go stype)) args) + ExprTypeApp c xs -> ExprTypeApp (go c) (map go xs) + ExprTypeForall tvar stype + | tvar == a -> orig + | tvar == b -> error "type var collision" + | otherwise -> ExprTypeForall tvar (go stype) + + +textSomeExprType :: SomeExprType -> Text +textSomeExprType = go [] + where + go _ (ExprTypePrim p) = textExprType p + go (x : _) (ExprTypeConstr1 c) = textExprTypeConstr1 c x + go [] (ExprTypeConstr1 _) = "<incomplte type>" + go _ (ExprTypeVar (TypeVar name)) = name + go _ (ExprTypeFunction _ r) = "function:" <> textSomeExprType r + go _ (ExprTypeArguments _) = "{…}" + go _ (ExprTypeApp c xs) = go (map textSomeExprType xs) c + go _ (ExprTypeForall (TypeVar name) ctype) = "∀" <> name <> "." <> go [] ctype + +data AsFunType a + = forall b. (a ~ FunctionType b, ExprType b) => IsFunType + | NotFunType + +asFunType :: Expr a -> AsFunType a +asFunType = \case + Let _ _ _ expr -> asFunType expr + FunVariable {} -> IsFunType + ArgsReq {} -> IsFunType + ArgsApp {} -> IsFunType + FunctionAbstraction {} -> IsFunType + _ -> NotFunType + + +data VarValue a = VarValue + { vvVariables :: EvalTrace + , vvArguments :: FunctionArguments SomeArgumentType + , vvFunction :: CallStack -> FunctionArguments SomeVarValue -> a + } + +data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a) + +svvVariables :: SomeVarValue -> EvalTrace +svvVariables (SomeVarValue vv) = vvVariables vv + +svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType +svvArguments (SomeVarValue vv) = vvArguments vv + +someConstValue :: ExprType a => a -> SomeVarValue +someConstValue = SomeVarValue . VarValue [] mempty . const . const + +fromConstValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> VarValue a -> m a +fromConstValue stack name (VarValue _ args value :: VarValue b) = do + maybe (fail err) return $ do + guard $ anull args + cast $ value stack mempty + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] + +fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> SomeVarValue -> m a +fromSomeVarValue stack name (SomeVarValue (VarValue _ args value :: VarValue b)) = do + maybe (fail err) return $ do + guard $ anull args + cast $ value stack mempty + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] + +textSomeVarValue :: SomeVarValue -> Text +textSomeVarValue (SomeVarValue (VarValue _ args value)) + | anull args = textExprValue $ value (CallStack []) mempty + | otherwise = "<function>" + +someVarValueType :: SomeVarValue -> SomeExprType +someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a)) + | anull args = ExprTypePrim (Proxy @a) + | otherwise = ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (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 (ExprTypeArguments args) _ _ -> args + FunVariable _ _ _ -> error "exprArgs: type-var args" + ArgsReq args expr -> fmap snd args <> exprArgs expr + ArgsApp (FunctionArguments applied) expr -> + let FunctionArguments args = exprArgs expr + in FunctionArguments (args `M.difference` applied) + FunctionAbstraction {} -> mempty + FunctionEval {} -> mempty + ExposePrimType {} -> mempty + ExposeFunType args _ -> args + Pure {} -> error "exprArgs: pure" + App {} -> error "exprArgs: app" + Undefined {} -> error "exprArgs: undefined" + +data SomeArgumentType = SomeArgumentType ArgumentType SomeExprType + +data ArgumentType + = RequiredArgument + | OptionalArgument + | ExprDefault SomeExpr + | ContextDefault + + +data Traced a = Traced EvalTrace a + +type VarNameSelectors = ( FqVarName, [ Text ] ) +type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ] +newtype CallStack = CallStack [ ( SourceLine, EvalTrace ) ] + +instance ExprType CallStack where + textExprType _ = T.pack "callstack" + textExprValue _ = T.pack "<callstack>" + +gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace +gatherVars = fmap (uniqOn fst . sortOn fst) . helper + where + helper :: forall b. Expr b -> m EvalTrace + helper = \case + Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr + e@(Variable _ var) -> gatherLocalVar var e + e@(DynVariable _ _ var) -> gatherLocalVar var e + e@(FunVariable _ _ var) -> gatherLocalVar var e + e@(OptVariable _ var) -> gatherLocalVar var e + ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr + ArgsApp (FunctionArguments args) fun -> do + v <- helper fun + vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args + return $ concat (v : vs) + FunctionAbstraction expr -> helper expr + FunctionEval _ efun -> helper efun + HidePrimType expr -> helper expr + HideFunType _ expr -> helper expr + ExposePrimType expr -> helper expr + ExposeFunType _ expr -> helper expr + TypeLambda {} -> return [] + TypeApp _ _ expr -> helper expr + LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr + Pure _ -> return [] + e@(App (AnnRecord sel) _ x) + | Just (var, sels) <- gatherSelectors x + -> do + gdefs <- askGlobalDefs + dict <- askDictionary + let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval e) gdefs dict + return $ catMaybes [ (( var, sels ++ [ sel ] ), ) <$> mbVal ] + | otherwise -> do + helper x + App _ f x -> (++) <$> helper f <*> helper x + Concat es -> concat <$> mapM helper es + Regex es -> concat <$> mapM helper es + Undefined {} -> return [] + Trace expr -> helper expr + + gatherLocalVar :: forall b. ExprType b => FqVarName -> Expr b -> m EvalTrace + gatherLocalVar var expr + | GlobalVarName {} <- var = return [] + | isInternalVar var = return [] + | otherwise = do + gdefs <- askGlobalDefs + dict <- askDictionary + let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval expr) gdefs dict + return $ maybe [] (\x -> [ ( ( var, [] ), x ) ]) mbVal + + gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] ) + gatherSelectors = \case + Variable _ var -> Just (var, []) + 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..1a6082a --- /dev/null +++ b/src/Script/Expr/Class.hs @@ -0,0 +1,108 @@ +module Script.Expr.Class ( + ExprType(..), + ExprTypeConstr1(..), + TypeDeconstructor(..), + RecordSelector(..), + ExprListUnpacker(..), + ExprEnumerator(..), +) where + +import Data.Kind +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 + + matchTypeConstructor :: proxy a -> TypeDeconstructor a + matchTypeConstructor _ = NoTypeDeconstructor + + 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 + +class (Typeable a, forall b. ExprType b => ExprType (a b)) => ExprTypeConstr1 (a :: Type -> Type) where + textExprTypeConstr1 :: proxy a -> Text -> Text + +data TypeDeconstructor a + = NoTypeDeconstructor + | forall c x. (ExprTypeConstr1 c, ExprType x, c x ~ a) => TypeDeconstructor1 (Proxy c) (Proxy x) + + +data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) + +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 () where + textExprType _ = "Unit" + textExprValue () = "()" + +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 _ = textExprTypeConstr1 @[] Proxy (textExprType @a Proxy) + textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" + matchTypeConstructor _ = TypeDeconstructor1 Proxy Proxy + + exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) + +instance ExprTypeConstr1 [] where + textExprTypeConstr1 _ x = "[" <> x <> "]" + +instance ExprType a => ExprType (Maybe a) where + textExprType _ = textExprType @a Proxy <> "?" + textExprValue (Just x) = textExprValue x + textExprValue Nothing = "Nothing" + +instance (ExprType a, ExprType b) => ExprType (Either a b) where + textExprType _ = textExprType @a Proxy <> "|" <> textExprType @b Proxy + textExprValue (Left x) = "Left " <> textExprValue x + textExprValue (Right x) = "Right " <> textExprValue x diff --git a/src/Script/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..7e60f80 --- /dev/null +++ b/src/Script/Object.hs @@ -0,0 +1,53 @@ +module Script.Object ( + ObjectId(..), + ObjectType(..), + Object(..), SomeObject(..), + toSomeObject, fromSomeObject, + destroySomeObject, +) where + +import Data.Kind +import Data.Text (Text) +import Data.Typeable + +import Script.Expr.Class + + +newtype ObjectId = ObjectId Int + +class Typeable a => ObjectType m a where + type ConstructorArgs a :: Type + type ConstructorArgs a = () + + textObjectType :: proxy (m a) -> proxy a -> Text + textObjectValue :: proxy (m a) -> a -> Text + + createObject :: ObjectId -> ConstructorArgs a -> m (Object m a) + destroyObject :: Object m a -> m () + +instance (Typeable m, ObjectType m a) => ExprType (Object m a) where + textExprType _ = textObjectType (Proxy @(m a)) (Proxy @a) + textExprValue = textObjectValue (Proxy @(m a)) . objImpl + + +data Object m a = ObjectType m a => Object + { objId :: ObjectId + , objImpl :: a + } + +data SomeObject m = forall a. ObjectType m a => SomeObject + { sobjId :: ObjectId + , sobjImpl :: a + } + +toSomeObject :: Object m a -> SomeObject m +toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl } + +fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a) +fromSomeObject SomeObject {..} = do + let objId = sobjId + objImpl <- cast sobjImpl + return Object {..} + +destroySomeObject :: SomeObject m -> m () +destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl) diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs new file mode 100644 index 0000000..6f6eb64 --- /dev/null +++ b/src/Script/Shell.hs @@ -0,0 +1,344 @@ +module Script.Shell ( + ShellScript(..), + ShellStatement(ShellStatement), + ShellPipeline(ShellPipeline), + ShellCommand(ShellCommand), + ShellArguments(..), ShellArgument(..), + 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.Maybe +import Data.Scientific +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable + +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Marshal.Array +import Foreign.Storable + +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Posix.IO qualified as P +import System.Posix.Process +import System.Posix.Types +import System.Process hiding (ShellCommand) + +import Asset +import Network +import Network.Ip +import Output +import Process +import Run.Monad +import Script.Expr.Class +import Script.Var + + +newtype ShellScript = ShellScript [ ShellStatement ] + +data ShellState = ShellState + { shellWorkingDirectory :: FilePath + , shellOldWorkingDirectory :: FilePath + , shellExitOnError :: Bool + , shellLastExitCode :: ExitCode + } + +data ShellStatement = ShellStatement + { shellPipeline :: ShellPipeline + , shellSourceLine :: SourceLine + } + +data ShellPipeline = ShellPipeline + { pipeCommand :: ShellCommand + , pipeUpstream :: Maybe ShellPipeline + } + +data ShellCommand = ShellCommand + { cmdCommand :: Text + , cmdExtArguments :: ShellArguments + , cmdSourceLine :: SourceLine + } + +newtype ShellArguments = ShellArguments { fromShellArguments :: [ ShellArgument ] } + deriving (Semigroup, Monoid) + +data ShellArgument + = ShellArgument Text + | ShellRedirectStdin Text + | ShellRedirectStdout Bool Text + | ShellRedirectStderr Bool Text + +cmdArguments :: ShellCommand -> [ Text ] +cmdArguments = catMaybes . map (\case ShellArgument x -> Just x; _ -> Nothing) . fromShellArguments . cmdExtArguments + +instance ExprType ShellScript where + textExprType _ = T.pack "ShellScript" + textExprValue _ = "<shell-script>" + +instance ExprType ShellStatement where + textExprType _ = T.pack "ShellStatement" + textExprValue _ = "<shell-statement>" + +instance ExprType ShellPipeline where + textExprType _ = T.pack "ShellPipeline" + textExprValue _ = "<shell-pipeline>" + +instance ExprType ShellCommand where + textExprType _ = T.pack "ShellCommand" + textExprValue _ = "<shell-command>" + +instance ExprType ShellArguments where + textExprType _ = T.pack "ShellArguments" + textExprValue _ = "<shell-arguments>" + exprExpansionConvFrom = shellExpansionTemplate + (Just (ShellArguments . (: []) . ShellArgument)) + (Just (ShellArguments . map ShellArgument)) + +instance ExprType ShellArgument where + textExprType _ = T.pack "ShellArgument" + textExprValue _ = "<shell-argument>" + exprExpansionConvFrom = shellExpansionTemplate (Just ShellArgument) Nothing + + +shellExpansionTemplate :: forall a b. (Typeable a, ExprType b) => Maybe (Text -> a) -> Maybe ([ Text ] -> a) -> Maybe (b -> a) +shellExpansionTemplate fromSingle fromList = listToMaybe $ catMaybes + [ single id + , single (T.pack . show @Integer) + , single (T.pack . show @Scientific) + , single textAssetPath + ] + where + single :: forall c. (ExprType c) => (c -> Text) -> Maybe (b -> a) + single conv = listToMaybe $ catMaybes + [ fromSingle >>= \f -> cast (f . conv) + , fromList >>= \f -> cast (f . map conv) + ] + + +data ShellExecInfo = ShellExecInfo + { seiNode :: Node + , seiProcName :: ProcName + , seiStatusVar :: MVar ExitCode + } + + +data HandleHandling + = CloseHandle Handle + | KeepHandle Handle + +closeIfRequested :: MonadIO m => HandleHandling -> m () +closeIfRequested (CloseHandle h) = liftIO $ hClose h +closeIfRequested (KeepHandle _) = return () + +handledHandle :: HandleHandling -> Handle +handledHandle (CloseHandle h) = h +handledHandle (KeepHandle h) = h + + +executeCommand :: ShellExecInfo -> ShellState -> HandleHandling -> HandleHandling -> HandleHandling -> ShellCommand -> TestRun ShellState +executeCommand sei@ShellExecInfo {..} st pstdin pstdout pstderr scmd@ShellCommand {..} = do + let args = cmdArguments scmd + ( pstdin', pstdout', pstderr' ) <- (\f -> foldM f ( pstdin, pstdout, pstderr ) (fromShellArguments cmdExtArguments)) $ \cur@( cin, cout, cerr ) -> \case + ShellRedirectStdin path -> do + closeIfRequested cin + h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) ReadMode + return ( CloseHandle h, cout, cerr ) + ShellRedirectStdout append path -> do + closeIfRequested cout + h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) $ if append then AppendMode else WriteMode + return ( cin, CloseHandle h, cerr ) + ShellRedirectStderr append path -> do + closeIfRequested cerr + h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) $ if append then AppendMode else WriteMode + return ( cin, cout, CloseHandle h ) + _ -> do + return cur + + ( getExitStatus, st' ) <- executeCommandProcess sei st (handledHandle pstdin') (handledHandle pstdout') (handledHandle pstderr') args cmdCommand + let failedWithStatus status = do + when (shellExitOnError st) $ do + liftIO $ putMVar seiStatusVar status + throwError Failed + return st' { shellLastExitCode = status } + + mapM_ closeIfRequested [ pstdin', pstdout', pstderr' ] + getExitStatus >>= \case + Exited ExitSuccess -> do + return st' { shellLastExitCode = ExitSuccess } + Exited status -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "failed at: " <> textSourceLine cmdSourceLine + failedWithStatus status + Terminated sig _ -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "killed with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine + failedWithStatus (ExitFailure (- fromIntegral sig)) + Stopped sig -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "stopped with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine + failedWithStatus (ExitFailure (- fromIntegral sig)) + + +executeCommandProcess :: ShellExecInfo -> ShellState -> Handle -> Handle -> Handle -> [ Text ] -> Text -> TestRun ( TestRun ProcessStatus, ShellState ) +executeCommandProcess sei@ShellExecInfo {..} st@ShellState {..} pstdin pstdout pstderr args = \case + "!" + | (cmd : args') <- args -> do + ( exit, st' ) <- executeCommandProcess sei st pstdin pstdout pstderr args' cmd + let exit' = exit >>= \case Exited ExitSuccess -> return (Exited (ExitFailure (-1))) + _ -> return (Exited ExitSuccess) + return ( exit', st' ) + + | [] <- args -> do + return ( return (Exited (ExitFailure (-1))), st ) + + "cd" + | [] <- args -> liftIO $ do + hPutStrLn pstdout (nodeDir seiNode) + return ( return (Exited ExitSuccess), st + { shellWorkingDirectory = nodeDir seiNode + , shellOldWorkingDirectory = shellWorkingDirectory + } ) + | [ "-" ] <- args -> liftIO $ do + hPutStrLn pstdout shellOldWorkingDirectory + return ( return (Exited ExitSuccess), st + { shellWorkingDirectory = shellOldWorkingDirectory + , shellOldWorkingDirectory = shellWorkingDirectory + } ) + | [ dir ] <- args -> liftIO $ do + cd <- canonicalizePath $ shellWorkingDirectory </> T.unpack dir + doesDirectoryExist cd >>= \case + True -> return ( return (Exited ExitSuccess), st + { shellWorkingDirectory = cd + , shellOldWorkingDirectory = shellWorkingDirectory + } ) + False -> do + hPutStrLn pstderr $ "cd: no such directory: " <> T.unpack dir + return ( return (Exited (ExitFailure (-1))), st ) + | otherwise -> do + liftIO $ hPutStrLn pstderr $ "cd: too many arguments" + return ( return (Exited (ExitFailure (-1))), st ) + + "pwd" + | [] <- args -> do + liftIO $ hPutStrLn pstdout shellWorkingDirectory + return ( return (Exited ExitSuccess), st ) + | otherwise -> do + liftIO $ hPutStrLn pstderr $ "pwd: too many arguments" + return ( return (Exited (ExitFailure (-1))), st ) + + "set" + | [ "+e" ] <- args -> do + return ( return (Exited ExitSuccess), st { shellExitOnError = False } ) + | [ "-e" ] <- args -> do + return ( return (Exited ExitSuccess), st { shellExitOnError = True } ) + | otherwise -> do + liftIO $ hPutStrLn pstderr $ "set: " <> T.unpack (T.unwords args) <> ": not implemented" + return ( return (Exited (ExitFailure (-1))), st ) + + cmd -> liftIO $ do + (_, _, _, phandle) <- createProcess_ "shell" + (proc (T.unpack cmd) (map T.unpack args)) + { std_in = UseHandle pstdin + , std_out = UseHandle pstdout + , std_err = UseHandle pstderr + , cwd = Just shellWorkingDirectory + , env = Just [] + } + Just pid <- getPid phandle + let getProcessStatus' = + liftIO (getProcessStatus True False pid) >>= \case + Just status -> return status + Nothing -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "no exit status" + return (Exited (ExitFailure (-1))) + return ( getProcessStatus', st ) + + +executePipeline :: ShellExecInfo -> ShellState -> HandleHandling -> HandleHandling -> HandleHandling -> ShellPipeline -> TestRun ShellState +executePipeline sei st pstdin pstdout pstderr ShellPipeline {..} = do + case pipeUpstream of + Nothing -> do + executeCommand sei st pstdin pstdout pstderr pipeCommand + + Just upstream -> do + ( pipeRead, pipeWrite ) <- createPipeCloexec + void $ forkTestUsing forkOS $ do + void $ executePipeline sei st pstdin (CloseHandle pipeWrite) (KeepHandle $ handledHandle pstderr) upstream + + state' <- executeCommand sei st (CloseHandle pipeRead) pstdout (KeepHandle $ handledHandle pstderr) pipeCommand + closeIfRequested pstderr + return state' + +executeScript :: ShellExecInfo -> Handle -> Handle -> Handle -> ShellScript -> TestRun () +executeScript sei@ShellExecInfo {..} pstdin pstdout pstderr (ShellScript statements) = do + setNetworkNamespace $ getNetns seiNode + let initialState = ShellState + { shellWorkingDirectory = nodeDir seiNode + , shellOldWorkingDirectory = nodeDir seiNode + , shellExitOnError = True + , shellLastExitCode = ExitSuccess + } + finalState <- (\f -> foldM f initialState statements) $ \st ShellStatement {..} -> do + executePipeline sei st (KeepHandle pstdin) (KeepHandle pstdout) (KeepHandle pstderr) shellPipeline + + liftIO $ putMVar seiStatusVar (shellLastExitCode finalState) + +spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process +spawnShell procNode procName script = do + idVar <- asks $ teNextProcId . fst + procId <- liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x )) + + procOutput <- liftIO $ newTVarIO [] + procIgnore <- liftIO $ newTVarIO ( 0, [] ) + seiStatusVar <- liftIO $ newEmptyMVar + ( pstdin, procStdin ) <- createPipeCloexec + ( hout, pstdout ) <- createPipeCloexec + ( herr, pstderr ) <- createPipeCloexec + procHandle <- fmap (Right . (, seiStatusVar)) $ forkTestUsing forkOS $ do + let seiNode = procNode + seiProcName = procName + executeScript ShellExecInfo {..} pstdin pstdout pstderr script + liftIO $ do + hClose pstdin + hClose pstdout + hClose pstderr + + let procKillWith = Nothing + let procPid = Nothing + let process = Process {..} + + startProcessIOLoops process hout herr + return process + +withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a +withShellProcess node pname script inner = do + procVar <- asks $ teProcesses . fst + + process <- spawnShell node pname script + liftIO $ modifyMVar_ procVar $ return . (process:) + + inner process `finally` do + ps <- liftIO $ takeMVar procVar + closeTestProcess process `finally` do + liftIO $ putMVar procVar $ filter (/=process) ps + + +foreign import ccall "shell_pipe_cloexec" c_pipe_cloexec :: Ptr Fd -> IO CInt + +createPipeCloexec :: (MonadIO m, MonadFail m) => m ( Handle, Handle ) +createPipeCloexec = liftIO $ do + allocaArray 2 $ \ptr -> do + c_pipe_cloexec ptr >>= \case + 0 -> do + rh <- P.fdToHandle =<< peekElemOff ptr 0 + wh <- P.fdToHandle =<< peekElemOff ptr 1 + return ( rh, wh ) + _ -> do + fail $ "failed to create pipe" diff --git a/src/Script/Var.hs b/src/Script/Var.hs new file mode 100644 index 0000000..a3620f4 --- /dev/null +++ b/src/Script/Var.hs @@ -0,0 +1,78 @@ +module Script.Var ( + VarName(..), textVarName, unpackVarName, + FqVarName(..), textFqVarName, unpackFqVarName, unqualifyName, + TypedVarName(..), + ModuleName(..), textModuleName, + TestName(..), textTestName, + SourceLine(..), textSourceLine, +) where + +import Data.Text (Text) +import Data.Text qualified as T + +import Script.Expr.Class + + +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) + +instance ExprType a => ExprType (TypedVarName a) where + textExprType _ = "TypedVarName" + textExprValue = textVarName . fromTypedVarName + + +newtype ModuleName = ModuleName [ Text ] + deriving (Eq, Ord, Show) + +textModuleName :: ModuleName -> Text +textModuleName (ModuleName parts) = T.intercalate "." parts + + +data TestName = TestName + { testNameModule :: ModuleName + , testNameBase :: Text + } + deriving (Eq, Ord) + +textTestName :: TestName -> Text +textTestName (TestName (ModuleName mparts) base) = T.intercalate "." (mparts ++ [ base ]) + + +data SourceLine + = SourceLine Text + | SourceLineBuiltin + +textSourceLine :: SourceLine -> Text +textSourceLine (SourceLine text) = text +textSourceLine SourceLineBuiltin = "<builtin>" + +instance ExprType SourceLine where + textExprType _ = "SourceLine" + textExprValue = textSourceLine diff --git a/src/Test.hs b/src/Test.hs index 719e3e2..26f5bff 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,340 +1,104 @@ module Test ( - Module(..), Test(..), + Tag(..), 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.Bifunctor import Data.Scientific -import Data.String -import Data.Text (Text) -import Data.Text qualified as T +import Data.Text (Text, pack) 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] + { testName :: TestName + , testTags :: [ Expr Tag ] + , 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 - 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 Regex = RegexCompiled Text RE.Regex - | RegexPart Text - | RegexString Text - -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] +instance ExprType Test where + textExprType _ = "Test" + textExprValue _ = "<test>" + +data Tag = Tag ModuleName VarName + deriving (Eq) + +instance ExprType Tag where + textExprType _ = "Tag" + textExprValue (Tag mname vname) = "<tag:" <> textModuleName mname <> "." <> textVarName vname <> ">" + +data TestBlock a where + EmptyTestBlock :: TestBlock () + TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a + +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 ] -> Maybe Signal -> (Process -> TestStep a) -> TestStep a + SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a + Send :: Process -> Text -> TestStep () + Expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a + Flush :: Process -> Maybe Regex -> TestStep () + Guard :: CallStack -> Bool -> TestStep () + DisconnectNode :: Node -> TestStep a -> TestStep a + DisconnectNodes :: Network -> TestStep a -> TestStep a + DisconnectUpstream :: Network -> TestStep a -> TestStep a + PacketLoss :: Scientific -> Node -> TestStep a -> TestStep a + Wait :: TestStep () + +instance ExprType a => ExprType (TestBlock a) where + textExprType _ = "TestBlock" + textExprValue _ = "<test-block>" + +instance ExprType a => ExprType (TestStep a) where + textExprType _ = "TestStep" + textExprValue _ = "<test-step>" + + +data MultiplyTimeout = MultiplyTimeout Scientific + +instance ObjectType TestRun MultiplyTimeout where + type ConstructorArgs MultiplyTimeout = Scientific + + textObjectType _ _ = "MultiplyTimeout" + textObjectValue _ (MultiplyTimeout x) = pack (show x) <> "@MultiplyTimeout" + + createObject oid timeout + | timeout >= 0 = do + var <- asks (teTimeout . fst) + liftIO $ modifyMVar_ var $ return . + (if timeout == 0 then second (+ 1) else first (* timeout)) + return $ Object oid $ MultiplyTimeout timeout + + | otherwise = do + outLine OutputError Nothing "timeout must not be negative" + throwError Failed + + destroyObject Object { objImpl = MultiplyTimeout timeout } = do + var <- asks (teTimeout . fst) + liftIO $ modifyMVar_ var $ return . + (if timeout == 0 then second (subtract 1) else first (/ timeout)) diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index 6c6c2f0..85f7b86 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -3,50 +3,86 @@ module Test.Builtins ( ) where import Data.Map qualified as M -import Data.Maybe +import Data.Proxy +import Data.Scientific import Data.Text (Text) -import Data.Typeable +import Data.Text qualified as T -import Process (Process) +import Process +import Process.Signal +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 $ concat + [ [ fq "send" builtinSend + , fq "flush" builtinFlush + , fq "ignore" builtinIgnore + , fq "guard" builtinGuard + , fq "multiply_timeout" builtinMultiplyTimeout + , fq "wait" builtinWait + , fq "concat" builtinConcat + ] + , map (uncurry fq) signalBuiltins ] + where + fq name impl = (( ModuleName [ "$" ], VarName name ), impl ) + +biVar :: ExprType a => Text -> Expr a +biVar = Variable SourceLineBuiltin . LocalVarName . VarName -getArg :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> (Expr a) -getArg args = fromMaybe (error "parameter mismatch") . getArgMb args +biOpt :: ExprType a => Text -> Expr (Maybe a) +biOpt = OptVariable SourceLineBuiltin . LocalVarName . VarName -getArgMb :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> Maybe (Expr a) -getArgMb (FunctionArguments args) kw = do - SomeExpr expr <- M.lookup kw args - cast expr +biArgs :: [ ( Maybe ArgumentKeyword, a ) ] -> FunctionArguments ( VarName, a ) +biArgs = FunctionArguments . M.fromList . map (\( kw, atype ) -> ( kw, ( VarName $ maybe "$0" (\(ArgumentKeyword tkw) -> "$" <> tkw) kw, atype ) )) + +builtinSend :: SomeExpr +builtinSend = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Send <$> biVar "$to" <*> biVar "$0") + where + atypes = + [ ( Just "to", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) ) + , ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Text)) ) + ] -builtinSend :: SomeVarValue -builtinSend = SomeVarValue (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ] +builtinFlush :: SomeExpr +builtinFlush = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Flush <$> biVar "$from" <*> biOpt "$matching") where atypes = - [ ( Just "to", SomeArgumentType (ContextDefault @Process) ) - , ( Nothing, SomeArgumentType (RequiredArgument @Text) ) + [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) ) + , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) ) ] -builtinFlush :: SomeVarValue -builtinFlush = SomeVarValue (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args Nothing) ] +builtinIgnore :: SomeExpr +builtinIgnore = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @IgnoreProcessOutput) <$> ((,) <$> biVar "$from" <*> biOpt "$matching")) where atypes = - [ ( Just "from", SomeArgumentType (ContextDefault @Process) ) - , ( Nothing, SomeArgumentType (OptionalArgument @Regex) ) + [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) ) + , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) ) ] -builtinGuard :: SomeVarValue -builtinGuard = SomeVarValue (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ - \sline args -> TestBlock [ Guard sline (getArg args Nothing) ] +builtinGuard :: SomeExpr +builtinGuard = SomeExpr $ + ArgsReq (biArgs [ ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Bool)) ) ]) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Guard <$> Variable SourceLineBuiltin callStackFqVarName <*> biVar "$0") + +builtinMultiplyTimeout :: SomeExpr +builtinMultiplyTimeout = SomeExpr $ ArgsReq (biArgs $ [ ( Just "by", SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Scientific)) ) ]) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @MultiplyTimeout) <$> biVar "$by") + +builtinWait :: SomeExpr +builtinWait = SomeExpr $ Pure $ TestBlockStep EmptyTestBlock Wait -builtinWait :: SomeVarValue -builtinWait = SomeVarValue mempty $ const . const $ TestBlock [ Wait ] +builtinConcat :: SomeExpr +builtinConcat = SomeExpr $ TypeLambda (TypeVar "a") + (ExprTypeFunction + (ExprTypeArguments $ FunctionArguments $ M.singleton Nothing $ SomeArgumentType RequiredArgument + (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar (TypeVar "a") ] ] )) + (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar (TypeVar "a") ]) + ) $ \case + ExprTypePrim (pa :: Proxy a) -> HideFunType (FunctionArguments $ M.singleton Nothing $ SomeArgumentType RequiredArgument (ExprTypePrim (Proxy :: Proxy [[ a ]]))) $ + ArgsReq (biArgs [ ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim pa) ) ]) $ FunctionAbstraction $ (concat :: [[ a ]] -> [ a ]) <$> biVar "$0" + t -> Undefined ("ambiguous type ‘" <> T.unpack (textSomeExprType t) <> "’ for concat") :: Expr DynamicType diff --git a/src/TestMode.hs b/src/TestMode.hs new file mode 100644 index 0000000..2ccf5a4 --- /dev/null +++ b/src/TestMode.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE CPP #-} + +module TestMode ( + testMode, +) where + +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State + +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.Builtins +import Script.Expr +import Test + + +data TestModeInput = TestModeInput + { tmiOutput :: Output + , tmiConfig :: Maybe Config + , tmiParams :: [ Text ] + } + +data TestModeState = TestModeState + { tmsModules :: Maybe LoadedModules + , tmsNextTestNumber :: Int + } + +initTestModeState :: TestModeState +initTestModeState = TestModeState + { tmsModules = Nothing + , 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 + +runTestsC :: [ Test ] -> CommandM Report +runTestsC tests = do + out <- asks tmiOutput + num <- getNextTestNumber + Just LoadedModules {..} <- gets tmsModules + mbconfig <- asks tmiConfig + let opts = defaultTestOptions + { optDefaultTool = fromMaybe "/bin/true" $ configTool =<< mbconfig + , optTestDir = ".test" <> show num + , optKeep = True + , optKeepGoing = True + , optHookTestResult = \tname res -> do + flip runReaderT out $ outLine OutputTestRaw Nothing $ + "run-test-result " <> testNameBase tname <> " " <> (if res then "done" else "failed") + } + liftIO (runTests out opts lmGlobalDefs tests) + + +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 ) + ] + +showError :: Text -> CustomTestError -> Command +showError prefix = \case + ModuleNotFound moduleName -> do + cmdOut $ prefix <> " module-not-found" <> textModuleName moduleName + FileNotFound notFoundPath -> do + cmdOut $ prefix <> " file-not-found " <> T.pack notFoundPath + TestNotFound tname mbfile -> do + cmdOut $ prefix <> " test-not-found " <> tname <> maybe "" ((" " <>) . T.pack) mbfile + TestOrTagNotFound tname mbfile -> do + cmdOut $ prefix <> " test-or-tag-not-found " <> tname <> maybe "" ((" " <>) . T.pack) mbfile + ImportModuleError bundle -> do +#if MIN_VERSION_megaparsec(9,7,0) + mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle +#endif + cmdOut $ prefix <> " parse-error" + where + showParseError _ SourcePos {..} _ = concat + [ "parse-error" + , " ", sourceName + , ":", show $ unPos sourceLine + , ":", show $ unPos sourceColumn + ] + +cmdLoad :: Command +cmdLoad = do + [ path ] <- asks tmiParams + liftIO (loadModules [ ( T.unpack path, Nothing ) ]) >>= \case + Right modules -> do + modify $ \s -> s { tmsModules = Just modules } + cmdOut "load-done" + Left err -> showError "load-failed" err + +cmdLoadConfig :: Command +cmdLoadConfig = do + Just config <- asks tmiConfig + liftIO (getConfigTestFiles config >>= loadModules . (map (, Nothing ))) >>= \case + Right modules -> do + modify $ \s -> s { tmsModules = Just modules } + cmdOut "load-config-done" + Left err -> showError "load-config-failed" err + +cmdRun :: Command +cmdRun = do + params <- asks tmiParams + let ( select, exclude ) = fmap (map (T.drop 1)) $ partition (("^" /=) . T.take 1) params + pfilter = (TestFilter (if select == [ "*" ] then Nothing else Just select) exclude) + cfilter <- asks $ maybe mempty testFilterFromConfig . tmiConfig + Just lm <- gets tmsModules + case filterTests (cfilter <> pfilter) lm of + Left err -> showError "run-failed" err + Right tests -> do + Report {..} <- runTestsC tests + cmdOut $ T.unwords + [ "run-done" + , T.pack (show reportTotalCount) + , T.pack (show reportPassedCount) + , T.pack (show reportSkippedCount) + , T.pack (show reportFailedCount) + ] diff --git a/src/TextFormat.hs b/src/TextFormat.hs new file mode 100644 index 0000000..7b8152f --- /dev/null +++ b/src/TextFormat.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TextFormat ( + FormattedText, + plainText, + + TextStyle, + withStyle, noStyle, + + Color(..), + setForegroundColor, setBackgroundColor, + + endWithNewline, + + renderPlainText, + formattedTextLength, + formattedTextHeight, +) where + +import Data.Text (Text) +import Data.Text qualified as T + +import TextFormat.Types + + +plainText :: Text -> FormattedText +plainText = PlainText + + +withStyle :: TextStyle -> FormattedText -> FormattedText +withStyle = FormattedText + +noStyle :: TextStyle +noStyle = CustomTextColor Nothing Nothing + +setForegroundColor :: Color -> TextStyle -> TextStyle +setForegroundColor color (CustomTextColor _ bg) = CustomTextColor (Just color) bg + +setBackgroundColor :: Color -> TextStyle -> TextStyle +setBackgroundColor color (CustomTextColor fg _) = CustomTextColor fg (Just color) + + +endWithNewline :: FormattedText -> FormattedText +endWithNewline = EndWithNewline + + +renderPlainText :: FormattedText -> Text +renderPlainText = \case + PlainText text -> text + ConcatenatedText ftexts -> mconcat $ map renderPlainText ftexts + FormattedText _ ftext -> renderPlainText ftext + EndWithNewline ftext -> let res = renderPlainText ftext + in case T.unsnoc res of + Just ( _, '\n') -> res + _ -> res <> "\n" + +formattedTextLength :: FormattedText -> Int +formattedTextLength = \case + PlainText text -> T.length text + ConcatenatedText ftexts -> sum $ map formattedTextLength ftexts + FormattedText _ ftext -> formattedTextLength ftext + EndWithNewline ftext -> formattedTextLength ftext + +formattedTextHeight :: FormattedText -> Int +formattedTextHeight = countLines . collectParts + where + collectParts = \case + PlainText text -> [ text ] + ConcatenatedText ftexts -> concatMap collectParts ftexts + FormattedText _ ftext -> collectParts ftext + EndWithNewline ftext -> collectParts ftext + countLines (t : ts) + | T.null t = countLines ts + | otherwise = 1 + countLines (dropLine (t : ts)) + countLines [] = 0 + dropLine (t : ts) + | Just ( '\n', t' ) <- T.uncons (T.dropWhile (/= '\n') t) = t' : ts + | otherwise = dropLine ts + dropLine [] = [] diff --git a/src/TextFormat/Ansi.hs b/src/TextFormat/Ansi.hs new file mode 100644 index 0000000..0e8d030 --- /dev/null +++ b/src/TextFormat/Ansi.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TextFormat.Ansi ( + FormattedText, + + AnsiText(..), + renderAnsiText, +) where + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Writer + +import Data.String +import Data.Text (Text) +import Data.Text qualified as T + +import TextFormat.Types + + +newtype AnsiText = AnsiText { fromAnsiText :: Text } + deriving (Eq, Ord, Semigroup, Monoid, IsString) + + +data RenderState = RenderState + { rsEndedWithNewline :: Bool + } + +initialRenderState :: RenderState +initialRenderState = RenderState + { rsEndedWithNewline = True + } + +renderAnsiText :: FormattedText -> AnsiText +renderAnsiText ft = AnsiText $ T.concat $ execWriter $ flip evalStateT initialRenderState $ go ( Nothing, Nothing ) ft + where + go :: ( Maybe Color, Maybe Color ) -> FormattedText -> StateT RenderState (Writer [ Text ]) () + go cur@( cfg, cbg ) = \case + PlainText text -> do + tell [ text ] + case T.unsnoc text of + Just ( _, c ) -> modify (\s -> s { rsEndedWithNewline = c == '\n' }) + Nothing -> return () + ConcatenatedText ftexts -> mconcat <$> mapM (go cur) ftexts + FormattedText (CustomTextColor fg bg) ftext -> do + tell [ ansiColor fg bg ] + go ( fg <|> cfg, bg <|> cbg ) ftext + tell [ ansiColor + (if fg /= cfg then cfg <|> Just DefaultColor else Nothing) + (if bg /= cbg then cbg <|> Just DefaultColor else Nothing) + ] + EndWithNewline ftext -> do + go cur ftext + gets rsEndedWithNewline >>= \case + True -> return () + False -> tell [ "\n" ] >> modify (\s -> s { rsEndedWithNewline = True }) + + +ansiColor :: Maybe Color -> Maybe Color -> Text +ansiColor Nothing Nothing = "" +ansiColor (Just fg) Nothing = "\ESC[" <> T.pack (show (colorNum fg)) <> "m" +ansiColor Nothing (Just bg) = "\ESC[" <> T.pack (show (colorNum bg + 10)) <> "m" +ansiColor (Just fg) (Just bg) = "\ESC[" <> T.pack (show (colorNum fg)) <> ";" <> T.pack (show (colorNum bg + 10)) <> "m" + +colorNum :: Color -> Int +colorNum = \case + DefaultColor -> 39 + Black -> 30 + Red -> 31 + Green -> 32 + Yellow -> 33 + Blue -> 34 + Magenta -> 35 + Cyan -> 36 + White -> 37 + BrightBlack -> 90 + BrightRed -> 91 + BrightGreen -> 92 + BrightYellow -> 93 + BrightBlue -> 94 + BrightMagenta -> 95 + BrightCyan -> 96 + BrightWhite -> 97 diff --git a/src/TextFormat/Types.hs b/src/TextFormat/Types.hs new file mode 100644 index 0000000..40deabd --- /dev/null +++ b/src/TextFormat/Types.hs @@ -0,0 +1,58 @@ +module TextFormat.Types ( + FormattedText(..), + TextStyle(..), + Color(..), +) where + +import Data.String +import Data.Text (Text) + + +data FormattedText + = PlainText Text + | ConcatenatedText [ FormattedText ] + | FormattedText TextStyle FormattedText + | EndWithNewline FormattedText + +instance IsString FormattedText where + fromString = PlainText . fromString + +instance Semigroup FormattedText where + ConcatenatedText xs <> ConcatenatedText ys = ConcatenatedText (xs ++ ys) + x <> ConcatenatedText ys = ConcatenatedText (x : ys) + ConcatenatedText xs <> y = ConcatenatedText (xs ++ [ y ]) + x <> y = ConcatenatedText [ x, y ] + +instance Monoid FormattedText where + mempty = ConcatenatedText [] + mconcat [] = ConcatenatedText [] + mconcat [ x ] = x + mconcat xs = ConcatenatedText $ concatMap flatten xs + where + flatten (ConcatenatedText ys) = ys + flatten y = [ y ] + + +data TextStyle + = CustomTextColor (Maybe Color) (Maybe Color) + + +data Color + = DefaultColor + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + | BrightBlack + | BrightRed + | BrightGreen + | BrightYellow + | BrightBlue + | BrightMagenta + | BrightCyan + | BrightWhite + deriving (Eq) 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..9a6abcb --- /dev/null +++ b/src/main.c @@ -0,0 +1,203 @@ +#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 <stdlib.h> +#include <string.h> +#include <sys/mount.h> +#include <sys/stat.h> +#include <sys/syscall.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[] ) +{ + int ret; + + uid_t uid = geteuid(); + gid_t gid = getegid(); + ret = unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS ); + if( ret < 0 ){ + fprintf( stderr, "unsharing user, network and mount namespaces failed: %s\n", strerror( errno )); + return 1; + } + + char buf[ 256 ]; + int len; + + 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; + + /* + * Prepare for future filesystem isolation within additional mount namespace: + * - clone whole mount tree as read-only under new /tmp/new_root + * - keep writable /proc and /tmp + */ + + ret = mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" ); + if( ret < 0 ){ + fprintf( stderr, "failed to mount tmpfs on /run: %s\n", strerror( errno )); + return 1; + } + + ret = mkdir( "/run/new_root", 0700 ); + if( ret < 0 ){ + fprintf( stderr, "failed to create new_root directory: %s\n", strerror( errno )); + return 1; + } + + ret = mount( "/", "/run/new_root", NULL, MS_BIND | MS_REC, NULL ); + if( ret < 0 ){ + fprintf( stderr, "failed to bind-mount / on new_root: %s\n", strerror( errno )); + return 1; + } + + struct mount_attr * attr_ro = &( struct mount_attr ) { + .attr_set = MOUNT_ATTR_RDONLY, + }; + ret = mount_setattr( -1, "/run/new_root", AT_RECURSIVE, attr_ro, sizeof( * attr_ro ) ); + if( ret < 0 ){ + fprintf( stderr, "failed set sandbox root as read-only: %s\n", strerror( errno )); + return 1; + } + + struct mount_attr * attr_rw = &( struct mount_attr ) { + .attr_clr = MOUNT_ATTR_RDONLY, + }; + ret = mount_setattr( -1, "/run/new_root/proc", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) ); + if( ret < 0 ){ + fprintf( stderr, "failed set sandbox /proc as read-write: %s\n", strerror( errno )); + return 1; + } + ret = mount_setattr( -1, "/run/new_root/tmp", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) ); + if( ret < 0 ){ + if( errno == EINVAL ){ + // Original /tmp is not a separate filesystem, so we can't just change the attributes + ret = mount( "/tmp", "/run/new_root/tmp", NULL, MS_BIND, NULL ); + if( ret < 0 ) + fprintf( stderr, "failed to bind-mount original /tmp in sandbox as read-write: %s\n", strerror( errno )); + } else { + fprintf( stderr, "failed set sandbox /tmp as read-write: %s\n", strerror( errno )); + } + } + + ret = mount( "tmpfs", "/run/new_root/run", "tmpfs", 0, "size=4m" ); + if( ret < 0 ){ + fprintf( stderr, "failed to mount tmpfs on sandbox /run: %s\n", strerror( errno )); + return 1; + } + + ret = mkdir( "/run/new_root/run/old_root", 0700 ); + if( ret < 0 ){ + fprintf( stderr, "failed to create old_root directory: %s\n", strerror( errno )); + return 1; + } + + hs_init( &argc, &argv ); + testerMain(); + hs_exit(); + + return 0; +} + +/* + * - Replace filesystem hierarchy with read-only version, + * - bind-mound rwdir from writable tree, and + * - keep writeable /tmp from host. + */ +int erebos_tester_isolate_fs( const char * rwdir ) +{ + int ret; + + ret = unshare( CLONE_NEWNS ); + if( ret < 0 ){ + fprintf( stderr, "unsharing mount namespace failed: %s\n", strerror( errno )); + return -1; + } + + char * cwd = getcwd( NULL, 0 ); + ret = syscall( SYS_pivot_root, "/run/new_root", "/run/new_root/run/old_root" ); + if( ret < 0 ){ + fprintf( stderr, "failed to pivot_root: %s\n", strerror( errno )); + free( cwd ); + return -1; + } + + char oldrwdir[ strlen(rwdir) + 15 ]; + snprintf( oldrwdir, sizeof oldrwdir, "/run/old_root/%s", rwdir ); + ret = mount( oldrwdir, rwdir, NULL, MS_BIND, NULL ); + if( ret < 0 ){ + fprintf( stderr, "failed to bind-mount %s on %s: %s\n", oldrwdir, rwdir, strerror( errno )); + free( cwd ); + return -1; + } + + ret = umount2( "/run/old_root", MNT_DETACH ); + if( ret < 0 ){ + fprintf( stderr, "failed to detach /run/old_root: %s\n", strerror( errno )); + free( cwd ); + return -1; + } + + ret = chdir( cwd ); + if( ret < 0 ){ + fprintf( stderr, "failed to chdir to %s: %s\n", cwd, strerror( errno )); + free( cwd ); + return -1; + } + free( cwd ); + + return 0; +} diff --git a/src/shell.c b/src/shell.c new file mode 100644 index 0000000..d832078 --- /dev/null +++ b/src/shell.c @@ -0,0 +1,8 @@ +#define _GNU_SOURCE +#include <fcntl.h> +#include <unistd.h> + +int shell_pipe_cloexec( int pipefd[ 2 ] ) +{ + return pipe2( pipefd, O_CLOEXEC ); +} diff --git a/test/asset/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/list/concat.et b/test/asset/list/concat.et new file mode 100644 index 0000000..c669a78 --- /dev/null +++ b/test/asset/list/concat.et @@ -0,0 +1,38 @@ +test Test: + let list1 = [ 1 ] + let list2 = [ 2, 3 ] + let empty = [ ] + + node n + + let c1 = concat [[ 1 ]] + for i in c1: + shell on n: + echo "c1 $i" + local: + shell on n: + echo "c1-end" + + let c2 = concat [[ 1 ], [], empty] + for i in c2: + shell on n: + echo "c2 $i" + local: + shell on n: + echo "c2-end" + + let c3 = concat [ list1, list2, [ 6, 5 ], list2 ] + for i in c3: + shell on n: + echo "c3 $i" + local: + shell on n: + echo "c3-end" + + let c4 = list1 ++ list2 ++ [ 6, 5 ] ++ list2 + for i in c4: + shell on n: + echo "c4 $i" + local: + shell on n: + echo "c4-end" diff --git a/test/asset/network/disconnect_node.et b/test/asset/network/disconnect_node.et new file mode 100644 index 0000000..a9450a7 --- /dev/null +++ b/test/asset/network/disconnect_node.et @@ -0,0 +1,27 @@ +test Test: + node n1 + node n2 + node n3 + + local: + shell on n1: + ping ${n3.ip} -c 1 + + shell on n2: + ping ${n3.ip} -c 1 + + local: + disconnect_node n1 + + shell on n1: + ! ping ${n3.ip} -c 1 + + shell on n2: + ping ${n3.ip} -c 1 + + local: + shell on n1: + ping ${n3.ip} -c 1 + + shell on n2: + ping ${n3.ip} -c 1 diff --git a/test/asset/network/disconnect_nodes.et b/test/asset/network/disconnect_nodes.et new file mode 100644 index 0000000..9469024 --- /dev/null +++ b/test/asset/network/disconnect_nodes.et @@ -0,0 +1,46 @@ +test Test: + subnet s1 + node n1_1 on s1 + node n1_2 on s1 + + subnet s2 + node n2_1 on s2 + node n2_2 on s2 + + subnet s3 + node n3 on s3 + + local: + shell on n1_1: + ping ${n1_2.ip} -c 1 -W 0.001 + ping ${n2_2.ip} -c 1 -W 0.001 + ping ${n3.ip} -c 1 -W 0.001 + + shell on n2_1: + ping ${n1_2.ip} -c 1 -W 0.001 + ping ${n2_2.ip} -c 1 -W 0.001 + ping ${n3.ip} -c 1 -W 0.001 + + local: + disconnect_nodes s1 + + shell on n1_1: + ! ping ${n1_2.ip} -c 1 -W 0.001 + ! ping ${n2_2.ip} -c 1 -W 0.001 + ! ping ${n3.ip} -c 1 -W 0.001 + + shell on n2_1: + ! ping ${n1_2.ip} -c 1 -W 0.001 + ping ${n2_2.ip} -c 1 -W 0.001 + ping ${n3.ip} -c 1 -W 0.001 + + local: + shell on n1_1: + ping ${n1_2.ip} -c 1 -W 0.001 + ping ${n2_2.ip} -c 1 -W 0.001 + ping ${n3.ip} -c 1 -W 0.001 + + shell on n2_1: + ping ${n1_2.ip} -c 1 -W 0.001 + ping ${n2_2.ip} -c 1 -W 0.001 + ping ${n3.ip} -c 1 -W 0.001 diff --git a/test/asset/output/flush.et b/test/asset/output/flush.et new file mode 100644 index 0000000..0051dfd --- /dev/null +++ b/test/asset/output/flush.et @@ -0,0 +1,13 @@ +test Test: + node n + shell on n as p: + echo a + echo b + echo c + echo d + echo e + with p: + expect /e/ + flush matching /[b-z]/ + expect /.*/ + expect /.*/ timeout 0.0 diff --git a/test/asset/output/ignore.et b/test/asset/output/ignore.et new file mode 100644 index 0000000..cc70e3b --- /dev/null +++ b/test/asset/output/ignore.et @@ -0,0 +1,20 @@ +test Test: + node n + shell on n as p: + echo a + echo b + echo c + echo d + grep -q . + echo e + echo F + echo g + echo H + with p: + expect /d/ + ignore matching /[b-z]/ + send "x" + expect /.*/ + expect /H/ + expect /F/ + expect /.*/ timeout 0.0 diff --git a/test/asset/parser/function-fail.et b/test/asset/parser/function-fail.et new file mode 100644 index 0000000..59ac3b0 --- /dev/null +++ b/test/asset/parser/function-fail.et @@ -0,0 +1,2 @@ +test Test: + guard 1 == 1 diff --git a/test/asset/parser/function.et b/test/asset/parser/function.et new file mode 100644 index 0000000..2a096b9 --- /dev/null +++ b/test/asset/parser/function.et @@ -0,0 +1,16 @@ +def f (x) and y = (x + y) + 1 + +def g (x) and y = (x + (y+1)) + +test Test: + guard (1 == 1) + guard (1 /= 2) + let x = 2 + guard (x == x) + guard (x /= 1) + guard (x /= x + 1) + + guard (f 1 and 2 == 4) + guard (f 1 and 2 == g 1 and 2) + guard (f 1 and (g 2 and 3) == g 1 and 2 + 4) + guard (f (10 + g and 1 1) and (g 2 and 3) == g 1 and 2 + 10 +6) diff --git a/test/asset/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/parser/tags.et b/test/asset/parser/tags.et new file mode 100644 index 0000000..3e06e44 --- /dev/null +++ b/test/asset/parser/tags.et @@ -0,0 +1,20 @@ +tag SomeTag + +tag OtherTag + +test First: + tag: SomeTag + tag: OtherTag + let x = 1 + local: + let y = 1 + +test Second: + tag: SomeTag + + local: + let x = 1 + +test Third: + local: + let x = 1 diff --git a/test/asset/parser/type-annotation.et b/test/asset/parser/type-annotation.et new file mode 100644 index 0000000..9740768 --- /dev/null +++ b/test/asset/parser/type-annotation.et @@ -0,0 +1,15 @@ +def fun (a : String) and (b : Integer) proc (p : Process): + let c = [ a, "x" ] : [ String ] + let d = [ a ] + let e = [ b : Integer, 43 : Integer ]:[Integer] + let f = [[ c, ["y"]]] : [[[ String ] ] ] + guard (c /= d) + guard (e == e) + +test Test: + let x = "" : String + let y = (2 : Integer) + let z = (2 : Integer) + (y : Integer) : Integer + let re = /xyz/ : Regex + spawn as p + fun "a" and ((z) : Integer) proc (p : Process) diff --git a/test/asset/run-fail/bool.et b/test/asset/run-fail/bool.et new file mode 100644 index 0000000..1608a08 --- /dev/null +++ b/test/asset/run-fail/bool.et @@ -0,0 +1,3 @@ +test Test: + node n + guard (True == False) diff --git a/test/asset/run-fail/command-ignore.et b/test/asset/run-fail/command-ignore.et new file mode 100644 index 0000000..9622782 --- /dev/null +++ b/test/asset/run-fail/command-ignore.et @@ -0,0 +1,13 @@ +test Test: + node n + shell on n as p: + cat + + send "a" to p + send "b" to p + send "x" to p + expect /x/ from p + ignore from p + + multiply_timeout by 0.0 + expect /.*/ from p diff --git a/test/asset/run-success/bool.et b/test/asset/run-success/bool.et new file mode 100644 index 0000000..7121cc0 --- /dev/null +++ b/test/asset/run-success/bool.et @@ -0,0 +1,7 @@ +test Test: + node n + guard (True == True) + guard (False == False) + guard (False /= True) + guard ((1 == 1) == True) + guard ((1 == 0) == False) diff --git a/test/asset/run-success/command-flush.et b/test/asset/run-success/command-flush.et new file mode 100644 index 0000000..8c5f7b8 --- /dev/null +++ b/test/asset/run-success/command-flush.et @@ -0,0 +1,30 @@ +def expect_next from p (str): + expect /(.*)/ from p capture line + guard (line == str) + +test Test: + node n + shell on n as p: + cat + + send "a1" to p + send "b" to p + send "x" to p + expect /x/ from p + + flush from p matching /a.*/ + send "a2" to p + send "c" to p + + expect_next "b" from p + expect_next "a2" from p + expect_next "c" from p + + send "d" to p + send "e" to p + send "f" to p + send "x" to p + expect /x/ from p + flush from p + send "g" to p + expect_next "g" from p diff --git a/test/asset/run-success/command-ignore.et b/test/asset/run-success/command-ignore.et new file mode 100644 index 0000000..dc950d1 --- /dev/null +++ b/test/asset/run-success/command-ignore.et @@ -0,0 +1,39 @@ +def expect_next from p (str): + expect /(.*)/ from p capture line + guard (line == str) + +test Test: + node n + shell on n as p: + cat + + send "a" to p + send "b" to p + send "x" to p + expect /x/ from p + + ignore from p matching /a/ + send "a" to p + send "c" to p + + expect_next "b" from p + expect_next "c" from p + + send "a" to p + send "b" to p + with p: + send "c" + ignore matching /[bcd]/ + send "d" + send "e" + expect_next "e" from p + + send "a" to p + send "b" to p + local: + send "c" to p + send "d" to p + + expect_next "b" from p + expect_next "c" from p + expect_next "d" from p diff --git a/test/asset/run/callstack.et b/test/asset/run/callstack.et new file mode 100644 index 0000000..36eb401 --- /dev/null +++ b/test/asset/run/callstack.et @@ -0,0 +1,41 @@ +test AG: + let x = 1 + guard (x == 0) + +test AE: + spawn as p + let x = 2 + expect /$x/ from p timeout 0.0 + +def fg: + let x = 1 + guard (x == 0) + +test BG: + fg + +def gg (x): + let y = 2 + guard (x == y) + +test CG: + let z = 3 + gg (z) + +def fe on p: + let x = 1 + expect /$x/ from p timeout 0.0 + +test BE: + spawn as p + fe on p + +def ge (x) on p: + guard (x /= 0) + let y = 2 + expect /$x $y/ from p timeout 0.0 + +test CE: + spawn as p + let z = 3 + ge (z) on p diff --git a/test/asset/run/echo.et b/test/asset/run/echo.et new file mode 100644 index 0000000..9950d7b --- /dev/null +++ b/test/asset/run/echo.et @@ -0,0 +1,4 @@ +test ExpectEcho: + spawn as p + send "abcdef" to p + expect /abcdef/ from p diff --git a/test/asset/run/erebos-tester-select1.yaml b/test/asset/run/erebos-tester-select1.yaml new file mode 100644 index 0000000..62e0ead --- /dev/null +++ b/test/asset/run/erebos-tester-select1.yaml @@ -0,0 +1,2 @@ +tests: ./tags.et +exclude: B diff --git a/test/asset/run/erebos-tester-select2.yaml b/test/asset/run/erebos-tester-select2.yaml new file mode 100644 index 0000000..52310be --- /dev/null +++ b/test/asset/run/erebos-tester-select2.yaml @@ -0,0 +1,8 @@ +tests: ./tags.et +select: + - T2 + - A + - B +exclude: + - A1 + - C 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/tags.et b/test/asset/run/tags.et new file mode 100644 index 0000000..b1433fa --- /dev/null +++ b/test/asset/run/tags.et @@ -0,0 +1,38 @@ +export tag A +export tag B +export tag C + +test T1: + guard True + +test T2: + guard True + +test A1: + tag: A + guard True + +test A2: + tag: A + guard True + +test B1: + tag: B + guard True + +test B2: + tag: B + guard True + +test C1: + tag: C + guard True + +test C2: + tag: C + guard True + +test BC: + tag: B + tag: C + guard True diff --git a/test/asset/run/tools/echo.sh b/test/asset/run/tools/echo.sh new file mode 100755 index 0000000..53b1eae --- /dev/null +++ b/test/asset/run/tools/echo.sh @@ -0,0 +1,2 @@ +#!/bin/sh +cat diff --git a/test/asset/run/tools/sysinfo.sh b/test/asset/run/tools/sysinfo.sh new file mode 100755 index 0000000..38591f4 --- /dev/null +++ b/test/asset/run/tools/sysinfo.sh @@ -0,0 +1,9 @@ +#!/bin/sh + +while read cmd; do + case "$cmd" in + network-info) + ip -o addr show | sed -e 's/[0-9]*: \([a-z0-9]*\).*inet6\? \([0-9a-f:.]*\).*/ip \1 \2/' + ;; + esac +done diff --git a/test/asset/run/trivial.et b/test/asset/run/trivial.et new file mode 100644 index 0000000..0b2e878 --- /dev/null +++ b/test/asset/run/trivial.et @@ -0,0 +1,7 @@ +test AlwaysSucceeds: + node n + guard (1 == 1) + +test AlwaysFails: + node n + guard (1 == 0) diff --git a/test/asset/shell/echo.et b/test/asset/shell/echo.et new file mode 100644 index 0000000..1e48cac --- /dev/null +++ b/test/asset/shell/echo.et @@ -0,0 +1,25 @@ +test Echo: + node n + let echo_str = "echo" + let space_str = "a b" + + shell on n as sh: + echo a b c + echo "a b c" + echo 'a b d' + echo a b " c d" + + /bin/echo "abcd" xyz + "echo" a"a" "b"c d + $echo_str b $echo_str c + + echo "$space_str" + echo $space_str + echo '$space_str' + + echo \$ \" \\ + echo "\""\""a" + echo "'" '"' '\\\' "\\" + echo a\ b\ \ c + + echo \" \' \\ \$ \# \| \> \< \; \[ \] \{ \} \( \) \* \? \~ \& \! diff --git a/test/asset/shell/error-exit.et b/test/asset/shell/error-exit.et new file mode 100644 index 0000000..ecc2cd4 --- /dev/null +++ b/test/asset/shell/error-exit.et @@ -0,0 +1,26 @@ +test Default: + node n + shell on n as sh: + false + +test DisabledSuccess: + node n + shell on n as sh: + set +e + false + true + +test DisabledFailure: + node n + shell on n as sh: + set +e + false + +test Enabled: + node n + shell on n as sh: + set +e + false + set -e + false + true diff --git a/test/asset/shell/expansion.et b/test/asset/shell/expansion.et new file mode 100644 index 0000000..b947eb6 --- /dev/null +++ b/test/asset/shell/expansion.et @@ -0,0 +1,20 @@ +test Test: + node n + + let str = "some string" + let int = 2 + let num = 4.5 + let list = [ "a b", "c d", "e", "f" ] + let ilist = [ 1 .. 5 ] + let cmd = "echo" + let cmdlist = [ "echo", "w", "x y", " z " ] + let special = [ "<", ">", "| &", ";" ] + + shell on n as sh: + echo A $str B $int $num C + echo D $list E + echo F $ilist G + $cmd H I + $cmdlist J + $cmdlist K $ilist L $int M $special N + echo ${str}O P$str diff --git a/test/asset/shell/logic.et b/test/asset/shell/logic.et new file mode 100644 index 0000000..d1d4b32 --- /dev/null +++ b/test/asset/shell/logic.et @@ -0,0 +1,14 @@ +test NegateFalse: + node n + shell on n as sh: + ! false + +test NegateTrue: + node n + shell on n as sh: + ! true + +test NegateNothing: + node n + shell on n as sh: + ! diff --git a/test/asset/shell/pipe.et b/test/asset/shell/pipe.et new file mode 100644 index 0000000..a00360a --- /dev/null +++ b/test/asset/shell/pipe.et @@ -0,0 +1,25 @@ +test Pipe: + node n + shell on n as sh: + echo abcd | grep -o '[bc]*' + echo abcd | grep -o '[bcd]*' | grep -o '[ab]*' + + +test Redirect: + node n + shell on n as sh: + echo a > file + echo b > file + echo c >> file + echo x + cat file + echo y + cat < file + echo z + +test PipeRedirect: + node n + shell on n as sh: + echo abcdefghi | grep -o '[b-h]*' | grep -o '[a-g]*' > file + cat < file | grep -o '[acegi]' | cat > file2 + cat file2 - < file diff --git a/test/asset/shell/spawn.et b/test/asset/shell/spawn.et new file mode 100644 index 0000000..9d48e72 --- /dev/null +++ b/test/asset/shell/spawn.et @@ -0,0 +1,13 @@ +test ShellTrue: + node n + shell on n: + true + + shell on n as sh: + true + + +test ShellFalse: + node n + shell on n as sh: + false diff --git a/test/asset/shell/working-directory.et b/test/asset/shell/working-directory.et new file mode 100644 index 0000000..da31e2f --- /dev/null +++ b/test/asset/shell/working-directory.et @@ -0,0 +1,19 @@ +test Test: + node n + shell on n as sh: + pwd + mkdir -p abc/def/ghi + cd abc/def + pwd + cd .. + pwd + cd def/ghi + pwd + cd - + pwd + cd - + pwd + cd + pwd + cd /tmp + pwd diff --git a/test/script/definition.et b/test/script/definition.et new file mode 100644 index 0000000..31ae21f --- /dev/null +++ b/test/script/definition.et @@ -0,0 +1,21 @@ +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 /global-info - Starting test ‘basic\.Test’/ + expect /child-stdout p 4/ + expect /match p 4/ + expect /child-stdout p 11/ + expect /match p 11/ + expect /run-test-result Test (.*)/ capture result + guard (result == "done") + expect /(.*)/ capture done + guard (done == "run-done 1 1 0 0") diff --git a/test/script/expansion.et b/test/script/expansion.et new file mode 100644 index 0000000..85c241d --- /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 1 1 0 0/ diff --git a/test/script/list.et b/test/script/list.et new file mode 100644 index 0000000..7a032cb --- /dev/null +++ b/test/script/list.et @@ -0,0 +1,42 @@ +module list + +asset scripts: + path: ../asset/list + +def expect_next_stdout (what) from p: + expect /child-stdout shell (.*)/ from p capture line + guard (line == what) + + +test ListConcat: + spawn as p + with p: + send "load ${scripts.path}/concat.et" + expect /load-done/ + + send "run Test" + expect_next_stdout from p: + "c1 1" + "c1-end" + "c2 1" + "c2-end" + "c3 1" + "c3 2" + "c3 3" + "c3 6" + "c3 5" + "c3 2" + "c3 3" + "c3-end" + "c4 1" + "c4 2" + "c4 3" + "c4 6" + "c4 5" + "c4 2" + "c4 3" + "c4-end" + local: + expect /run-test-result Test (.*)/ capture result + guard (result == "done") + expect /run-done 1 1 0 0/ diff --git a/test/script/network.et b/test/script/network.et new file mode 100644 index 0000000..2978910 --- /dev/null +++ b/test/script/network.et @@ -0,0 +1,28 @@ +module network + +asset scripts: + path: ../asset/network + + +def run_test_from using p (file): + guard (file /= "") # TODO: forces (file :: String) + send "" to p # TODO: forces (p :: Process) + + with p: + send "load $file" + expect /load-done/ + + send "run Test" + expect /run-test-result Test (.*)/ capture result + guard (result == "done") + expect /run-done 1 1 0 0/ + + +test DisconnectNode: + spawn as p + run_test_from using p "${scripts.path}/disconnect_node.et" + + +test DisconnectNodes: + spawn as p + run_test_from using p "${scripts.path}/disconnect_nodes.et" diff --git a/test/script/output.et b/test/script/output.et new file mode 100644 index 0000000..8fb5616 --- /dev/null +++ b/test/script/output.et @@ -0,0 +1,57 @@ +module output + +asset scripts: + path: ../asset/output + +test FlushOutput: + spawn as p + with p: + send "load ${scripts.path}/flush.et" + expect /load-done/ + + send "run Test" + expect /child-stdout p a/ + expect /child-stdout p b/ + expect /child-stdout p c/ + expect /child-stdout p d/ + expect /child-stdout p e/ + expect /match p e/ + expect /ignored p b/ + expect /ignored p c/ + expect /ignored p d/ + expect /match p a/ + expect /match-fail expect.*/ + + expect /run-test-result Test (.*)/ capture result + guard (result == "failed") + expect /run-done 1 0 0 1/ + +test IgnoreOutput: + spawn as p + with p: + send "load ${scripts.path}/ignore.et" + expect /load-done/ + + send "run Test" + expect /child-stdout p a/ + expect /child-stdout p b/ + expect /child-stdout p c/ + expect /child-stdout p d/ + expect /child-stdin p x/ + expect /child-stdout p e/ + expect /child-stdout p F/ + expect /child-stdout p g/ + expect /child-stdout p H/ + expect /match p d/ + expect /ignored p b/ + expect /ignored p c/ + expect /match p a/ + expect /ignored p e/ + expect /match p H/ + expect /ignored p g/ + expect /match p F/ + expect /match-fail expect.*/ + + expect /run-test-result Test (.*)/ capture result + guard (result == "failed") + expect /run-done 1 0 0 1/ diff --git a/test/script/parser.et b/test/script/parser.et new file mode 100644 index 0000000..d387877 --- /dev/null +++ b/test/script/parser.et @@ -0,0 +1,26 @@ +module parser + +asset scripts: + path: ../asset/parser + +def expect_load_success using p of file: + guard (file /= "") # TODO: forces (file :: String) + send "load ${scripts.path}/$file.et" to p + expect /load-([a-z-]+).*/ from p capture done + guard (done == "done") + +def expect_load_failure using p of file giving error: + guard (file /= "") # TODO: forces (file :: String) + send "load ${scripts.path}/$file.et" to p + expect /load-([a-z-]+) ([a-z-]+).*/ from p capture done, msg + guard (done == "failed") + guard (msg == error) + +test Parser: + spawn as p + expect_load_failure using p of "non-existing-file" giving "file-not-found" + expect_load_success using p of "indent" + expect_load_success using p of "function" + expect_load_failure using p of "function-fail" giving "parse-error" + expect_load_success using p of "tags" + expect_load_success using p of "type-annotation" diff --git a/test/script/run.et b/test/script/run.et new file mode 100644 index 0000000..d58746a --- /dev/null +++ b/test/script/run.et @@ -0,0 +1,329 @@ +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-test-result AlwaysSucceeds (.*)/ capture result + guard (result == "done") + expect /run-done ([0-9]+) ([0-9]+) 0 0/ capture total, passed + guard (total == passed) + + send "run AlwaysFails" + local: + expect /match-fail .*/ + expect /run-test-result AlwaysFails (.*)/ capture result + guard (result == "failed") + expect /run-done ([0-9]+) 0 0 ([0-9]+)/ capture total, failed + guard (total == failed) + + +test SimpleRun: + let should_succeed = [ "bool", "command-flush", "command-ignore" ] + let should_fail = [ "bool", "command-ignore" ] + spawn as p + + with p: + for file in should_succeed: + send "load ${scripts_success.path}/$file.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run Test" + local: + expect /run-test-result Test (.*)/ capture result + guard (result == "done") + expect /run-done 1 1 0 0/ + 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-test-result Test (.*)/ capture result + guard (result == "failed") + expect /run-done 1 0 0 1/ + flush + + +test RunConfig: + node n + local: + shell on n: + cp ${scripts.path}/erebos-tester.yaml . + mkdir tools + cp ${scripts.path}/tools/echo.sh ./tools/tool + mkdir scripts + cp ${scripts.path}/trivial.et ./scripts/ + cp ${scripts.path}/echo.et ./scripts/ + + spawn as p on n + + with p: + send "load-config" + expect /load-config-done/ + send "run *" + 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-done 3 2 0 1/ + + +test GetSysInfo: + node n + local: + shell on n: + cp ${scripts.path}/erebos-tester.yaml . + mkdir tools + cp ${scripts.path}/tools/sysinfo.sh ./tools/tool + mkdir scripts + cp ${scripts.path}/sysinfo.et ./scripts/ + + spawn as p on n + + with p: + send "load-config" + expect /load-config-done/ + send "run SysInfo" + expect /run-done 1 1 0 0/ + + +test CallStack: + spawn as p + with p: + send "load ${scripts.path}/callstack.et" + expect /load-done/ + + send "run AG" + expect /match-fail guard failed/ + expect /match-fail-line .*\/callstack.et:3:5: .*/ + expect /match-fail-var x 1/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /run-test-result AG (.*)/ capture result + guard (result == "failed") + expect /run-done 1 0 0 1/ + flush + + send "run AE" + expect /match-fail expect failed/ + expect /match-fail-line .*\/callstack.et:8:5: .*/ + expect /match-fail-var x 2/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /run-test-result AE (.*)/ capture result + guard (result == "failed") + expect /run-done 1 0 0 1/ + flush + + send "run BG" + expect /match-fail guard failed/ + expect /match-fail-line .*\/callstack.et:12:5: .*/ + expect /match-fail-var x 1/ + expect /match-fail-line .*\/callstack.et:15:5: .*/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /run-test-result BG (.*)/ capture result + guard (result == "failed") + expect /run-done 1 0 0 1/ + flush + + send "run CG" + expect /match-fail guard failed/ + expect /match-fail-line .*\/callstack.et:19:5: .*/ + expect /match-fail-var x 3/ + expect /match-fail-var y 2/ + expect /match-fail-line .*\/callstack.et:23:5: .*/ + expect /match-fail-var z 3/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /run-test-result CG (.*)/ capture result + guard (result == "failed") + expect /run-done 1 0 0 1/ + flush + + send "run BE" + expect /match-fail expect failed/ + expect /match-fail-line .*\/callstack.et:27:5: .*/ + expect /match-fail-var x 1/ + expect /match-fail-line .*\/callstack.et:31:5: .*/ + expect /match-fail-var p <process:p#[0-9]+>/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /run-test-result BE (.*)/ capture result + guard (result == "failed") + expect /run-done 1 0 0 1/ + flush + + send "run CE" + expect /match-fail expect failed/ + expect /match-fail-line .*\/callstack.et:36:5: .*/ + expect /match-fail-var x 3/ + expect /match-fail-var y 2/ + expect /match-fail-line .*\/callstack.et:41:5: .*/ + expect /match-fail-var p <process:p#[0-9]+>/ + expect /match-fail-var z 3/ + local: + expect /(match-fail-.*)/ capture done + guard (done == "match-fail-done") + local: + expect /run-test-result CE (.*)/ capture result + guard (result == "failed") + expect /run-done 1 0 0 1/ + flush + + +test RunTag: + spawn as p + with p: + send "load ${scripts.path}/tags.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run A" + local: + expect /run-test-result A1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result A2 (.*)/ capture result + guard (result == "done") + local: + expect /run-(.*)/ capture done + guard (done == "done 2 2 0 0") + + send "run B C" + local: + expect /run-test-result B1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result B2 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result C1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result C2 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result BC (.*)/ capture result + guard (result == "done") + local: + expect /run-(.*)/ capture done + guard (done == "done 5 5 0 0") + + +test RunTagExclude: + spawn as p + with p: + send "load ${scripts.path}/tags.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run * ^A ^C ^T2 ^B1" + local: + expect /run-test-result T1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result B2 (.*)/ capture result + guard (result == "done") + local: + expect /run-(.*)/ capture done + guard (done == "done 2 2 0 0") + + send "run T1 B1 A C ^B ^A1" + local: + expect /run-test-result T1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result A2 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result C1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result C2 (.*)/ capture result + guard (result == "done") + local: + expect /run-(.*)/ capture done + guard (done == "done 4 4 0 0") + + +test RunExcludeConfig1: + node n + local: + shell on n: + cp ${scripts.path}/erebos-tester-select1.yaml erebos-tester.yaml + cp ${scripts.path}/tags.et . + + spawn as p on n + with p: + send "load-config" + expect /load-config-done/ + send "run *" + expect /run-test-result T1 done/ + expect /run-test-result T2 done/ + expect /run-test-result A1 done/ + expect /run-test-result A2 done/ + expect /run-test-result C1 done/ + expect /run-test-result C2 done/ + local: + expect /run-(.*)/ capture done + guard (done == "done 6 6 0 0") + +test RunExcludeConfig2: + node n + local: + shell on n: + cp ${scripts.path}/erebos-tester-select2.yaml erebos-tester.yaml + cp ${scripts.path}/tags.et . + + spawn as p on n + with p: + send "load-config" + expect /load-config-done/ + send "run *" + expect /run-test-result T2 done/ + expect /run-test-result A2 done/ + expect /run-test-result B1 done/ + expect /run-test-result B2 done/ + local: + expect /run-(.*)/ capture done + guard (done == "done 4 4 0 0") diff --git a/test/script/shell.et b/test/script/shell.et new file mode 100644 index 0000000..90ff29a --- /dev/null +++ b/test/script/shell.et @@ -0,0 +1,203 @@ +asset scripts: + path: ../asset/shell + + +test ShellSpawn: + spawn as p + with p: + send "load ${scripts.path}/spawn.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run *" + expect /run-test-result ShellTrue done/ + expect /child-fail sh failed at: .*: false/ + expect /child-fail sh exit code: 1/ + expect /run-test-result ShellFalse failed/ + expect /run-done 2 1 0 1/ + + +def expect_next_stdout from p (expected): + expect from p /child-stdout sh (.*)/ capture line + guard (line == expected) + +test ShellEcho: + spawn as p + with p: + send "load ${scripts.path}/echo.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run *" + + expect_next_stdout from p: + "a b c" + "a b c" + "a b d" + "a b c d" + + "abcd xyz" + "aa bc d" + "b echo c" + + "a b" + "a b" + "\$space_str" + + "\$ \" \\" + "\"\"a" + "' \" \\\\\\ \\" + "a b c" + + "\" ' \\ \$ # | > < ; [ ] { } ( ) * ? ~ & !" + + with p: + expect /run-test-result Echo done/ + expect /run-done 1 1 0 0/ + + +test ShellPipe: + spawn as p + with p: + send "load ${scripts.path}/pipe.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run *" + + expect_next_stdout from p: + "bc" + "b" + with p: + expect /run-test-result Pipe done/ + + expect_next_stdout from p: + "x" + "b" + "c" + "y" + "b" + "c" + "z" + with p: + expect /run-test-result Redirect done/ + + expect_next_stdout from p: + "c" + "e" + "g" + "bcdefg" + with p: + expect /run-test-result PipeRedirect done/ + + with p: + expect /run-done 3 3 0 0/ + + +test ShellWorkingDirectory: + spawn as p + with p: + send "load ${scripts.path}/working-directory.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run *" + + expect from p /child-stdout sh (\/.*)/ capture home + expect_next_stdout from p: + "$home/abc/def" + "$home/abc" + "$home/abc/def/ghi" + "$home/abc" + "$home/abc" + "$home/abc/def/ghi" + "$home/abc/def/ghi" + "$home" + "$home" + "/tmp" + + +test ShellExitOnError: + spawn as p + with p: + send "load ${scripts.path}/error-exit.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + + send "run Default" + expect /child-fail sh failed at: .*error-exit.et:4:9: false/ + expect /run-test-result Default failed/ + expect /run-done 1 0 0 1/ + flush + + send "run DisabledSuccess" + expect /run-test-result DisabledSuccess done/ + expect /run-done 1 1 0 0/ + flush + + send "run DisabledFailure" + expect /run-test-result DisabledFailure failed/ + expect /run-done 1 0 0 1/ + flush + + send "run Enabled" + expect /child-fail sh failed at: .*error-exit.et:25:9: false/ + expect /run-test-result Enabled failed/ + expect /run-done 1 0 0 1/ + flush + + +test ShellLogic: + spawn as p + with p: + send "load ${scripts.path}/logic.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + + send "run NegateFalse" + expect /run-test-result NegateFalse done/ + expect /run-done 1 1 0 0/ + flush + + send "run NegateTrue" + expect /child-fail sh failed at: .*logic.et:9:9: ! true/ + expect /run-test-result NegateTrue failed/ + expect /run-done 1 0 0 1/ + flush + + send "run NegateNothing" + expect /child-fail sh failed at: .*logic.et:14:9: !/ + expect /run-test-result NegateNothing failed/ + expect /run-done 1 0 0 1/ + flush + + +test ShellVariableExpansion: + spawn as p + with p: + send "load ${scripts.path}/expansion.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + + send "run Test" + expect /child-stdout sh A some string B 2 4.5 C/ + expect /child-stdout sh D a b c d e f E/ + expect /child-stdout sh F 1 2 3 4 5 G/ + expect /child-stdout sh H I/ + expect /child-stdout sh w x y z J/ + expect /child-stdout sh w x y z K 1 2 3 4 5 L 2 M < > \| \& \; N/ + expect /child-stdout sh some stringO Psome string/ + expect /run-test-result Test done/ + expect /run-done 1 1 0 0/ + flush |