diff options
45 files changed, 2316 insertions, 857 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 74ef7be..bdfbc83 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,39 @@ # Revision history for erebos-tester +## 0.3.3 -- 2025-06-25 + +* Added optional `timeout` setting to config file +* Added `multiply_timeout` command +* Added `True` and `False` literals, and comparison operators for boolean values +* Added `--exclude` command-line option to exclude tests +* Execute shell commands in appropriate network namespace +* Show name of failed test in output + +## 0.3.2 -- 2025-05-16 + +* Asset files and directories for use during tests +* Select tests from project configuration using only test name on command line without script path +* Added `args` parameter to `spawn` command to pass extra command-line arguments to the spawned tool +* Experimental shell interpreter + +## 0.3.1 -- 2025-03-03 + +* Fix executing test tool given with relative path + +## 0.3.0 -- 2025-02-28 + +* User-defined functions +* Modules, exports and imports +* Added `ifname` member to the `node` type +* Added `>`, `>=`, `<=` and `<` operators for numbers +* Change "flush" command to take regex argument via "matching" keyword +* Change working directory of spawned process to node directory +* Use custom C main instead of wrapper binary for unshare(2) call. +* Fix regex check in flush command +* Time information in output +* Support for GHC up to 9.12 +* Fail when test requested on command-line is not found + ## 0.2.4 -- 2024-08-13 * Fix build with mtl-2.3 @@ -56,14 +56,26 @@ cmake --build build erebos-tester --verbose ``` -To run tests from a given test file, pass it as command-line argument: +To run all tests from project configuration (see below), run the tester without any argument: ``` -erebos-tester path/to/script.test +erebos-tester +``` + +To run only some named tests, list the names on command line: +``` +erebos-tester FirstTest SecondTest +``` + +To run tests from a given test file, pass it as command-line argument (the path +must contain a slash, so use e.g. `./script.et` for script in the current +directory): +``` +erebos-tester path/to/script.et ``` To select single test from a file, use `:` separator: ``` -erebos-tester path/to/script.test:TestName +erebos-tester path/to/script.et:TestName ``` Configuration @@ -76,6 +88,7 @@ This is a YAML file with following fields: * `tool`: path to the test tool, which may be overridden by the `--tool` command-line option. * `tests`: glob pattern that expands to all the test script files that should be used. +* `timeout`: initial timeout for test steps like `expect`, given as `int` or `float`; defaults to `1` if not specified. Script language --------------- @@ -166,6 +179,7 @@ let re2 = /$str$re1/ # match '.' followed by any character #### boolean Result of comparison operators `==` and `/=`. +Values are `True` and `False`. #### network @@ -178,8 +192,11 @@ and used by `spawn` or network configuration commands. Members: +`ifname` +: Name of the primary network interface of the node. + `ip` -: String representation of node's IP address. +: String representation of the node primary IP address. `network` : The network which the node belogs to. @@ -193,6 +210,15 @@ Members: `node` : Node on which the process is running. +#### asset + +Represents an asset (file or directory), which can be used during test execution. + +Members: + +`path` +: Path to the asset valid during the test execution. + #### list Lists are written using bracket notation: @@ -204,7 +230,7 @@ List elements can be of any type, but all elements of a particular list must hav Used in the `for` command. -### Build-in commands +### Built-in commands ``` subnet <name> [of <network>] @@ -219,11 +245,12 @@ node <name> [on <network>] Create a node on network `<network>` (or context network if omitted) and assign the new node to the variable `<name>`. ``` -spawn as <name> [on (<node> | <network>)] +spawn as <name> [on (<node> | <network>)] [args <arguments>] ``` Spawn a new test process on `<node>` or `<network>` (or one from context) and assign the new process to variable `<name>`. When spawning on network, create a new node for this process. +Extra `<arguments>` to the tool can be given as a list of strings using the `args` keyword. The process is terminated when the variable `<name>` goes out of scope (at the end of the block in which it was created) by closing its stdin. When the process fails to terminate successfully within a timeout, the test fails. @@ -310,6 +337,13 @@ with <expr>: Execute `<test block>` with `<expr>` as context. ``` +multiply_timeout by <multiplier> +``` + +Modify the timeout used for commands like `expect` by multiplying it with `<multiplier>`. +The effect lasts until the end of the block. + +``` wait ``` @@ -325,20 +359,15 @@ 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 the -last parameter, as a literal (number, string, etc.), or using parentheses. So this is ok: +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 move to the end: -``` -let re = /something/ -expect from p re -``` - -or be enclosed in parentheses: +but if the regular expression is stored in a variable, the parameter needs to +be enclosed in parentheses: ``` expect (re) from p ``` @@ -352,12 +381,12 @@ expect /$re/ from p 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 twice x = 2 * x +def quadruple of x = 4 * x ``` or followed by `:` to define test block: ``` -def greet p: +def say_hello to p: send "hello" to p expect /hi/ from p ``` @@ -366,9 +395,97 @@ Those then can be invoked elsewhere: ``` test: spawn as p - greet p + say_hello to p +``` + +When defining a function, the unnamed parameter, if any, must be enclosed in +parentheses: +``` +def twice (x) = 2 * x +``` + +### Modules, exports and imports + +Each test script file constitutes a module. As such, it can export definitions +for other modules to use, and import definitions from other modules. The name +of each module must match the filename with the file extension removed, and is +given using the `module` declaration. This declaration, if present, must be +given at the beginning of the file, before other declarations. + +For example a file `test/foo.et` can start with: +``` +module foo +``` +This name is also implicitly assigned when the `module` declaration is omitted. + +In case of a more complex hierarchy, individual parts are separated with `.` +and must match names of parent directories. E.g. a file `test/bar/baz.et` +can start with: + ``` +module bar.baz +``` + +Such declared hierarchy is then used to determine the root of the project in +order to find imported modules. + +To export a definition from module, use `export` keyword before `def`: +``` +export def say_hello to p: + send "hello" to p + expect /hi/ from p +``` +or list the exported name in a standalone export declaration: +``` +export say_hello +... + +def say_hello to p: + send "hello" to p + expect /hi/ from p +``` + +To import module, use `import <name>` statement, which makes all the exported +definitions from the module `<name>` available in the local scope. +``` +module bar.baz + +import foo +``` + +### Assets + +To provide the used test tool with access to auxiliary files needed for the +test execution, asset objects can be defined. The definition is done on the +toplevel using the `asset` keyword, giving the asset object name and a path to +the asset on the filesystem, relative to the directory containing the test +script: + +``` +asset my_asset: + path: ../path/to/file +``` + +Such defined asset object can then be used in expressions within tests or function definitions: + +``` +test: + spawn p + send to p "use-asset ${my_asset.path}" +``` + +The `my_asset.path` expression expands to a string containing path to the asset +that can be used by the spawned process `p`. The process should not try to +modify the file. + +Assets can be exported for use in other modules using the `export` keyword, +just like other definitions: + +``` +export asset my_asset: + path: ../path/to/file +``` Optional dependencies diff --git a/erebos-tester.cabal b/erebos-tester.cabal index c944e83..4fa1939 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: erebos-tester -version: 0.2.4 +version: 0.3.3 synopsis: Test framework with virtual network using Linux namespaces description: This framework is intended mainly for networking libraries/applications and @@ -28,7 +28,7 @@ flag ci source-repository head type: git - location: git://erebosprotocol.net/tester + location: https://code.erebosprotocol.net/tester executable erebos-tester ghc-options: @@ -43,35 +43,48 @@ executable erebos-tester -- sometimes needed for backward/forward compatibility: -Wno-error=unused-imports - main-is: Main.hs + main-is: + Main.hs - other-modules: Config - GDB - Network - Network.Ip - Output - Parser - Parser.Core - Parser.Expr - Parser.Statement - Paths_erebos_tester - Process - Run - Run.Monad - Test - Test.Builtins - Util - Version - Version.Git + other-modules: + Asset + Config + GDB + Network + Network.Ip + Output + Parser + Parser.Core + Parser.Expr + Parser.Shell + Parser.Statement + Paths_erebos_tester + Process + Run + Run.Monad + Script.Expr + Script.Expr.Class + Script.Module + Script.Object + Script.Shell + Script.Var + Test + Test.Builtins + TestMode + Util + Version + Version.Git - autogen-modules: Paths_erebos_tester + autogen-modules: + Paths_erebos_tester - c-sources: + c-sources: src/main.c - other-extensions: + other-extensions: + CPP TemplateHaskell - default-extensions: + default-extensions: DefaultSignatures DeriveTraversable ExistentialQuantification @@ -92,10 +105,11 @@ executable erebos-tester TypeFamilies TypeOperators - build-depends: - base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 }, + build-depends: + base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 }, bytestring ^>= { 0.10, 0.11, 0.12 }, containers ^>= { 0.6.2.1, 0.7 }, + clock ^>= { 0.8.3 }, directory ^>=1.3.6.0, filepath ^>= { 1.4.2.1, 1.5.2 }, Glob >=0.10 && <0.11, @@ -107,10 +121,11 @@ executable erebos-tester process ^>=1.6.9, regex-tdfa ^>=1.3.1.0, scientific >=0.3 && < 0.4, - stm ^>=2.5.0.1, - template-haskell^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22 }, + stm ^>= { 2.5.0 }, + template-haskell^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 }, text ^>= { 1.2, 2.0, 2.1 }, th-compat >=0.1 && <0.2, unix >=2.7 && <2.9, - hs-source-dirs: src - default-language: Haskell2010 + + hs-source-dirs: src + default-language: Haskell2010 diff --git a/erebos-tester.yaml b/erebos-tester.yaml new file mode 100644 index 0000000..2c75d7c --- /dev/null +++ b/erebos-tester.yaml @@ -0,0 +1 @@ +tests: test/script/**/*.et diff --git a/minici.yaml b/minici.yaml index a3f87f5..0813962 100644 --- a/minici.yaml +++ b/minici.yaml @@ -1,3 +1,13 @@ job build: shell: - - cabal build -fci + - cabal build -fci --constraint='megaparsec >= 9.7.0' + - mkdir build + - cp $(cabal list-bin erebos-tester) build/erebos-tester + artifact bin: + path: build/erebos-tester + +job test: + uses: + - build.bin + shell: + - EREBOS_TEST_TOOL='build/erebos-tester --test-mode' erebos-tester --verbose diff --git a/src/Asset.hs b/src/Asset.hs new file mode 100644 index 0000000..72ffd54 --- /dev/null +++ b/src/Asset.hs @@ -0,0 +1,33 @@ +module Asset ( + Asset(..), + AssetPath(..), +) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable + +import Script.Expr.Class + +data Asset = Asset + { assetPath :: AssetPath + } + +newtype AssetPath = AssetPath FilePath + +textAssetPath :: AssetPath -> Text +textAssetPath (AssetPath path) = T.pack path + +instance ExprType Asset where + textExprType _ = "asset" + textExprValue asset = "asset:" <> textAssetPath (assetPath asset) + + recordMembers = + [ ( "path", RecordSelector $ assetPath ) + ] + +instance ExprType AssetPath where + textExprType _ = "filepath" + textExprValue = ("filepath:" <>) . textAssetPath + + exprExpansionConvTo = cast textAssetPath diff --git a/src/Config.hs b/src/Config.hs index 7f5895c..adf0321 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -2,11 +2,13 @@ module Config ( Config(..), findConfig, parseConfig, + getConfigTestFiles, ) where import Control.Monad.Combinators import Data.ByteString.Lazy qualified as BS +import Data.Scientific import Data.Text qualified as T import Data.YAML @@ -16,31 +18,31 @@ import System.FilePath import System.FilePath.Glob data Config = Config - { configTool :: Maybe FilePath - , configTests :: [Pattern] + { configDir :: FilePath + , configTool :: Maybe FilePath + , configTests :: [ Pattern ] + , configTimeout :: Maybe Scientific } deriving (Show) -instance Semigroup Config where - a <> b = Config - { configTool = maybe (configTool b) Just (configTool a) - , configTests = configTests a ++ configTests b - } - -instance Monoid Config where - mempty = Config - { configTool = Nothing - , configTests = [] - } - -instance FromYAML Config where - parseYAML = withMap "Config" $ \m -> Config - <$> (fmap T.unpack <$> m .:? "tool") - <*> (map (compile . T.unpack) <$> foldr1 (<|>) +instance FromYAML (FilePath -> Config) where + parseYAML = withMap "Config" $ \m -> do + configTool <- (fmap T.unpack <$> m .:? "tool") + configTests <- (map (compile . T.unpack) <$> foldr1 (<|>) [ fmap (:[]) (m .: "tests") -- single pattern , m .:? "tests" .!= [] -- list of patterns ] ) + configTimeout <- fmap fromNumber <$> m .:! "timeout" + return $ \configDir -> Config {..} + +newtype Number = Number { fromNumber :: Scientific } + +instance FromYAML Number where + parseYAML = \case + Scalar _ (SFloat x) -> return $ Number $ realToFrac x + Scalar _ (SInt x) -> return $ Number $ fromIntegral x + node -> typeMismatch "int or float" node findConfig :: IO (Maybe FilePath) findConfig = go "." @@ -63,4 +65,7 @@ parseConfig path = do Left (pos, err) -> do putStr $ prettyPosWithSource pos contents err exitFailure - Right conf -> return conf + Right conf -> return $ conf $ takeDirectory path + +getConfigTestFiles :: Config -> IO [ FilePath ] +getConfigTestFiles config = concat <$> mapM (flip globDir1 $ configDir config) (configTests config) @@ -75,7 +75,7 @@ gdbStart onCrash = do let process = Process { procName = ProcNameGDB - , procHandle = handle + , procHandle = Left handle , procStdin = hin , procOutput = pout , procKillWith = Nothing @@ -144,7 +144,7 @@ gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . erro addInferior :: MonadOutput m => GDB -> Process -> m () addInferior gdb process = do - liftIO (getPid $ procHandle process) >>= \case + liftIO (either getPid (\_ -> return Nothing) $ procHandle process) >>= \case Nothing -> outProc OutputError process $ "failed to get PID" Just pid -> do tgid <- liftIO (atomically $ tryReadTChan $ gdbThreadGroups gdb) >>= \case diff --git a/src/Main.hs b/src/Main.hs index 01bb766..b3f7a2a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,8 +2,10 @@ module Main (main) where import Control.Monad +import Data.List import Data.Maybe -import qualified Data.Text as T +import Data.Text (Text) +import Data.Text qualified as T import Text.Read (readMaybe) @@ -12,40 +14,44 @@ import System.Directory import System.Environment import System.Exit import System.FilePath -import System.FilePath.Glob import System.IO import System.Posix.Terminal import System.Posix.Types import Config import Output -import Parser import Process import Run +import Script.Module import Test +import TestMode import Util import Version data CmdlineOptions = CmdlineOptions { optTest :: TestOptions , optRepeat :: Int + , optExclude :: [ Text ] , optVerbose :: Bool , optColor :: Maybe Bool , optShowHelp :: Bool , optShowVersion :: Bool + , optTestMode :: Bool } defaultCmdlineOptions :: CmdlineOptions defaultCmdlineOptions = CmdlineOptions { optTest = defaultTestOptions , optRepeat = 1 + , optExclude = [] , optVerbose = False , optColor = Nothing , optShowHelp = False , optShowVersion = False + , optTestMode = False } -options :: [OptDescr (CmdlineOptions -> CmdlineOptions)] +options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] options = [ Option ['T'] ["tool"] (ReqArg (\str -> to $ \opts -> case break (==':') str of @@ -79,6 +85,9 @@ options = , Option ['r'] ["repeat"] (ReqArg (\str opts -> opts { optRepeat = read str }) "<count>") "number of times to repeat the test(s)" + , Option [ 'e' ] [ "exclude" ] + (ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test>") + "exclude given test from execution" , Option [] ["wait"] (NoArg $ to $ \opts -> opts { optWait = True }) "wait at the end of each test" @@ -92,11 +101,17 @@ options = where to f opts = opts { optTest = f (optTest opts) } +hiddenOptions :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] +hiddenOptions = + [ Option [] [ "test-mode" ] + (NoArg (\opts -> opts { optTestMode = True })) + "test mode" + ] + main :: IO () main = do - configPath <- findConfig - config <- mapM parseConfig configPath - let baseDir = maybe "." dropFileName configPath + config <- mapM parseConfig =<< findConfig + let baseDir = maybe "." configDir config envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool -> return $ fromMaybe (error "No test tool defined") $ mbtool `mplus` (return . (baseDir </>) =<< configTool =<< config) @@ -105,19 +120,26 @@ main = do { optTest = defaultTestOptions { optDefaultTool = envtool , optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions + , optTimeout = fromMaybe (optTimeout defaultTestOptions) $ configTimeout =<< config } } args <- getArgs - (opts, ofiles) <- case getOpt Permute options args of + (opts, oselection) <- case getOpt Permute (options ++ hiddenOptions) args of (o, files, []) -> return (foldl (flip id) initOpts o, files) (_, _, errs) -> do hPutStrLn stderr $ concat errs <> "Try `erebos-tester --help' for more information." exitFailure + let ( ofiles, otests ) + | any (any isPathSeparator) oselection = ( oselection, [] ) + | otherwise = ( [], map T.pack oselection ) + when (optShowHelp opts) $ do let header = unlines - [ "Usage: erebos-tester [<option>...] [<script>[:<test>]...]" + [ "Usage: erebos-tester [<option>...] [<test-name>...]" + , " or: erebos-tester [<option>...] <script>[:<test>]..." + , " <test-name> name of a test from project configuration" , " <script> path to test script file" , " <test> name of the test to run" , "" @@ -130,32 +152,55 @@ main = do putStrLn versionLine exitSuccess - getPermissions (head $ words $ optDefaultTool $ optTest opts) >>= \perms -> do - when (not $ executable perms) $ do - fail $ optDefaultTool (optTest opts) <> " is not executable" + when (optTestMode opts) $ do + testMode config + exitSuccess + + case words $ optDefaultTool $ optTest opts of + (path : _) -> getPermissions path >>= \perms -> do + when (not $ executable perms) $ do + fail $ "‘" <> path <> "’ is not executable" + _ -> fail $ "invalid tool argument: ‘" <> optDefaultTool (optTest opts) <> "’" files <- if not (null ofiles) then return $ flip map ofiles $ \ofile -> case span (/= ':') ofile of (path, ':':test) -> (path, Just $ T.pack test) (path, _) -> (path, Nothing) - else map (, Nothing) . concat <$> mapM (flip globDir1 baseDir) (maybe [] configTests config) + else map (, Nothing) <$> maybe (return []) (getConfigTestFiles) config when (null files) $ fail $ "No test files" useColor <- case optColor opts of Just use -> return use Nothing -> queryTerminal (Fd 1) - out <- startOutput (optVerbose opts) useColor - - tests <- forM files $ \(path, mbTestName) -> do - Module {..} <- parseTestFile path - return $ map ( , moduleDefinitions ) $ case mbTestName of - Nothing -> moduleTests - Just name -> filter ((==name) . testName) moduleTests - - ok <- allM (uncurry $ runTest out $ optTest opts) $ - concat $ replicate (optRepeat opts) $ concat tests + let outputStyle + | optVerbose opts = OutputStyleVerbose + | otherwise = OutputStyleQuiet + out <- startOutput outputStyle useColor + + ( modules, globalDefs ) <- loadModules (map fst files) + tests <- filter ((`notElem` optExclude opts) . testName) <$> if null otests + then fmap concat $ forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do + case mbTestName of + Nothing -> return moduleTests + Just name + | Just test <- find ((name ==) . testName) moduleTests + -> return [ test ] + | otherwise + -> do + hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found in ‘" <> filePath <> "’" + exitFailure + else forM otests $ \name -> if + | Just test <- find ((name ==) . testName) $ concatMap moduleTests modules + -> return test + | otherwise + -> do + hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found" + exitFailure + + ok <- allM (runTest out (optTest opts) globalDefs) $ + concat $ replicate (optRepeat opts) tests when (not ok) exitFailure foreign export ccall testerMain :: IO () diff --git a/src/Network.hs b/src/Network.hs index c841acb..e12231d 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -26,7 +26,8 @@ import System.FilePath import System.Process import Network.Ip -import Test +import Script.Expr +import Script.Expr.Class {- NETWORK STRUCTURE @@ -108,8 +109,9 @@ instance ExprType Node where textExprValue n = T.pack "n:" <> textNodeName (nodeName n) recordMembers = map (first T.pack) - [ ("ip", RecordSelector $ textIpAddress . nodeIp) - , ("network", RecordSelector $ nodeNetwork) + [ ( "ifname", RecordSelector $ const ("veth0" :: Text) ) + , ( "ip", RecordSelector $ textIpAddress . nodeIp ) + , ( "network", RecordSelector $ nodeNetwork ) ] diff --git a/src/Network.hs-boot b/src/Network.hs-boot deleted file mode 100644 index 1b5e9c4..0000000 --- a/src/Network.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Network where - -data Network -data Node -data NodeName diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs index 8f0887a..69a6b43 100644 --- a/src/Network/Ip.hs +++ b/src/Network/Ip.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Network.Ip ( IpPrefix(..), textIpNetwork, @@ -17,7 +19,9 @@ module Network.Ip ( NetworkNamespace, HasNetns(..), addNetworkNamespace, + setNetworkNamespace, textNetnsName, + runInNetworkNamespace, callOn, Link(..), @@ -32,7 +36,9 @@ module Network.Ip ( addRoute, ) where +import Control.Concurrent import Control.Concurrent.STM +import Control.Exception import Control.Monad import Control.Monad.Writer @@ -42,6 +48,11 @@ import Data.Text qualified as T import Data.Typeable import Data.Word +import Foreign.C.Error +import Foreign.C.Types + +import System.Posix.IO +import System.Posix.Types import System.Process newtype IpPrefix = IpPrefix [Word8] @@ -122,12 +133,37 @@ addNetworkNamespace netnsName = do netnsRoutesActive <- liftSTM $ newTVar [] return $ NetworkNamespace {..} +setNetworkNamespace :: MonadIO m => NetworkNamespace -> m () +setNetworkNamespace netns = liftIO $ do + let path = "/var/run/netns/" <> T.unpack (textNetnsName netns) +#if MIN_VERSION_unix(2,8,0) + open = openFd path ReadOnly defaultFileFlags { cloexec = True } +#else + open = openFd path ReadOnly Nothing defaultFileFlags +#endif + res <- bracket open closeFd $ \(Fd fd) -> do + c_setns fd c_CLONE_NEWNET + when (res /= 0) $ do + throwErrno "setns failed" + +foreign import ccall unsafe "sched.h setns" c_setns :: CInt -> CInt -> IO CInt +c_CLONE_NEWNET :: CInt +c_CLONE_NEWNET = 0x40000000 + +runInNetworkNamespace :: NetworkNamespace -> IO a -> IO a +runInNetworkNamespace netns act = do + mvar <- newEmptyMVar + void $ forkOS $ do + setNetworkNamespace netns + putMVar mvar =<< act + takeMVar mvar + + textNetnsName :: NetworkNamespace -> Text textNetnsName = netnsName callOn :: HasNetns a => a -> Text -> IO () -callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> ns <> "\" " <> cmd - where ns = textNetnsName $ getNetns n +callOn n cmd = runInNetworkNamespace (getNetns n) $ callCommand $ T.unpack cmd data Link a = Link diff --git a/src/Output.hs b/src/Output.hs index 135e6e0..7c4a8a5 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -1,14 +1,14 @@ module Output ( - Output, OutputType(..), + Output, OutputStyle(..), OutputType(..), MonadOutput(..), startOutput, + resetOutputTime, outLine, outPromptGetLine, outPromptGetLineCompletion, ) where import Control.Concurrent.MVar -import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader @@ -17,16 +17,21 @@ import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.IO qualified as TL +import System.Clock import System.Console.Haskeline import System.Console.Haskeline.History +import System.IO + +import Text.Printf data Output = Output { outState :: MVar OutputState , outConfig :: OutputConfig + , outStartedAt :: MVar TimeSpec } data OutputConfig = OutputConfig - { outVerbose :: Bool + { outStyle :: OutputStyle , outUseColor :: Bool } @@ -35,15 +40,23 @@ data OutputState = OutputState , outHistory :: History } -data OutputType = OutputChildStdout - | OutputChildStderr - | OutputChildStdin - | OutputChildInfo - | OutputChildFail - | OutputMatch - | OutputMatchFail - | OutputError - | OutputAlways +data OutputStyle + = OutputStyleQuiet + | OutputStyleVerbose + | OutputStyleTest + deriving (Eq) + +data OutputType + = OutputChildStdout + | OutputChildStderr + | OutputChildStdin + | OutputChildInfo + | OutputChildFail + | OutputMatch + | OutputMatchFail + | OutputError + | OutputAlways + | OutputTestRaw class MonadIO m => MonadOutput m where getOutput :: m Output @@ -51,10 +64,17 @@ class MonadIO m => MonadOutput m where instance MonadIO m => MonadOutput (ReaderT Output m) where getOutput = ask -startOutput :: Bool -> Bool -> IO Output -startOutput outVerbose outUseColor = Output - <$> newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory } - <*> pure OutputConfig { .. } +startOutput :: OutputStyle -> Bool -> IO Output +startOutput outStyle outUseColor = do + outState <- newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory } + outConfig <- pure OutputConfig {..} + outStartedAt <- newMVar =<< getTime Monotonic + hSetBuffering stdout LineBuffering + return Output {..} + +resetOutputTime :: Output -> IO () +resetOutputTime Output {..} = do + modifyMVar_ outStartedAt . const $ getTime Monotonic outColor :: OutputType -> Text outColor OutputChildStdout = T.pack "0" @@ -66,6 +86,7 @@ outColor OutputMatch = T.pack "32" outColor OutputMatchFail = T.pack "31" outColor OutputError = T.pack "31" outColor OutputAlways = "0" +outColor OutputTestRaw = "0" outSign :: OutputType -> Text outSign OutputChildStdout = T.empty @@ -77,11 +98,25 @@ outSign OutputMatch = T.pack "+" outSign OutputMatchFail = T.pack "/" outSign OutputError = T.pack "!!" outSign OutputAlways = T.empty +outSign OutputTestRaw = T.empty outArr :: OutputType -> Text outArr OutputChildStdin = "<" outArr _ = ">" +outTestLabel :: OutputType -> Text +outTestLabel = \case + OutputChildStdout -> "child-stdout" + OutputChildStderr -> "child-stderr" + OutputChildStdin -> "child-stdin" + OutputChildInfo -> "child-info" + OutputChildFail -> "child-fail" + OutputMatch -> "match" + OutputMatchFail -> "match-fail" + OutputError -> "error" + OutputAlways -> "other" + OutputTestRaw -> "" + printWhenQuiet :: OutputType -> Bool printWhenQuiet = \case OutputChildStderr -> True @@ -96,10 +131,20 @@ ioWithOutput act = liftIO . act =<< getOutput outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m () outLine otype prompt line = ioWithOutput $ \out -> - when (outVerbose (outConfig out) || printWhenQuiet otype) $ do + case outStyle (outConfig out) of + OutputStyleQuiet + | printWhenQuiet otype -> normalOutput out + | otherwise -> return () + OutputStyleVerbose -> normalOutput out + OutputStyleTest -> testOutput out + where + normalOutput out = do + stime <- readMVar (outStartedAt out) + nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic withMVar (outState out) $ \st -> do outPrint st $ TL.fromChunks $ concat - [ if outUseColor (outConfig out) + [ [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ] + , if outUseColor (outConfig out) then [ T.pack "\ESC[", outColor otype, T.pack "m" ] else [] , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ] @@ -109,6 +154,16 @@ outLine otype prompt line = ioWithOutput $ \out -> else [] ] + testOutput out = do + withMVar (outState out) $ \st -> do + outPrint st $ case otype of + OutputTestRaw -> TL.fromStrict line + _ -> TL.fromChunks + [ outTestLabel otype, " " + , maybe "-" id prompt, " " + , line + ] + outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text) outPromptGetLine = outPromptGetLineCompletion noCompletion diff --git a/src/Parser.hs b/src/Parser.hs index e23b277..9f1a0e3 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,12 +1,15 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Parser ( - parseTestFile, + parseTestFiles, + CustomTestError(..), ) where import Control.Monad +import Control.Monad.Except import Control.Monad.State +import Data.IORef import Data.Map qualified as M import Data.Maybe import Data.Proxy @@ -21,13 +24,16 @@ import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L import System.Directory -import System.Exit import System.FilePath +import System.IO.Error +import Asset import Network import Parser.Core import Parser.Expr import Parser.Statement +import Script.Expr +import Script.Module import Test import Test.Builtins @@ -37,36 +43,37 @@ parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do modify $ \s -> s { testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar } - block (\name steps -> return $ Test name $ mconcat steps) header testStep + block (\name steps -> return $ Test name $ Scope <$> mconcat steps) header testStep where header = do wsymbol "test" lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') -parseDefinition :: TestParser Toplevel -parseDefinition = label "symbol definition" $ toplevel ToplevelDefinition $ do - def <- localState $ L.indentBlock scn $ do +parseDefinition :: Pos -> TestParser ( VarName, SomeExpr ) +parseDefinition href = label "symbol definition" $ do + def@( name, expr ) <- localState $ do wsymbol "def" name <- varName argsDecl <- functionArguments (\off _ -> return . ( off, )) varName mzero (\_ -> return . VarName) atypes <- forM argsDecl $ \( off, vname :: VarName ) -> do tvar <- newTypeVar - modify $ \s -> s { testVars = ( vname, ExprTypeVar tvar ) : testVars s } + modify $ \s -> s { testVars = ( vname, ( LocalVarName vname, ExprTypeVar tvar )) : testVars s } return ( off, vname, tvar ) - choice + SomeExpr expr <- choice [ do osymbol ":" - let finish steps = do - atypes' <- getInferredTypes atypes - ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs (mconcat steps) - return $ L.IndentSome Nothing finish testStep + scn + ref <- L.indentGuard scn GT href + SomeExpr <$> testBlock ref , do osymbol "=" - SomeExpr (expr :: Expr e) <- someExpr - atypes' <- getInferredTypes atypes - L.IndentNone . ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr + someExpr <* eol ] - modify $ \s -> s { testVars = fmap someExprType def : testVars s } + scn + atypes' <- getInferredTypes atypes + sexpr <- SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr + return ( name, sexpr ) + modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } return def where getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do @@ -94,45 +101,124 @@ parseDefinition = label "symbol definition" $ toplevel ToplevelDefinition $ do replaceArgs (SomeExpr e) = SomeExpr (go unif e) e -> e +parseAsset :: Pos -> TestParser ( VarName, SomeExpr ) +parseAsset href = label "asset definition" $ do + wsymbol "asset" + name <- varName + osymbol ":" + void eol + ref <- L.indentGuard scn GT href + + wsymbol "path" + osymbol ":" + off <- stateOffset <$> getParserState + path <- TL.unpack <$> takeWhile1P Nothing (/= '\n') + dir <- takeDirectory <$> gets testSourcePath + absPath <- liftIO (makeAbsolute $ dir </> path) + let assetPath = AssetPath absPath + liftIO (doesPathExist absPath) >>= \case + True -> return () + False -> registerParseError $ FancyError off $ S.singleton $ ErrorCustom $ FileNotFound absPath + + void $ L.indentGuard scn LT ref + let expr = SomeExpr $ Pure Asset {..} + modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } + return ( name, expr ) + +parseExport :: TestParser [ Toplevel ] +parseExport = label "export declaration" $ toplevel id $ do + ref <- L.indentLevel + wsymbol "export" + choice + [ do + def@( name, _ ) <- parseDefinition ref <|> parseAsset ref + return [ ToplevelDefinition def, ToplevelExport name ] + , do + names <- listOf varName + eol >> scn + return $ map ToplevelExport names + ] + +parseImport :: TestParser [ Toplevel ] +parseImport = label "import declaration" $ toplevel (\() -> []) $ do + wsymbol "import" + modName <- parseModuleName + importedModule <- getOrParseModule modName + modify $ \s -> s { testVars = map (fmap (fmap someExprType)) (moduleExportedDefinitions importedModule) ++ testVars s } + eol >> scn + parseTestModule :: FilePath -> TestParser Module parseTestModule absPath = do + scn moduleName <- choice [ label "module declaration" $ do wsymbol "module" off <- stateOffset <$> getParserState - x <- identifier - name <- (x:) <$> many (symbol "." >> identifier) - when (or (zipWith (/=) (reverse name) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do + name@(ModuleName tname) <- parseModuleName + when (or (zipWith (/=) (reverse tname) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "module name does not match file path" eol >> scn return name , do - return $ [ T.pack $ takeBaseName absPath ] + return $ ModuleName [ T.pack $ takeBaseName absPath ] ] - toplevels <- many $ choice - [ parseTestDefinition - , parseDefinition + modify $ \s -> s { testCurrentModuleName = moduleName } + toplevels <- fmap concat $ many $ choice + [ (: []) <$> parseTestDefinition + , (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1) + , (: []) <$> toplevel ToplevelDefinition (parseAsset pos1) + , parseExport + , parseImport ] let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; _ -> Nothing) toplevels moduleDefinitions = catMaybes $ map (\case ToplevelDefinition x -> Just x; _ -> Nothing) toplevels + moduleExports = catMaybes $ map (\case ToplevelExport x -> Just x; _ -> Nothing) toplevels eof 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 (Undefined "void" :: Expr Void) - , testNextTypeVar = 0 - , testTypeUnif = M.empty - } - res = runTestParser path content initState $ parseTestModule absPath +parseTestFiles :: [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] )) +parseTestFiles paths = do + parsedModules <- newIORef [] + runExceptT $ do + requestedModules <- reverse <$> foldM (go parsedModules) [] paths + allModules <- map snd <$> liftIO (readIORef parsedModules) + return ( requestedModules, allModules ) + where + go parsedModules res path = do + liftIO (parseTestFile parsedModules Nothing path) >>= \case + Left err -> do + throwError err + Right cur -> do + return $ cur : res - case res of - Left err -> putStr (errorBundlePretty err) >> exitFailure - Right testModule -> return testModule +parseTestFile :: IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module) +parseTestFile parsedModules mbModuleName path = do + absPath <- makeAbsolute path + (lookup absPath <$> readIORef parsedModules) >>= \case + Just found -> return $ Right found + Nothing -> do + let initState = TestParserState + { testSourcePath = path + , testVars = concat + [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins + ] + , testContext = SomeExpr (Undefined "void" :: Expr Void) + , testNextTypeVar = 0 + , testTypeUnif = M.empty + , testCurrentModuleName = fromMaybe (error "current module name should be set at the beginning of parseTestModule") mbModuleName + , testParseModule = \(ModuleName current) mname@(ModuleName imported) -> do + let projectRoot = iterate takeDirectory absPath !! length current + parseTestFile parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath + } + mbContent <- (Just <$> TL.readFile path) `catchIOError` \e -> + if isDoesNotExistError e then return Nothing else ioError e + case mbContent of + Just content -> do + runTestParser content initState (parseTestModule absPath) >>= \case + Left bundle -> do + return $ Left $ ImportModuleError bundle + Right testModule -> do + modifyIORef parsedModules (( absPath, testModule ) : ) + return $ Right testModule + Nothing -> return $ Left $ maybe (FileNotFound path) ModuleNotFound mbModuleName diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index 5fb4c5f..132dbc8 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -2,7 +2,6 @@ module Parser.Core where import Control.Applicative import Control.Monad -import Control.Monad.Identity import Control.Monad.State import Data.Map (Map) @@ -12,40 +11,72 @@ import Data.Set qualified as S import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Typeable -import Data.Void import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Network () +import Script.Expr +import Script.Module import Test -newtype TestParser a = TestParser (StateT TestParserState (ParsecT Void TestStream Identity) a) +newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a) deriving ( Functor, Applicative, Alternative, Monad , MonadState TestParserState , MonadPlus , MonadFail - , MonadParsec Void TestStream + , MonadIO + , MonadParsec CustomTestError TestStream ) type TestStream = TL.Text -type TestParseError = ParseError TestStream Void +type TestParseError = ParseError TestStream CustomTestError -runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> Either (ParseErrorBundle TestStream Void) a -runTestParser path content initState (TestParser parser) = runIdentity . flip (flip runParserT path) content . flip evalStateT initState $ parser +data CustomTestError + = ModuleNotFound ModuleName + | FileNotFound FilePath + | ImportModuleError (ParseErrorBundle TestStream CustomTestError) + deriving (Eq) + +instance Ord CustomTestError where + compare (ModuleNotFound a) (ModuleNotFound b) = compare a b + compare (ModuleNotFound _) _ = LT + compare _ (ModuleNotFound _) = GT + + compare (FileNotFound a) (FileNotFound b) = compare a b + compare (FileNotFound _) _ = LT + compare _ (FileNotFound _) = GT + + -- Ord instance is required to store errors in Set, but there shouldn't be + -- two ImportModuleErrors at the same possition, so "dummy" comparison + -- should be ok. + compare (ImportModuleError _) (ImportModuleError _) = EQ + +instance ShowErrorComponent CustomTestError where + showErrorComponent (ModuleNotFound name) = "module ‘" <> T.unpack (textModuleName name) <> "’ not found" + showErrorComponent (FileNotFound path) = "file ‘" <> path <> "’ not found" + showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle + +runTestParser :: TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a) +runTestParser content initState (TestParser parser) = flip (flip runParserT (testSourcePath initState)) content . flip evalStateT initState $ parser data Toplevel = ToplevelTest Test | ToplevelDefinition ( VarName, SomeExpr ) + | ToplevelExport VarName + | ToplevelImport ( ModuleName, VarName ) data TestParserState = TestParserState - { testVars :: [ ( VarName, SomeExprType ) ] + { testSourcePath :: FilePath + , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ] , testContext :: SomeExpr , testNextTypeVar :: Int , testTypeUnif :: Map TypeVar SomeExprType + , testCurrentModuleName :: ModuleName + , testParseModule :: ModuleName -> ModuleName -> IO (Either CustomTestError Module) } newTypeVar :: TestParser TypeVar @@ -54,25 +85,36 @@ newTypeVar = do modify $ \s -> s { testNextTypeVar = idx + 1 } return $ TypeVar $ T.pack $ 'a' : show idx -lookupVarType :: Int -> VarName -> TestParser SomeExprType +lookupVarType :: Int -> VarName -> TestParser ( FqVarName, SomeExprType ) lookupVarType off name = do gets (lookup name . testVars) >>= \case Nothing -> do registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "variable not in scope: `" <> textVarName name <> "'" vtype <- ExprTypeVar <$> newTypeVar - modify $ \s -> s { testVars = ( name, vtype ) : testVars s } - return vtype - Just t@(ExprTypeVar tvar) -> do - gets (fromMaybe t . M.lookup tvar . testTypeUnif) + let fqName = LocalVarName name + modify $ \s -> s { testVars = ( name, ( fqName, vtype )) : testVars s } + return ( fqName, vtype ) + Just ( fqName, t@(ExprTypeVar tvar) ) -> do + ( fqName, ) <$> gets (fromMaybe t . M.lookup tvar . testTypeUnif) Just x -> return x lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr lookupVarExpr off sline name = do - lookupVarType off name >>= \case - ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline name :: Expr a) - ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline name - ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline name :: Expr (FunctionType a)) + ( fqn, etype ) <- lookupVarType off name + case etype of + ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a) + ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn + ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a)) + +lookupScalarVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr +lookupScalarVarExpr off sline name = do + ( fqn, etype ) <- lookupVarType off name + case etype of + ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a) + ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn + ExprTypeFunction args (pa :: Proxy a) -> do + SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a)) unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do @@ -204,7 +246,7 @@ localState inner = do put s { testNextTypeVar = testNextTypeVar s', testTypeUnif = testTypeUnif s' } return x -toplevel :: (a -> Toplevel) -> TestParser a -> TestParser Toplevel +toplevel :: (a -> b) -> TestParser a -> TestParser b toplevel f = return . f <=< L.nonIndented scn block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c @@ -221,6 +263,18 @@ listOf item = do x <- item (x:) <$> choice [ symbol "," >> listOf item, return [] ] +blockOf :: Monoid a => Pos -> TestParser a -> TestParser a +blockOf indent step = go + where + go = do + scn + pos <- L.indentLevel + optional eof >>= \case + Just _ -> return mempty + _ | pos < indent -> return mempty + | pos == indent -> mappend <$> step <*> go + | otherwise -> L.incorrectIndent EQ indent pos + getSourceLine :: TestParser SourceLine getSourceLine = do @@ -230,3 +284,12 @@ getSourceLine = do , T.pack ": " , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate ] + + +getOrParseModule :: ModuleName -> TestParser Module +getOrParseModule name = do + current <- gets testCurrentModuleName + parseModule <- gets testParseModule + (TestParser $ lift $ lift $ parseModule current name) >>= \case + Right parsed -> return parsed + Left err -> customFailure err diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index 5ff3f15..b9b5f01 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -1,5 +1,6 @@ module Parser.Expr ( identifier, + parseModuleName, varName, newVarName, @@ -10,6 +11,8 @@ module Parser.Expr ( literal, variable, + stringExpansion, + checkFunctionArguments, functionArguments, ) where @@ -34,11 +37,10 @@ import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L import Text.Megaparsec.Error.Builder qualified as Err -import Text.Regex.TDFA qualified as RE -import Text.Regex.TDFA.Text qualified as RE import Parser.Core -import Test +import Script.Expr +import Script.Expr.Class reservedWords :: [ Text ] reservedWords = @@ -58,6 +60,11 @@ identifier = label "identifier" $ do ] return ident +parseModuleName :: TestParser ModuleName +parseModuleName = do + x <- identifier + ModuleName . (x :) <$> many (symbol "." >> identifier) + varName :: TestParser VarName varName = label "variable name" $ VarName <$> identifier @@ -74,7 +81,7 @@ addVarName off (TypedVarName name) = do Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.pack "variable '" <> textVarName name <> T.pack "' already exists" Nothing -> return () - modify $ \s -> s { testVars = ( name, ExprTypePrim @a Proxy ) : testVars s } + modify $ \s -> s { testVars = ( name, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s } someExpansion :: TestParser SomeExpr someExpansion = do @@ -83,12 +90,12 @@ someExpansion = do [do off <- stateOffset <$> getParserState sline <- getSourceLine name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') - lookupVarExpr off sline name + lookupScalarVarExpr off sline name , between (char '{') (char '}') someExpr ] -stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a) -stringExpansion tname conv = do +expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a) +expressionExpansion tname = do off <- stateOffset <$> getParserState SomeExpr e <- someExpansion let err = do @@ -96,7 +103,10 @@ stringExpansion tname conv = do [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ] return $ Undefined "expansion not defined for type" - maybe err return $ listToMaybe $ catMaybes $ conv e + maybe err (return . (<$> e)) $ listToMaybe $ catMaybes [ cast (id :: a -> a), exprExpansionConvTo, exprExpansionConvFrom ] + +stringExpansion :: TestParser (Expr Text) +stringExpansion = expressionExpansion "string" numberLiteral :: TestParser SomeExpr numberLiteral = label "number" $ lexeme $ do @@ -108,6 +118,13 @@ numberLiteral = label "number" $ lexeme $ do else return $ SomeExpr $ Pure x ] +boolLiteral :: TestParser SomeExpr +boolLiteral = label "bool" $ lexeme $ do + SomeExpr . Pure <$> choice + [ wsymbol "True" *> return True + , wsymbol "False" *> return False + ] + quotedString :: TestParser (Expr Text) quotedString = label "string" $ lexeme $ do void $ char '"' @@ -124,11 +141,7 @@ quotedString = label "string" $ lexeme $ do , char 't' >> return '\t' ] (Pure (T.singleton c) :) <$> inner - ,do e <- stringExpansion (T.pack "string") $ \e -> - [ cast e - , fmap (T.pack . show @Integer) <$> cast e - , fmap (T.pack . show @Scientific) <$> cast e - ] + ,do e <- stringExpansion (e:) <$> inner ] Concat <$> inner @@ -146,19 +159,14 @@ regex = label "regular expression" $ lexeme $ do , anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c]) ] (s:) <$> inner - ,do e <- stringExpansion (T.pack "regex") $ \e -> - [ cast e - , fmap RegexString <$> cast e - , fmap (RegexString . T.pack . show @Integer) <$> cast e - , fmap (RegexString . T.pack . show @Scientific) <$> cast e - ] + ,do e <- expressionExpansion (T.pack "regex") (e:) <$> inner ] parts <- inner let testEval = \case Pure (RegexPart p) -> p _ -> "" - case RE.compile RE.defaultCompOpt RE.defaultExecOpt $ T.concat $ map testEval parts of + case regexCompile $ T.concat $ map testEval parts of Left err -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [ "failed to parse regular expression: ", T.pack err ] Right _ -> return () @@ -260,11 +268,13 @@ someExpr = join inner <?> "expression" [ SomeBinOp ((==) @Integer) , SomeBinOp ((==) @Scientific) , SomeBinOp ((==) @Text) + , SomeBinOp ((==) @Bool) ] , binary' "/=" (\op xs ys -> length xs /= length ys || or (zipWith op xs ys)) $ [ SomeBinOp ((/=) @Integer) , SomeBinOp ((/=) @Scientific) , SomeBinOp ((/=) @Text) + , SomeBinOp ((/=) @Bool) ] , binary ">" $ [ SomeBinOp ((>) @Integer) @@ -346,6 +356,7 @@ typedExpr = do literal :: TestParser SomeExpr literal = label "literal" $ choice [ numberLiteral + , boolLiteral , SomeExpr <$> quotedString , SomeExpr <$> regex , list @@ -385,18 +396,17 @@ recordSelector (SomeExpr expr) = do checkFunctionArguments :: FunctionArguments SomeArgumentType -> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr -checkFunctionArguments (FunctionArguments argTypes) poff kw expr = do +checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr) = do case M.lookup kw argTypes of Just (SomeArgumentType (_ :: ArgumentType expected)) -> do - withRecovery registerParseError $ do - void $ unify poff (ExprTypePrim (Proxy @expected)) (someExprType expr) - return expr + withRecovery (\e -> registerParseError e >> return sexpr) $ do + SomeExpr <$> unifyExpr poff (Proxy @expected) expr Nothing -> do registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $ case kw of - Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword `" <> tkw <> "'" + Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’" Nothing -> "unexpected parameter" - return expr + return sexpr functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b) @@ -415,22 +425,10 @@ functionArguments check param lit promote = do [ T.pack "multiple unnamed parameters" ] parseArgs False - ,do off <- stateOffset <$> getParserState - x <- identifier - choice - [do off' <- stateOffset <$> getParserState - y <- pparam <|> (promote off' =<< identifier) - checkAndInsert off' (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed - - ,if allowUnnamed - then do - y <- promote off x - checkAndInsert off Nothing y $ return M.empty - else do - registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat - [ T.pack "multiple unnamed parameters" ] - return M.empty - ] + ,do x <- identifier + off <- stateOffset <$> getParserState + y <- pparam <|> (promote off =<< identifier) + checkAndInsert off (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed ,do return M.empty ] diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs new file mode 100644 index 0000000..89595e8 --- /dev/null +++ b/src/Parser/Shell.hs @@ -0,0 +1,81 @@ +module Parser.Shell ( + ShellScript, + shellScript, +) where + +import Control.Applicative (liftA2) +import Control.Monad + +import Data.Char +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL + +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L + +import Parser.Core +import Parser.Expr +import Script.Expr +import Script.Shell + +parseArgument :: TestParser (Expr Text) +parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice + [ doubleQuotedString + , singleQuotedString + , escapedChar + , stringExpansion + , unquotedString + ] + where + specialChars = [ '\"', '\\', '$' ] + + unquotedString :: TestParser (Expr Text) + unquotedString = do + Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars) + + doubleQuotedString :: TestParser (Expr Text) + doubleQuotedString = do + void $ char '"' + let inner = choice + [ char '"' >> return [] + , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner + , (:) <$> escapedChar <*> inner + , (:) <$> stringExpansion <*> inner + ] + App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner + + singleQuotedString :: TestParser (Expr Text) + singleQuotedString = do + Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'') + + escapedChar :: TestParser (Expr Text) + escapedChar = do + void $ char '\\' + Pure <$> choice + [ char '\\' >> return "\\" + , char '"' >> return "\"" + , char '$' >> return "$" + , char 'n' >> return "\n" + , char 'r' >> return "\r" + , char 't' >> return "\t" + ] + +parseArguments :: TestParser (Expr [ Text ]) +parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument + +shellStatement :: TestParser (Expr [ ShellStatement ]) +shellStatement = label "shell statement" $ do + line <- getSourceLine + command <- parseArgument + args <- parseArguments + return $ fmap (: []) $ ShellStatement + <$> command + <*> args + <*> pure line + +shellScript :: TestParser (Expr ShellScript) +shellScript = do + indent <- L.indentLevel + fmap ShellScript <$> blockOf indent shellStatement diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 4bed1ef..474fa03 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -1,5 +1,6 @@ module Parser.Statement ( testStep, + testBlock, ) where import Control.Monad @@ -21,11 +22,14 @@ import qualified Text.Megaparsec.Char.Lexer as L import Network (Network, Node) import Parser.Core import Parser.Expr +import Parser.Shell import Process (Process) +import Script.Expr +import Script.Expr.Class import Test import Util -letStatement :: TestParser (Expr TestBlock) +letStatement :: TestParser (Expr (TestBlock ())) letStatement = do line <- getSourceLine indent <- L.indentLevel @@ -40,9 +44,9 @@ letStatement = do addVarName off tname void $ eol body <- testBlock indent - return $ Let line tname e body + return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body) -forStatement :: TestParser (Expr TestBlock) +forStatement :: TestParser (Expr (TestBlock ())) forStatement = do ref <- L.indentLevel wsymbol "for" @@ -65,9 +69,54 @@ forStatement = do body <- testBlock indent return $ (\xs f -> mconcat $ map f xs) <$> (unpack <$> e) - <*> LambdaAbstraction tname body + <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body) -exprStatement :: TestParser (Expr TestBlock) +shellStatement :: TestParser (Expr (TestBlock ())) +shellStatement = do + ref <- L.indentLevel + wsymbol "shell" + parseParams ref Nothing Nothing + + where + parseParamKeyword kw prev = do + off <- stateOffset <$> getParserState + wsymbol kw + when (isJust prev) $ do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "unexpected parameter with keyword ‘" <> kw <> "’" + + parseParams ref mbpname mbnode = choice + [ do + parseParamKeyword "as" mbpname + pname <- newVarName + parseParams ref (Just pname) mbnode + + , do + parseParamKeyword "on" mbnode + node <- typedExpr + parseParams ref mbpname (Just node) + + , do + off <- stateOffset <$> getParserState + symbol ":" + node <- case mbnode of + Just node -> return node + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "missing parameter with keyword ‘on’" + return $ Undefined "" + + void eol + void $ L.indentGuard scn GT ref + script <- shellScript + cont <- fmap Scope <$> testBlock ref + let expr | Just pname <- mbpname = LambdaAbstraction pname cont + | otherwise = const <$> cont + return $ TestBlockStep EmptyTestBlock <$> + (SpawnShell mbpname <$> node <*> script <*> expr) + ] + +exprStatement :: TestParser (Expr (TestBlock ())) exprStatement = do ref <- L.indentLevel off <- stateOffset <$> getParserState @@ -77,11 +126,11 @@ exprStatement = do , unifyExpr off Proxy expr ] where - continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr TestBlock) + continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr (TestBlock ())) continuePartial off ref expr = do symbol ":" void eol - (fun :: Expr (FunctionType TestBlock)) <- unifyExpr off Proxy expr + (fun :: Expr (FunctionType (TestBlock ()))) <- unifyExpr off Proxy expr scn indent <- L.indentGuard scn GT ref blockOf indent $ do @@ -129,7 +178,7 @@ instance ExprType a => ParamType (TypedVarName a) where instance ExprType a => ParamType (Expr a) where parseParam _ = do off <- stateOffset <$> getParserState - SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr + SomeExpr e <- literal <|> between (symbol "(") (symbol ")") someExpr unifyExpr off Proxy e showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" @@ -227,10 +276,10 @@ paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" -newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock } +newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } instance ExprType a => ParamType (InnerBlock a) where - type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr TestBlock ) + type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr (TestBlock ()) ) parseParam _ = mzero showParamType _ = "<code block>" paramExpr ( vars, expr ) = fmap InnerBlock $ helper vars $ const <$> expr @@ -242,14 +291,14 @@ instance ExprType a => ParamType (InnerBlock a) where combine f (x : xs) = f x xs combine _ [] = error "inner block parameter count mismatch" -innerBlock :: CommandDef TestBlock +innerBlock :: CommandDef (TestStep ()) innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun -innerBlockFun :: ExprType a => CommandDef (a -> TestBlock) +innerBlockFun :: ExprType a => CommandDef (a -> TestStep ()) innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList -innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock) -innerBlockFunList = fromInnerBlock <$> param "" +innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ()) +innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param "" newtype ExprParam a = ExprParam { fromExprParam :: a } deriving (Functor, Foldable, Traversable) @@ -263,7 +312,7 @@ instance ExprType a => ParamType (ExprParam a) where showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" paramExpr = fmap ExprParam -command :: String -> CommandDef TestStep -> TestParser (Expr TestBlock) +command :: String -> CommandDef (TestStep ()) -> TestParser (Expr (TestBlock ())) command name (CommandDef types ctor) = do indent <- L.indentLevel line <- getSourceLine @@ -271,7 +320,7 @@ command name (CommandDef types ctor) = do localState $ do restOfLine indent [] line $ map (fmap $ \(SomeParam p@(_ :: Proxy p) Proxy) -> SomeParam p $ Nothing @(ParamRep p)) types where - restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr TestBlock) + restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr (TestBlock ())) restOfLine cmdi partials line params = choice [do void $ lookAhead eol let definedVariables = mconcat $ map (someParamVars . snd) params @@ -288,7 +337,7 @@ command name (CommandDef types ctor) = do , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p ] (_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x - return $ (TestBlock . (: [])) <$> ctor iparams + return $ (TestBlockStep EmptyTestBlock) <$> ctor iparams ,do symbol ":" scn @@ -298,7 +347,7 @@ command name (CommandDef types ctor) = do ,do tryParams cmdi partials line [] params ] - restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr TestBlock) + restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr (TestBlock ())) restOfParts cmdi [] = testBlock cmdi restOfParts cmdi partials@((partIndent, params) : rest) = do scn @@ -324,7 +373,7 @@ command name (CommandDef types ctor) = do ] tryParams _ _ _ _ [] = mzero -testLocal :: TestParser (Expr TestBlock) +testLocal :: TestParser (Expr (TestBlock ())) testLocal = do ref <- L.indentLevel wsymbol "local" @@ -332,9 +381,10 @@ testLocal = do void $ eol indent <- L.indentGuard scn GT ref - localState $ testBlock indent + localState $ do + fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent -testWith :: TestParser (Expr TestBlock) +testWith :: TestParser (Expr (TestBlock ())) testWith = do ref <- L.indentLevel wsymbol "with" @@ -358,27 +408,28 @@ testWith = do indent <- L.indentGuard scn GT ref localState $ do modify $ \s -> s { testContext = ctx } - testBlock indent + fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent -testSubnet :: TestParser (Expr TestBlock) +testSubnet :: TestParser (Expr (TestBlock ())) testSubnet = command "subnet" $ Subnet <$> param "" <*> (fromExprParam <$> paramOrContext "of") <*> innerBlockFun -testNode :: TestParser (Expr TestBlock) +testNode :: TestParser (Expr (TestBlock ())) testNode = command "node" $ DeclNode <$> param "" <*> (fromExprParam <$> paramOrContext "on") <*> innerBlockFun -testSpawn :: TestParser (Expr TestBlock) +testSpawn :: TestParser (Expr (TestBlock ())) testSpawn = command "spawn" $ Spawn <$> param "as" <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") + <*> (maybe [] fromExprParam <$> param "args") <*> innerBlockFun -testExpect :: TestParser (Expr TestBlock) +testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect <$> cmdLine <*> (fromExprParam <$> paramOrContext "from") @@ -386,47 +437,36 @@ testExpect = command "expect" $ Expect <*> param "capture" <*> innerBlockFunList -testDisconnectNode :: TestParser (Expr TestBlock) +testDisconnectNode :: TestParser (Expr (TestBlock ())) testDisconnectNode = command "disconnect_node" $ DisconnectNode <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectNodes :: TestParser (Expr TestBlock) +testDisconnectNodes :: TestParser (Expr (TestBlock ())) testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectUpstream :: TestParser (Expr TestBlock) +testDisconnectUpstream :: TestParser (Expr (TestBlock ())) testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testPacketLoss :: TestParser (Expr TestBlock) +testPacketLoss :: TestParser (Expr (TestBlock ())) testPacketLoss = command "packet_loss" $ PacketLoss <$> (fromExprParam <$> paramOrContext "") <*> (fromExprParam <$> paramOrContext "on") <*> innerBlock -testBlock :: Pos -> TestParser (Expr TestBlock) +testBlock :: Pos -> TestParser (Expr (TestBlock ())) testBlock indent = blockOf indent testStep -blockOf :: Monoid a => Pos -> TestParser a -> TestParser a -blockOf indent step = go - where - go = do - scn - pos <- L.indentLevel - optional eof >>= \case - Just _ -> return mempty - _ | pos < indent -> return mempty - | pos == indent -> mappend <$> step <*> go - | otherwise -> L.incorrectIndent EQ indent pos - -testStep :: TestParser (Expr TestBlock) +testStep :: TestParser (Expr (TestBlock ())) testStep = choice [ letStatement , forStatement + , shellStatement , testLocal , testWith , testSubnet diff --git a/src/Process.hs b/src/Process.hs index 376b1ba..31641c9 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -7,6 +7,7 @@ module Process ( lineReadingLoop, spawnOn, closeProcess, + closeTestProcess, withProcess, ) where @@ -18,11 +19,15 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Function +import Data.Scientific import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Data.Text qualified as T +import Data.Text.IO qualified as T +import System.Directory +import System.Environment import System.Exit +import System.FilePath import System.IO import System.IO.Error import System.Posix.Signals @@ -33,11 +38,11 @@ import Network import Network.Ip import Output import Run.Monad -import Test +import Script.Expr.Class data Process = Process { procName :: ProcName - , procHandle :: ProcessHandle + , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode ) , procStdin :: Handle , procOutput :: TVar [Text] , procKillWith :: Maybe Signal @@ -89,28 +94,40 @@ lineReadingLoop process h act = spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process spawnOn target pname killWith cmd = do + -- When executing command given with relative path, turn it to absolute one, + -- because working directory will be changed for the shell wrapper. + cmd' <- liftIO $ do + case span (/= ' ') cmd of + ( path, rest ) + | any isPathSeparator path && isRelative path + -> do + path' <- makeAbsolute path + return (path' ++ rest) + _ -> return cmd + let netns = either getNetns getNetns target - let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" " - (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd) - { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe - , cwd = Just (either netDir nodeDir target) - , env = Just [ ( "EREBOS_DIR", "." ) ] - } + currentEnv <- liftIO $ getEnvironment + (Just hin, Just hout, Just herr, handle) <- liftIO $ do + runInNetworkNamespace netns $ createProcess (shell cmd') + { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe + , cwd = Just (either netDir nodeDir target) + , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv + } pout <- liftIO $ newTVarIO [] let process = Process { procName = pname - , procHandle = handle + , procHandle = Left handle , procStdin = hin , procOutput = pout , procKillWith = killWith , procNode = either (const undefined) id target } - forkTest $ lineReadingLoop process hout $ \line -> do + void $ forkTest $ lineReadingLoop process hout $ \line -> do outProc OutputChildStdout process line liftIO $ atomically $ modifyTVar pout (++[line]) - forkTest $ lineReadingLoop process herr $ \line -> do + void $ forkTest $ lineReadingLoop process herr $ \line -> do case pname of ProcNameTcpdump -> return () _ -> outProc OutputChildStderr process line @@ -121,24 +138,29 @@ spawnOn target pname killWith cmd = do return process -closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m () -closeProcess p = do +closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Scientific -> Process -> m () +closeProcess timeout p = do liftIO $ hClose $ procStdin p case procKillWith p of Nothing -> return () - Just sig -> liftIO $ getPid (procHandle p) >>= \case + Just sig -> liftIO $ either getPid (\_ -> return Nothing) (procHandle p) >>= \case Nothing -> return () Just pid -> signalProcess sig pid liftIO $ void $ forkIO $ do - threadDelay 1000000 - terminateProcess $ procHandle p - liftIO (waitForProcess (procHandle p)) >>= \case + threadDelay $ floor $ 1000000 * timeout + either terminateProcess (killThread . fst) $ procHandle p + liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) >>= \case ExitSuccess -> return () ExitFailure code -> do outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code throwError Failed +closeTestProcess :: Process -> TestRun () +closeTestProcess process = do + timeout <- liftIO . readMVar =<< asks (teTimeout . fst) + closeProcess timeout process + withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a withProcess target pname killWith cmd inner = do procVar <- asks $ teProcesses . fst @@ -148,5 +170,5 @@ withProcess target pname killWith cmd inner = do inner process `finally` do ps <- liftIO $ takeMVar procVar - closeProcess process `finally` do + closeTestProcess process `finally` do liftIO $ putMVar procVar $ filter (/=process) ps @@ -1,6 +1,8 @@ module Run ( module Run.Monad, runTest, + loadModules, + evalGlobalDefs, ) where import Control.Applicative @@ -8,14 +10,18 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Monad import Control.Monad.Except +import Control.Monad.Fix import Control.Monad.Reader +import Control.Monad.Writer +import Data.Bifunctor import Data.Map qualified as M import Data.Maybe -import Data.Set qualified as S +import Data.Proxy import Data.Scientific +import Data.Set qualified as S import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import System.Directory import System.Exit @@ -24,17 +30,25 @@ import System.Posix.Process import System.Posix.Signals import System.Process +import Text.Megaparsec (errorBundlePretty, showErrorComponent) + import GDB import Network import Network.Ip import Output +import Parser import Process import Run.Monad +import Script.Expr +import Script.Module +import Script.Object +import Script.Shell import Test import Test.Builtins -runTest :: Output -> TestOptions -> Test -> [ ( VarName, SomeExpr ) ] -> IO Bool -runTest out opts test variables = do + +runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool +runTest out opts gdefs test = do let testDir = optTestDir opts when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e -> if isDoesNotExistError e then return () else ioError e @@ -43,7 +57,9 @@ runTest out opts test variables = do createDirectoryIfMissing True testDir failedVar <- newTVarIO Nothing + objIdVar <- newMVar 1 procVar <- newMVar [] + timeoutVar <- newMVar $ optTimeout opts mgdb <- if optGDB opts then flip runReaderT out $ do @@ -55,11 +71,14 @@ runTest out opts test variables = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teNextObjId = objIdVar , teProcesses = procVar + , teTimeout = timeoutVar , teGDB = fst <$> mgdb } tstate = TestState - { tsVars = builtins + { tsGlobals = gdefs + , tsLocals = [] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty @@ -68,7 +87,7 @@ runTest out opts test variables = do let sigHandler SignalInfo { siginfoSpecific = chld } = do processes <- readMVar procVar forM_ processes $ \p -> do - mbpid <- getPid (procHandle p) + mbpid <- either getPid (\_ -> return Nothing) (procHandle p) when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do let err detail = outProc OutputChildFail p detail case siginfoStatus chld of @@ -82,23 +101,17 @@ runTest out opts test variables = do Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing - let withVarExprList (( name, expr ) : rest) act = do - value <- evalSome expr - local (fmap $ \s -> s { tsVars = ( name, value ) : tsVars s }) $ do - withVarExprList rest act - withVarExprList [] act = act - - res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do - withVarExprList variables $ do - withInternet $ \_ -> do - evalBlock =<< eval (testSteps test) - when (optWait opts) $ do - void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + resetOutputTime out + ( res, [] ) <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do + withInternet $ \_ -> do + runStep =<< eval (testSteps test) + when (optWait opts) $ do + void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." 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) @@ -106,17 +119,56 @@ runTest out opts test variables = do (Right (), Nothing) -> do when (not $ optKeep opts) $ removeDirectoryRecursive testDir return True - _ -> return False + _ -> do + flip runReaderT out $ do + void $ outLine OutputError Nothing $ "Test ‘" <> testName test <> "’ failed." + return False + + +loadModules :: [ FilePath ] -> IO ( [ Module ], GlobalDefs ) +loadModules files = do + ( modules, allModules ) <- parseTestFiles files >>= \case + Right res -> do + return res + Left err -> do + case err of + ImportModuleError bundle -> + putStr (errorBundlePretty bundle) + _ -> do + putStrLn (showErrorComponent err) + exitFailure + let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules + return ( modules, globalDefs ) + + +evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs +evalGlobalDefs exprs = fix $ \gdefs -> + builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs) + +runBlock :: TestBlock () -> TestRun () +runBlock EmptyTestBlock = return () +runBlock (TestBlockStep prev step) = runBlock prev >> runStep step + +runStep :: TestStep () -> TestRun () +runStep = \case + Scope block -> do + ( x, objs ) <- censor (const []) $ listen $ catchError (Right <$> runBlock block) (return . Left) + mapM_ destroySomeObject (reverse objs) + either throwError return x + + CreateObject (Proxy :: Proxy o) cargs -> do + objIdVar <- asks (teNextObjId . fst) + oid <- liftIO $ modifyMVar objIdVar (\x -> return ( x + 1, x )) + obj <- createObject @TestRun @o (ObjectId oid) cargs + tell [ toSomeObject obj ] -evalBlock :: TestBlock -> TestRun () -evalBlock (TestBlock steps) = forM_ steps $ \case Subnet name parent inner -> do - withSubnet parent (Just name) $ evalBlock . inner + withSubnet parent (Just name) $ runStep . inner DeclNode name net inner -> do - withNode net (Left name) $ evalBlock . inner + withNode net (Left name) $ runStep . inner - Spawn tvname@(TypedVarName (VarName tname)) target inner -> do + Spawn tvname@(TypedVarName (VarName tname)) target args inner -> do case target of Left net -> withNode net (Right tvname) go Right node -> go node @@ -125,14 +177,22 @@ evalBlock (TestBlock steps) = forM_ steps $ \case opts <- asks $ teOptions . fst let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) - withProcess (Right node) pname Nothing tool $ evalBlock . inner + cmd = unwords $ tool : map (T.unpack . escape) args + escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" + withProcess (Right node) pname Nothing cmd $ runStep . inner + + SpawnShell mbname node script inner -> do + let tname | Just (TypedVarName (VarName name)) <- mbname = name + | otherwise = "shell" + let pname = ProcName tname + withShellProcess node pname script $ runStep . inner Send p line -> do outProc OutputChildStdin p line send p line Expect line p expr captures inner -> do - expect line p expr captures $ evalBlock . inner + expect line p expr captures $ runStep . inner Flush p regex -> do flush p regex @@ -141,18 +201,18 @@ evalBlock (TestBlock steps) = forM_ steps $ \case testStepGuard line vars expr DisconnectNode node inner -> do - withDisconnectedUp (nodeUpstream node) $ evalBlock inner + withDisconnectedUp (nodeUpstream node) $ runStep inner DisconnectNodes net inner -> do - withDisconnectedBridge (netBridge net) $ evalBlock inner + withDisconnectedBridge (netBridge net) $ runStep inner DisconnectUpstream net inner -> do case netUpstream net of - Just link -> withDisconnectedUp link $ evalBlock inner - Nothing -> evalBlock inner + Just link -> withDisconnectedUp link $ runStep inner + Nothing -> runStep inner PacketLoss loss node inner -> do - withNodePacketLoss node loss $ evalBlock inner + withNodePacketLoss node loss $ runStep inner Wait -> do void $ outPromptGetLine "Waiting..." @@ -248,14 +308,14 @@ exprFailed desc sline pname exprVars = do outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", textSourceLine sline] forM_ exprVars $ \((name, sel), value) -> outLine OutputMatchFail (Just prompt) $ T.concat - [ " ", textVarName name, T.concat (map ("."<>) sel) + [ " ", textFqVarName name, T.concat (map ("."<>) sel) , " = ", textSomeVarValue sline value ] throwError Failed expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun () expect sline p (Traced trace re) tvars inner = do - timeout <- asks $ optTimeout . teOptions . fst + timeout <- liftIO . readMVar =<< asks (teTimeout . fst) delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do line <- readTVar (procOutput p) @@ -272,12 +332,6 @@ expect sline p (Traced trace re) tvars inner = do outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline throwError Failed - forM_ vars $ \name -> do - cur <- asks (lookup name . tsVars . snd) - when (isJust cur) $ do - outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` textSourceLine sline - throwError Failed - outProc OutputMatch p line inner capture diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 3739e2e..f681e99 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -7,6 +7,7 @@ module Run.Monad ( finally, forkTest, + forkTestUsing, ) where import Control.Concurrent @@ -14,31 +15,41 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Control.Monad.Writer import Data.Map (Map) -import Data.Set (Set) import Data.Scientific -import qualified Data.Text as T +import Data.Set (Set) +import Data.Text qualified as T import {-# SOURCE #-} GDB import Network.Ip import Output import {-# SOURCE #-} Process -import Test +import Script.Expr +import Script.Object -newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a } - deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO) +newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed (WriterT [ SomeObject TestRun ] IO)) a } + deriving + ( Functor, Applicative, Monad + , MonadReader ( TestEnv, TestState ) + , MonadWriter [ SomeObject TestRun ] + , MonadIO + ) data TestEnv = TestEnv { teOutput :: Output , teFailed :: TVar (Maybe Failed) , teOptions :: TestOptions - , teProcesses :: MVar [Process] + , teNextObjId :: MVar Int + , teProcesses :: MVar [ Process ] + , teTimeout :: MVar Scientific , teGDB :: Maybe (MVar GDB) } data TestState = TestState - { tsVars :: [(VarName, SomeVarValue)] + { tsGlobals :: GlobalDefs + , tsLocals :: [ ( VarName, SomeVarValue ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific @@ -91,8 +102,9 @@ instance MonadError Failed TestRun where catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler instance MonadEval TestRun where - askDictionary = asks (tsVars . snd) - withDictionary f = local (fmap $ \s -> s { tsVars = f (tsVars s) }) + askGlobalDefs = asks (tsGlobals . snd) + askDictionary = asks (tsLocals . snd) + withDictionary f = local (fmap $ \s -> s { tsLocals = f (tsLocals s) }) instance MonadOutput TestRun where getOutput = asks $ teOutput . fst @@ -107,10 +119,14 @@ finally act handler = do void handler return x -forkTest :: TestRun () -> TestRun () -forkTest act = do +forkTest :: TestRun () -> TestRun ThreadId +forkTest = forkTestUsing forkIO + +forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId +forkTestUsing fork act = do tenv <- ask - void $ liftIO $ forkIO $ do - runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case + liftIO $ fork $ do + ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act) + case res of Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e) Right () -> return () diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs new file mode 100644 index 0000000..ced807c --- /dev/null +++ b/src/Script/Expr.hs @@ -0,0 +1,452 @@ +module Script.Expr ( + Expr(..), varExpr, mapExpr, + + MonadEval(..), VariableDictionary, GlobalDefs, + lookupVar, tryLookupVar, withVar, withTypedVar, + eval, evalSome, evalSomeWith, + + FunctionType, DynamicType, + ExprType(..), SomeExpr(..), + TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, + + VarValue(..), SomeVarValue(..), + svvVariables, svvArguments, + someConstValue, fromConstValue, + fromSomeVarValue, textSomeVarValue, someVarValueType, + + ArgumentKeyword(..), FunctionArguments(..), + anull, exprArgs, + SomeArgumentType(..), ArgumentType(..), + + Traced(..), EvalTrace, VarNameSelectors, gatherVars, + AppAnnotation(..), + + module Script.Var, + + Regex(RegexPart, RegexString), + regexCompile, regexMatch, +) where + +import Control.Monad +import Control.Monad.Reader + +import Data.Char +import Data.Foldable +import Data.List +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe +import Data.Scientific +import Data.String +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable + +import Text.Regex.TDFA qualified as RE +import Text.Regex.TDFA.Text qualified as RE + +import Script.Expr.Class +import Script.Var +import Util + + +data Expr a where + Let :: forall a b. ExprType b => SourceLine -> TypedVarName b -> Expr b -> Expr a -> Expr a + Variable :: ExprType a => SourceLine -> FqVarName -> Expr a + DynVariable :: TypeVar -> SourceLine -> FqVarName -> Expr DynamicType + FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> FqVarName -> Expr (FunctionType a) + ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a) + ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) + FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a) + FunctionEval :: ExprType a => Expr (FunctionType a) -> Expr a + LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b) + Pure :: a -> Expr a + App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b + Concat :: [ Expr Text ] -> Expr Text + Regex :: [ Expr Regex ] -> Expr Regex + Undefined :: String -> Expr a + Trace :: Expr a -> Expr (Traced a) + +data AppAnnotation b = AnnNone + | ExprType b => AnnRecord Text + +instance Functor Expr where + fmap f x = Pure f <*> x + +instance Applicative Expr where + pure = Pure + (<*>) = App AnnNone + +instance Semigroup a => Semigroup (Expr a) where + e <> f = (<>) <$> e <*> f + +instance Monoid a => Monoid (Expr a) where + mempty = Pure mempty + +varExpr :: ExprType a => SourceLine -> TypedVarName a -> Expr a +varExpr sline (TypedVarName name) = Variable sline (LocalVarName name) + +mapExpr :: forall a. (forall b. Expr b -> Expr b) -> Expr a -> Expr a +mapExpr f = go + where + go :: forall c. Expr c -> Expr c + go = \case + Let sline vname vval expr -> f $ Let sline vname (go vval) (go expr) + e@Variable {} -> f e + e@DynVariable {} -> f e + e@FunVariable {} -> f e + ArgsReq args expr -> f $ ArgsReq args (go expr) + ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr) + FunctionAbstraction expr -> f $ FunctionAbstraction (go expr) + FunctionEval expr -> f $ FunctionEval (go expr) + LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr) + e@Pure {} -> f e + App ann efun earg -> f $ App ann (go efun) (go earg) + e@Concat {} -> f e + e@Regex {} -> f e + e@Undefined {} -> f e + Trace expr -> f $ Trace (go expr) + + + +class MonadFail m => MonadEval m where + askGlobalDefs :: m GlobalDefs + askDictionary :: m VariableDictionary + withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a + +type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue + +type VariableDictionary = [ ( VarName, SomeVarValue ) ] + +lookupVar :: MonadEval m => FqVarName -> m SomeVarValue +lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name + +tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue) +tryLookupVar (LocalVarName name) = lookup name <$> askDictionary +tryLookupVar (GlobalVarName mname var) = M.lookup ( mname, var ) <$> askGlobalDefs + +withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a +withVar name value = withDictionary (( name, someConstValue value ) : ) + +withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a +withTypedVar (TypedVarName name) = withVar name + +isInternalVar :: FqVarName -> Bool +isInternalVar (GlobalVarName {}) = False +isInternalVar (LocalVarName (VarName name)) + | Just ( '$', _ ) <- T.uncons name = True + | otherwise = False + + +newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a) + deriving (Functor, Applicative, Monad) + +runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a +runSimpleEval (SimpleEval x) = curry $ runReader x + +instance MonadFail SimpleEval where + fail = error . ("eval failed: " <>) + +instance MonadEval SimpleEval where + askGlobalDefs = SimpleEval (asks fst) + askDictionary = SimpleEval (asks snd) + withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner) + +eval :: forall m a. MonadEval m => Expr a -> m a +eval = \case + Let _ (TypedVarName name) valExpr expr -> do + val <- eval valExpr + withVar name val $ eval expr + Variable sline name -> fromSomeVarValue sline name =<< lookupVar name + DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’" + FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name + ArgsReq (FunctionArguments req) efun -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ FunctionType $ \(FunctionArguments args) -> + let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req + FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict) + in fun $ FunctionArguments $ args `M.difference` req + ArgsApp eargs efun -> do + FunctionType fun <- eval efun + args <- mapM evalSome eargs + return $ FunctionType $ \args' -> fun (args <> args') + FunctionAbstraction expr -> do + val <- eval expr + return $ FunctionType $ const val + FunctionEval efun -> do + FunctionType fun <- eval efun + return $ fun mempty + LambdaAbstraction (TypedVarName name) expr -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict) + Pure value -> return value + App _ f x -> eval f <*> eval x + Concat xs -> T.concat <$> mapM eval xs + Regex xs -> mapM eval xs >>= \case + [ re@RegexCompiled {} ] -> return re + parts -> case regexCompile $ T.concat $ map regexSource parts of + Left err -> fail err + Right re -> return re + Undefined err -> fail err + Trace expr -> Traced <$> gatherVars expr <*> eval expr + +evalToVarValue :: MonadEval m => Expr a -> m (VarValue a) +evalToVarValue expr = do + VarValue + <$> gatherVars expr + <*> pure mempty + <*> (const . const <$> eval expr) + +evalFunToVarValue :: MonadEval m => Expr (FunctionType a) -> m (VarValue a) +evalFunToVarValue expr = do + FunctionType fun <- eval expr + VarValue + <$> gatherVars expr + <*> pure (exprArgs expr) + <*> pure (const fun) + +evalSome :: MonadEval m => SomeExpr -> m SomeVarValue +evalSome (SomeExpr expr) + | IsFunType <- asFunType expr = SomeVarValue <$> evalFunToVarValue expr + | otherwise = SomeVarValue <$> evalToVarValue expr + +evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue +evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs [] + + +data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a) + +instance ExprType a => ExprType (FunctionType a) where + textExprType _ = "function type" + textExprValue _ = "<function type>" + +data DynamicType + +instance ExprType DynamicType where + textExprType _ = "ambiguous type" + textExprValue _ = "<dynamic type>" + + +data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) + +newtype TypeVar = TypeVar Text + deriving (Eq, Ord) + +data SomeExprType + = forall a. ExprType a => ExprTypePrim (Proxy a) + | ExprTypeVar TypeVar + | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a) + +someExprType :: SomeExpr -> SomeExprType +someExprType (SomeExpr expr) = go expr + where + go :: forall e. ExprType e => Expr e -> SomeExprType + go = \case + DynVariable tvar _ _ -> ExprTypeVar tvar + (e :: Expr a) + | IsFunType <- asFunType e -> ExprTypeFunction (gof e) (proxyOfFunctionType e) + | otherwise -> ExprTypePrim (Proxy @a) + + gof :: forall e. ExprType e => Expr (FunctionType e) -> FunctionArguments SomeArgumentType + gof = \case + Let _ _ _ body -> gof body + Variable {} -> error "someExprType: gof: variable" + FunVariable params _ _ -> params + ArgsReq args body -> fmap snd args <> gof body + ArgsApp (FunctionArguments used) body -> + let FunctionArguments args = gof body + in FunctionArguments $ args `M.difference` used + FunctionAbstraction {} -> mempty + FunctionEval {} -> error "someExprType: gof: function eval" + Pure {} -> error "someExprType: gof: pure" + App {} -> error "someExprType: gof: app" + Undefined {} -> error "someExprType: gof: undefined" + + proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a + proxyOfFunctionType _ = Proxy + +textSomeExprType :: SomeExprType -> Text +textSomeExprType (ExprTypePrim p) = textExprType p +textSomeExprType (ExprTypeVar (TypeVar name)) = name +textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r + +data AsFunType a + = forall b. (a ~ FunctionType b, ExprType b) => IsFunType + | NotFunType + +asFunType :: Expr a -> AsFunType a +asFunType = \case + Let _ _ _ expr -> asFunType expr + FunVariable {} -> IsFunType + ArgsReq {} -> IsFunType + ArgsApp {} -> IsFunType + FunctionAbstraction {} -> IsFunType + _ -> NotFunType + + +data VarValue a = VarValue + { vvVariables :: EvalTrace + , vvArguments :: FunctionArguments SomeArgumentType + , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a + } + +data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a) + +svvVariables :: SomeVarValue -> EvalTrace +svvVariables (SomeVarValue vv) = vvVariables vv + +svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType +svvArguments (SomeVarValue vv) = vvArguments vv + +someConstValue :: ExprType a => a -> SomeVarValue +someConstValue = SomeVarValue . VarValue [] mempty . const . const + +fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> VarValue a -> m a +fromConstValue sline name (VarValue _ args value :: VarValue b) = do + maybe (fail err) return $ do + guard $ anull args + cast $ value sline mempty + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] + +fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m a +fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do + maybe (fail err) return $ do + guard $ anull args + cast $ value sline mempty + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] + +textSomeVarValue :: SourceLine -> SomeVarValue -> Text +textSomeVarValue sline (SomeVarValue (VarValue _ args value)) + | anull args = textExprValue $ value sline mempty + | otherwise = "<function>" + +someVarValueType :: SomeVarValue -> SomeExprType +someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a)) + | anull args = ExprTypePrim (Proxy @a) + | otherwise = ExprTypeFunction args (Proxy @a) + + +newtype ArgumentKeyword = ArgumentKeyword Text + deriving (Show, Eq, Ord, IsString) + +newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a) + deriving (Show, Semigroup, Monoid, Functor, Foldable, Traversable) + +anull :: FunctionArguments a -> Bool +anull (FunctionArguments args) = M.null args + +exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType +exprArgs = \case + Let _ _ _ expr -> exprArgs expr + Variable {} -> mempty + FunVariable args _ _ -> args + ArgsReq args expr -> fmap snd args <> exprArgs expr + ArgsApp (FunctionArguments applied) expr -> + let FunctionArguments args = exprArgs expr + in FunctionArguments (args `M.difference` applied) + FunctionAbstraction {} -> mempty + FunctionEval {} -> mempty + Pure {} -> error "exprArgs: pure" + App {} -> error "exprArgs: app" + Undefined {} -> error "exprArgs: undefined" + +funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m (FunctionType a) +funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do + maybe (fail err) return $ do + FunctionType <$> cast (value sline) + where + err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has ", + (if anull args then "type " else "function type returting ") <> textExprType @b Proxy ] + +data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a) + +data ArgumentType a + = RequiredArgument + | OptionalArgument + | ExprDefault (Expr a) + | ContextDefault + + +data Traced a = Traced EvalTrace a + +type VarNameSelectors = ( FqVarName, [ Text ] ) +type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ] + +gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace +gatherVars = fmap (uniqOn fst . sortOn fst) . helper + where + helper :: forall b. Expr b -> m EvalTrace + helper = \case + Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr + Variable _ var + | isInternalVar var -> return [] + | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr + ArgsApp (FunctionArguments args) fun -> do + v <- helper fun + vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args + return $ concat (v : vs) + FunctionAbstraction expr -> helper expr + FunctionEval efun -> helper efun + LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr + Pure _ -> return [] + e@(App (AnnRecord sel) _ x) + | Just (var, sels) <- gatherSelectors x + -> do + val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e + return [ (( var, sels ++ [ sel ] ), val ) ] + | otherwise -> do + helper x + App _ f x -> (++) <$> helper f <*> helper x + Concat es -> concat <$> mapM helper es + Regex es -> concat <$> mapM helper es + Undefined {} -> return [] + Trace expr -> helper expr + + gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] ) + gatherSelectors = \case + Variable _ var -> Just (var, []) + App (AnnRecord sel) _ x -> do + (var, sels) <- gatherSelectors x + return (var, sels ++ [sel]) + _ -> Nothing + + +data Regex = RegexCompiled Text RE.Regex + | RegexPart Text + | RegexString Text + +instance ExprType Regex where + textExprType _ = T.pack "regex" + textExprValue _ = T.pack "<regex>" + + exprExpansionConvFrom = listToMaybe $ catMaybes + [ cast (RegexString) + , cast (RegexString . T.pack . show @Integer) + , cast (RegexString . T.pack . show @Scientific) + ] + +regexCompile :: Text -> Either String Regex +regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $ + T.singleton '^' <> src <> T.singleton '$' + +regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text])) +regexMatch (RegexCompiled _ re) text = RE.regexec re text +regexMatch _ _ = Left "regex not compiled" + +regexSource :: Regex -> Text +regexSource (RegexCompiled src _) = src +regexSource (RegexPart src) = src +regexSource (RegexString str) = T.concatMap escapeChar str + where + escapeChar c | isAlphaNum c = T.singleton c + | c `elem` ['`', '\'', '<', '>'] = T.singleton c + | otherwise = T.pack ['\\', c] diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs new file mode 100644 index 0000000..20a92b4 --- /dev/null +++ b/src/Script/Expr/Class.hs @@ -0,0 +1,77 @@ +module Script.Expr.Class ( + ExprType(..), + RecordSelector(..), + ExprListUnpacker(..), + ExprEnumerator(..), +) where + +import Data.Maybe +import Data.Scientific +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable +import Data.Void + +class Typeable a => ExprType a where + textExprType :: proxy a -> Text + textExprValue :: a -> Text + + recordMembers :: [(Text, RecordSelector a)] + recordMembers = [] + + exprExpansionConvTo :: ExprType b => Maybe (a -> b) + exprExpansionConvTo = Nothing + + exprExpansionConvFrom :: ExprType b => Maybe (b -> a) + exprExpansionConvFrom = Nothing + + exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a) + exprListUnpacker _ = Nothing + + exprEnumerator :: proxy a -> Maybe (ExprEnumerator a) + exprEnumerator _ = Nothing + + +data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) + +data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e) + +data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) + + +instance ExprType Integer where + textExprType _ = T.pack "integer" + textExprValue x = T.pack (show x) + + exprExpansionConvTo = listToMaybe $ catMaybes + [ cast (T.pack . show :: Integer -> Text) + ] + + exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo + +instance ExprType Scientific where + textExprType _ = T.pack "number" + textExprValue x = T.pack (show x) + + exprExpansionConvTo = listToMaybe $ catMaybes + [ cast (T.pack . show :: Scientific -> Text) + ] + +instance ExprType Bool where + textExprType _ = T.pack "bool" + textExprValue True = T.pack "true" + textExprValue False = T.pack "false" + +instance ExprType Text where + textExprType _ = T.pack "string" + textExprValue x = T.pack (show x) + +instance ExprType Void where + textExprType _ = T.pack "void" + textExprValue _ = T.pack "<void>" + +instance ExprType a => ExprType [a] where + textExprType _ = "[" <> textExprType @a Proxy <> "]" + textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" + + exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) diff --git a/src/Script/Module.hs b/src/Script/Module.hs new file mode 100644 index 0000000..3ea59bf --- /dev/null +++ b/src/Script/Module.hs @@ -0,0 +1,20 @@ +module Script.Module ( + Module(..), + ModuleName(..), textModuleName, + moduleExportedDefinitions, +) where + +import Script.Expr +import Test + +data Module = Module + { moduleName :: ModuleName + , moduleTests :: [ Test ] + , moduleDefinitions :: [ ( VarName, SomeExpr ) ] + , moduleExports :: [ VarName ] + } + +moduleExportedDefinitions :: Module -> [ ( VarName, ( FqVarName, SomeExpr )) ] +moduleExportedDefinitions Module {..} = + map (\( var, expr ) -> ( var, ( GlobalVarName moduleName var, expr ))) $ + filter ((`elem` moduleExports) . fst) moduleDefinitions diff --git a/src/Script/Object.hs b/src/Script/Object.hs new file mode 100644 index 0000000..9232b21 --- /dev/null +++ b/src/Script/Object.hs @@ -0,0 +1,42 @@ +module Script.Object ( + ObjectId(..), + ObjectType(..), + Object(..), SomeObject(..), + toSomeObject, fromSomeObject, + destroySomeObject, +) where + +import Data.Kind +import Data.Typeable + + +newtype ObjectId = ObjectId Int + +class Typeable a => ObjectType m a where + type ConstructorArgs a :: Type + type ConstructorArgs a = () + + createObject :: ObjectId -> ConstructorArgs a -> m (Object m a) + destroyObject :: Object m a -> m () + +data Object m a = ObjectType m a => Object + { objId :: ObjectId + , objImpl :: a + } + +data SomeObject m = forall a. ObjectType m a => SomeObject + { sobjId :: ObjectId + , sobjImpl :: a + } + +toSomeObject :: Object m a -> SomeObject m +toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl } + +fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a) +fromSomeObject SomeObject {..} = do + let objId = sobjId + objImpl <- cast sobjImpl + return Object {..} + +destroySomeObject :: SomeObject m -> m () +destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl) diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs new file mode 100644 index 0000000..9bbf06c --- /dev/null +++ b/src/Script/Shell.hs @@ -0,0 +1,94 @@ +module Script.Shell ( + ShellStatement(..), + ShellScript(..), + withShellProcess, +) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Reader + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T + +import System.Exit +import System.IO +import System.Process hiding (ShellCommand) + +import Network +import Network.Ip +import Output +import Process +import Run.Monad +import Script.Var + + +data ShellStatement = ShellStatement + { shellCommand :: Text + , shellArguments :: [ Text ] + , shellSourceLine :: SourceLine + } + +newtype ShellScript = ShellScript [ ShellStatement ] + + +executeScript :: Node -> ProcName -> MVar ExitCode -> Handle -> Handle -> Handle -> ShellScript -> TestRun () +executeScript node pname statusVar pstdin pstdout pstderr (ShellScript statements) = do + setNetworkNamespace $ getNetns node + forM_ statements $ \ShellStatement {..} -> case shellCommand of + "echo" -> liftIO $ do + T.hPutStrLn pstdout $ T.intercalate " " shellArguments + hFlush pstdout + cmd -> do + (_, _, _, phandle) <- liftIO $ createProcess_ "shell" + (proc (T.unpack cmd) (map T.unpack shellArguments)) + { std_in = UseHandle pstdin + , std_out = UseHandle pstdout + , std_err = UseHandle pstderr + , cwd = Just (nodeDir node) + , env = Just [] + } + liftIO (waitForProcess phandle) >>= \case + ExitSuccess -> return () + status -> do + outLine OutputChildFail (Just $ textProcName pname) $ "failed at: " <> textSourceLine shellSourceLine + liftIO $ putMVar statusVar status + throwError Failed + liftIO $ putMVar statusVar ExitSuccess + +spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process +spawnShell procNode procName script = do + procOutput <- liftIO $ newTVarIO [] + statusVar <- liftIO $ newEmptyMVar + ( pstdin, procStdin ) <- liftIO $ createPipe + ( hout, pstdout ) <- liftIO $ createPipe + ( herr, pstderr ) <- liftIO $ createPipe + procHandle <- fmap (Right . (, statusVar)) $ forkTestUsing forkOS $ do + executeScript procNode procName statusVar pstdin pstdout pstderr script + + let procKillWith = Nothing + let process = Process {..} + + void $ forkTest $ lineReadingLoop process hout $ \line -> do + outProc OutputChildStdout process line + liftIO $ atomically $ modifyTVar procOutput (++ [ line ]) + void $ forkTest $ lineReadingLoop process herr $ \line -> do + outProc OutputChildStderr process line + + return process + +withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a +withShellProcess node pname script inner = do + procVar <- asks $ teProcesses . fst + + process <- spawnShell node pname script + liftIO $ modifyMVar_ procVar $ return . (process:) + + inner process `finally` do + ps <- liftIO $ takeMVar procVar + closeTestProcess process `finally` do + liftIO $ putMVar procVar $ filter (/=process) ps diff --git a/src/Script/Var.hs b/src/Script/Var.hs new file mode 100644 index 0000000..668060c --- /dev/null +++ b/src/Script/Var.hs @@ -0,0 +1,56 @@ +module Script.Var ( + VarName(..), textVarName, unpackVarName, + FqVarName(..), textFqVarName, unpackFqVarName, unqualifyName, + TypedVarName(..), + ModuleName(..), textModuleName, + SourceLine(..), textSourceLine, +) where + +import Data.Text (Text) +import Data.Text qualified as T + + +newtype VarName = VarName Text + deriving (Eq, Ord) + +textVarName :: VarName -> Text +textVarName (VarName name) = name + +unpackVarName :: VarName -> String +unpackVarName = T.unpack . textVarName + + +data FqVarName + = GlobalVarName ModuleName VarName + | LocalVarName VarName + deriving (Eq, Ord) + +textFqVarName :: FqVarName -> Text +textFqVarName (GlobalVarName mname vname) = textModuleName mname <> "." <> textVarName vname +textFqVarName (LocalVarName vname) = textVarName vname + +unpackFqVarName :: FqVarName -> String +unpackFqVarName = T.unpack . textFqVarName + +unqualifyName :: FqVarName -> VarName +unqualifyName (GlobalVarName _ name) = name +unqualifyName (LocalVarName name) = name + + +newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName } + deriving (Eq, Ord) + + +newtype ModuleName = ModuleName [ Text ] + deriving (Eq, Ord, Show) + +textModuleName :: ModuleName -> Text +textModuleName (ModuleName parts) = T.intercalate "." parts + +data SourceLine + = SourceLine Text + | SourceLineBuiltin + +textSourceLine :: SourceLine -> Text +textSourceLine (SourceLine text) = text +textSourceLine SourceLineBuiltin = "<builtin>" diff --git a/src/Test.hs b/src/Test.hs index 3db7919..3e98efa 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,533 +1,81 @@ module Test ( - Module(..), Test(..), TestStep(..), TestBlock(..), - SourceLine(..), textSourceLine, - MonadEval(..), lookupVar, tryLookupVar, withVar, - VarName(..), TypedVarName(..), textVarName, unpackVarName, withTypedVar, - ExprType(..), SomeExpr(..), - TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, - FunctionType, DynamicType, - - VarValue(..), SomeVarValue(..), - svvVariables, svvArguments, - someConstValue, fromConstValue, - fromSomeVarValue, textSomeVarValue, someVarValueType, - - RecordSelector(..), - ExprListUnpacker(..), - ExprEnumerator(..), - Expr(..), varExpr, mapExpr, eval, evalSome, - Traced(..), EvalTrace, VarNameSelectors, gatherVars, - AppAnnotation(..), - - ArgumentKeyword(..), FunctionArguments(..), - anull, exprArgs, - SomeArgumentType(..), ArgumentType(..), - - Regex(RegexPart, RegexString), regexMatch, + MultiplyTimeout(..), ) where -import Control.Monad +import Control.Concurrent.MVar +import Control.Monad.Except import Control.Monad.Reader -import Data.Char -import Data.Foldable -import Data.List -import Data.Map (Map) -import Data.Map qualified as M import Data.Scientific -import Data.String import Data.Text (Text) -import Data.Text qualified as T import Data.Typeable -import Data.Void - -import Text.Regex.TDFA qualified as RE -import Text.Regex.TDFA.Text qualified as RE - -import {-# SOURCE #-} Network -import {-# SOURCE #-} Process -import Util -data Module = Module - { moduleName :: [ Text ] - , moduleTests :: [ Test ] - , moduleDefinitions :: [ ( VarName, SomeExpr ) ] - } +import Network +import Output +import Process +import Run.Monad +import Script.Expr +import Script.Object +import Script.Shell data Test = Test { testName :: Text - , testSteps :: Expr TestBlock + , testSteps :: Expr (TestStep ()) } -newtype TestBlock = TestBlock [ TestStep ] - deriving (Semigroup, Monoid) - -data TestStep - = Subnet (TypedVarName Network) Network (Network -> TestBlock) - | DeclNode (TypedVarName Node) Network (Node -> TestBlock) - | Spawn (TypedVarName Process) (Either Network Node) (Process -> TestBlock) - | Send Process Text - | Expect SourceLine Process (Traced Regex) [ TypedVarName Text ] ([ Text ] -> TestBlock) - | Flush Process (Maybe Regex) - | Guard SourceLine EvalTrace Bool - | DisconnectNode Node TestBlock - | DisconnectNodes Network TestBlock - | DisconnectUpstream Network TestBlock - | PacketLoss Scientific Node TestBlock - | Wait - -data SourceLine - = SourceLine Text - | SourceLineBuiltin - -textSourceLine :: SourceLine -> Text -textSourceLine (SourceLine text) = text -textSourceLine SourceLineBuiltin = "<builtin>" - - -class MonadFail m => MonadEval m where - askDictionary :: m VariableDictionary - withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a - -type VariableDictionary = [ ( VarName, SomeVarValue ) ] - -lookupVar :: MonadEval m => VarName -> m SomeVarValue -lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return . lookup name =<< askDictionary - -tryLookupVar :: MonadEval m => VarName -> m (Maybe SomeVarValue) -tryLookupVar name = lookup name <$> askDictionary - -withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a -withVar name value = withDictionary (( name, someConstValue value ) : ) - -newtype VarName = VarName Text - deriving (Eq, Ord, Show) - -newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName } - deriving (Eq, Ord) - -textVarName :: VarName -> Text -textVarName (VarName name ) = name - -unpackVarName :: VarName -> String -unpackVarName = T.unpack . textVarName - -isInternalVar :: VarName -> Bool -isInternalVar (VarName name) - | Just ( '$', _ ) <- T.uncons name = True - | otherwise = False - -withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a -withTypedVar (TypedVarName name) = withVar name - - -class Typeable a => ExprType a where - textExprType :: proxy a -> Text - textExprValue :: a -> Text - - recordMembers :: [(Text, RecordSelector a)] - recordMembers = [] - - exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a) - exprListUnpacker _ = Nothing - - exprEnumerator :: proxy a -> Maybe (ExprEnumerator a) - exprEnumerator _ = Nothing - -instance ExprType Integer where - textExprType _ = T.pack "integer" - textExprValue x = T.pack (show x) - - exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo - -instance ExprType Scientific where - textExprType _ = T.pack "number" - textExprValue x = T.pack (show x) - -instance ExprType Bool where - textExprType _ = T.pack "bool" - textExprValue True = T.pack "true" - textExprValue False = T.pack "false" - -instance ExprType Text where - textExprType _ = T.pack "string" - textExprValue x = T.pack (show x) - -instance ExprType Regex where - textExprType _ = T.pack "regex" - textExprValue _ = T.pack "<regex>" - -instance ExprType Void where - textExprType _ = T.pack "void" - textExprValue _ = T.pack "<void>" - -instance ExprType a => ExprType [a] where - textExprType _ = "[" <> textExprType @a Proxy <> "]" - textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" - - exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) - -instance ExprType TestBlock where +data TestBlock a where + EmptyTestBlock :: TestBlock () + TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a + +instance Semigroup (TestBlock ()) where + EmptyTestBlock <> block = block + block <> EmptyTestBlock = block + block <> TestBlockStep block' step = TestBlockStep (block <> block') step + +instance Monoid (TestBlock ()) where + mempty = EmptyTestBlock + +data TestStep a where + Scope :: TestBlock a -> TestStep a + CreateObject :: forall o. ObjectType TestRun o => Proxy o -> ConstructorArgs o -> TestStep () + Subnet :: TypedVarName Network -> Network -> (Network -> TestStep a) -> TestStep a + DeclNode :: TypedVarName Node -> Network -> (Node -> TestStep a) -> TestStep a + Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> (Process -> TestStep a) -> TestStep a + SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a + Send :: Process -> Text -> TestStep () + Expect :: SourceLine -> Process -> Traced Regex -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a + Flush :: Process -> Maybe Regex -> TestStep () + Guard :: SourceLine -> EvalTrace -> Bool -> TestStep () + DisconnectNode :: Node -> TestStep a -> TestStep a + DisconnectNodes :: Network -> TestStep a -> TestStep a + DisconnectUpstream :: Network -> TestStep a -> TestStep a + PacketLoss :: Scientific -> Node -> TestStep a -> TestStep a + Wait :: TestStep () + +instance Typeable a => ExprType (TestBlock a) where textExprType _ = "test block" textExprValue _ = "<test block>" -data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a) - -instance ExprType a => ExprType (FunctionType a) where - textExprType _ = "function type" - textExprValue _ = "<function type>" - -data DynamicType - -instance ExprType DynamicType where - textExprType _ = "ambiguous type" - textExprValue _ = "<dynamic type>" - -data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) - -newtype TypeVar = TypeVar Text - deriving (Eq, Ord) - -data SomeExprType - = forall a. ExprType a => ExprTypePrim (Proxy a) - | ExprTypeVar TypeVar - | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a) - -someExprType :: SomeExpr -> SomeExprType -someExprType (SomeExpr expr) = go expr - where - go :: forall e. ExprType e => Expr e -> SomeExprType - go = \case - DynVariable tvar _ _ -> ExprTypeVar tvar - (e :: Expr a) - | IsFunType <- asFunType e -> ExprTypeFunction (gof e) (proxyOfFunctionType e) - | otherwise -> ExprTypePrim (Proxy @a) - - gof :: forall e. ExprType e => Expr (FunctionType e) -> FunctionArguments SomeArgumentType - gof = \case - Let _ _ _ body -> gof body - Variable {} -> error "someExprType: gof: variable" - FunVariable params _ _ -> params - ArgsReq args body -> fmap snd args <> gof body - ArgsApp (FunctionArguments used) body -> - let FunctionArguments args = gof body - in FunctionArguments $ args `M.difference` used - FunctionAbstraction {} -> mempty - FunctionEval {} -> error "someExprType: gof: function eval" - Pure {} -> error "someExprType: gof: pure" - App {} -> error "someExprType: gof: app" - Undefined {} -> error "someExprType: gof: undefined" - - proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a - proxyOfFunctionType _ = Proxy - -textSomeExprType :: SomeExprType -> Text -textSomeExprType (ExprTypePrim p) = textExprType p -textSomeExprType (ExprTypeVar (TypeVar name)) = name -textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r - -data AsFunType a - = forall b. (a ~ FunctionType b, ExprType b) => IsFunType - | NotFunType - -asFunType :: Expr a -> AsFunType a -asFunType = \case - Let _ _ _ expr -> asFunType expr - FunVariable {} -> IsFunType - ArgsReq {} -> IsFunType - ArgsApp {} -> IsFunType - FunctionAbstraction {} -> IsFunType - _ -> NotFunType - - -data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a) - -svvVariables :: SomeVarValue -> EvalTrace -svvVariables (SomeVarValue vv) = vvVariables vv - -svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType -svvArguments (SomeVarValue vv) = vvArguments vv - -data VarValue a = VarValue - { vvVariables :: EvalTrace - , vvArguments :: FunctionArguments SomeArgumentType - , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a - } - -someConstValue :: ExprType a => a -> SomeVarValue -someConstValue = SomeVarValue . VarValue [] mempty . const . const - -fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> VarValue a -> m a -fromConstValue sline name (VarValue _ args value :: VarValue b) = do - maybe (fail err) return $ do - guard $ anull args - cast $ value sline mempty - where - err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", - if anull args then textExprType @b Proxy else "function type" ] - -fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m a -fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do - maybe (fail err) return $ do - guard $ anull args - cast $ value sline mempty - where - err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", - if anull args then textExprType @b Proxy else "function type" ] - -textSomeVarValue :: SourceLine -> SomeVarValue -> Text -textSomeVarValue sline (SomeVarValue (VarValue _ args value)) - | anull args = textExprValue $ value sline mempty - | otherwise = "<function>" - -someVarValueType :: SomeVarValue -> SomeExprType -someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a)) - | anull args = ExprTypePrim (Proxy @a) - | otherwise = ExprTypeFunction args (Proxy @a) - - -data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) - -data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e) - -data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) - - -data Expr a where - Let :: forall a b. ExprType b => SourceLine -> TypedVarName b -> Expr b -> Expr a -> Expr a - Variable :: ExprType a => SourceLine -> VarName -> Expr a - DynVariable :: TypeVar -> SourceLine -> VarName -> Expr DynamicType - FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> VarName -> Expr (FunctionType a) - ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a) - ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) - FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a) - FunctionEval :: ExprType a => Expr (FunctionType a) -> Expr a - LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b) - Pure :: a -> Expr a - App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b - Concat :: [Expr Text] -> Expr Text - Regex :: [Expr Regex] -> Expr Regex - Undefined :: String -> Expr a - Trace :: Expr a -> Expr (Traced a) - -data AppAnnotation b = AnnNone - | ExprType b => AnnRecord Text - -instance Functor Expr where - fmap f x = Pure f <*> x - -instance Applicative Expr where - pure = Pure - (<*>) = App AnnNone - -instance Semigroup a => Semigroup (Expr a) where - e <> f = (<>) <$> e <*> f - -instance Monoid a => Monoid (Expr a) where - mempty = Pure mempty - -varExpr :: ExprType a => SourceLine -> TypedVarName a -> Expr a -varExpr sline (TypedVarName name) = Variable sline name - -mapExpr :: forall a. (forall b. Expr b -> Expr b) -> Expr a -> Expr a -mapExpr f = go - where - go :: forall c. Expr c -> Expr c - go = \case - Let sline vname vval expr -> f $ Let sline vname (go vval) (go expr) - e@Variable {} -> f e - e@DynVariable {} -> f e - e@FunVariable {} -> f e - ArgsReq args expr -> f $ ArgsReq args (go expr) - ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr) - FunctionAbstraction expr -> f $ FunctionAbstraction (go expr) - FunctionEval expr -> f $ FunctionEval (go expr) - LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr) - e@Pure {} -> f e - App ann efun earg -> f $ App ann (go efun) (go earg) - e@Concat {} -> f e - e@Regex {} -> f e - e@Undefined {} -> f e - Trace expr -> f $ Trace (go expr) - - -newtype SimpleEval a = SimpleEval (Reader VariableDictionary a) - deriving (Functor, Applicative, Monad) - -runSimpleEval :: SimpleEval a -> VariableDictionary -> a -runSimpleEval (SimpleEval x) = runReader x - -instance MonadFail SimpleEval where - fail = error . ("eval failed: " <>) - -instance MonadEval SimpleEval where - askDictionary = SimpleEval ask - withDictionary f (SimpleEval inner) = SimpleEval (local f inner) - - -eval :: forall m a. MonadEval m => Expr a -> m a -eval = \case - Let _ (TypedVarName name) valExpr expr -> do - val <- eval valExpr - withVar name val $ eval expr - Variable sline name -> fromSomeVarValue sline name =<< lookupVar name - DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackVarName name <> "’" - FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name - ArgsReq (FunctionArguments req) efun -> do - dict <- askDictionary - return $ FunctionType $ \(FunctionArguments args) -> - let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req - FunctionType fun = runSimpleEval (eval efun) (toList used ++ dict) - in fun $ FunctionArguments $ args `M.difference` req - ArgsApp eargs efun -> do - FunctionType fun <- eval efun - args <- mapM evalSome eargs - return $ FunctionType $ \args' -> fun (args <> args') - FunctionAbstraction expr -> do - val <- eval expr - return $ FunctionType $ const val - FunctionEval efun -> do - FunctionType fun <- eval efun - return $ fun mempty - LambdaAbstraction (TypedVarName name) expr -> do - dict <- askDictionary - return $ \x -> runSimpleEval (eval expr) (( name, someConstValue x ) : dict) - Pure value -> return value - App _ f x -> eval f <*> eval x - Concat xs -> T.concat <$> mapM eval xs - Regex xs -> mapM eval xs >>= \case - [ re@RegexCompiled {} ] -> return re - parts -> case regexCompile $ T.concat $ map regexSource parts of - Left err -> fail err - Right re -> return re - Undefined err -> fail err - Trace expr -> Traced <$> gatherVars expr <*> eval expr - -evalSome :: MonadEval m => SomeExpr -> m SomeVarValue -evalSome (SomeExpr expr) - | IsFunType <- asFunType expr = do - FunctionType fun <- eval expr - fmap SomeVarValue $ VarValue - <$> gatherVars expr - <*> pure (exprArgs expr) - <*> pure (const fun) - | otherwise = do - fmap SomeVarValue $ VarValue - <$> gatherVars expr - <*> pure mempty - <*> (const . const <$> eval expr) - -data Traced a = Traced EvalTrace a - -type VarNameSelectors = ( VarName, [ Text ] ) -type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ] - -gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace -gatherVars = fmap (uniqOn fst . sortOn fst) . helper - where - helper :: forall b. Expr b -> m EvalTrace - helper = \case - Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr - Variable _ var - | isInternalVar var -> return [] - | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr - ArgsApp (FunctionArguments args) fun -> do - v <- helper fun - vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args - return $ concat (v : vs) - FunctionAbstraction expr -> helper expr - FunctionEval efun -> helper efun - LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr - Pure _ -> return [] - e@(App (AnnRecord sel) _ x) - | Just (var, sels) <- gatherSelectors x - -> do - val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e - return [ (( var, sels ++ [ sel ] ), val ) ] - | otherwise -> do - helper x - App _ f x -> (++) <$> helper f <*> helper x - Concat es -> concat <$> mapM helper es - Regex es -> concat <$> mapM helper es - Undefined {} -> return [] - Trace expr -> helper expr - - gatherSelectors :: forall b. Expr b -> Maybe (VarName, [Text]) - gatherSelectors = \case - Variable _ var -> Just (var, []) - App (AnnRecord sel) _ x -> do - (var, sels) <- gatherSelectors x - return (var, sels ++ [sel]) - _ -> Nothing - - -newtype ArgumentKeyword = ArgumentKeyword Text - deriving (Show, Eq, Ord, IsString) - -newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a) - deriving (Show, Semigroup, Monoid, Functor, Foldable, Traversable) - -anull :: FunctionArguments a -> Bool -anull (FunctionArguments args) = M.null args - -exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType -exprArgs = \case - Let _ _ _ expr -> exprArgs expr - Variable {} -> mempty - FunVariable args _ _ -> args - ArgsReq args expr -> fmap snd args <> exprArgs expr - ArgsApp (FunctionArguments applied) expr -> - let FunctionArguments args = exprArgs expr - in FunctionArguments (args `M.difference` applied) - FunctionAbstraction {} -> mempty - FunctionEval {} -> mempty - Pure {} -> error "exprArgs: pure" - App {} -> error "exprArgs: app" - Undefined {} -> error "exprArgs: undefined" - -funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m (FunctionType a) -funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do - maybe (fail err) return $ do - guard $ not $ anull args - FunctionType <$> cast (value sline) - where - err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has ", - (if anull args then "type " else "function type returting ") <> textExprType @b Proxy ] - -data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a) - -data ArgumentType a - = RequiredArgument - | OptionalArgument - | ExprDefault (Expr a) - | ContextDefault - +data MultiplyTimeout = MultiplyTimeout Scientific -data Regex = RegexCompiled Text RE.Regex - | RegexPart Text - | RegexString Text +instance ObjectType TestRun MultiplyTimeout where + type ConstructorArgs MultiplyTimeout = Scientific -regexCompile :: Text -> Either String Regex -regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $ - T.singleton '^' <> src <> T.singleton '$' + createObject oid timeout + | timeout > 0 = do + var <- asks (teTimeout . fst) + liftIO $ modifyMVar_ var $ return . (* timeout) + return $ Object oid $ MultiplyTimeout timeout -regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text])) -regexMatch (RegexCompiled _ re) text = RE.regexec re text -regexMatch _ _ = Left "regex not compiled" + | otherwise = do + outLine OutputError Nothing "timeout must be positive" + throwError Failed -regexSource :: Regex -> Text -regexSource (RegexCompiled src _) = src -regexSource (RegexPart src) = src -regexSource (RegexString str) = T.concatMap escapeChar str - where - escapeChar c | isAlphaNum c = T.singleton c - | c `elem` ['`', '\'', '<', '>'] = T.singleton c - | otherwise = T.pack ['\\', c] + destroyObject Object { objImpl = MultiplyTimeout timeout } = do + var <- asks (teTimeout . fst) + liftIO $ modifyMVar_ var $ return . (/ timeout) diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index a676a35..6dba707 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -4,33 +4,39 @@ module Test.Builtins ( import Data.Map qualified as M import Data.Maybe +import Data.Proxy +import Data.Scientific import Data.Text (Text) import Process (Process) +import Script.Expr import Test -builtins :: [ ( VarName, SomeVarValue ) ] -builtins = - [ ( VarName "send", builtinSend ) - , ( VarName "flush", builtinFlush ) - , ( VarName "guard", builtinGuard ) - , ( VarName "wait", builtinWait ) +builtins :: GlobalDefs +builtins = M.fromList + [ fq "send" builtinSend + , fq "flush" builtinFlush + , fq "guard" builtinGuard + , fq "multiply_timeout" builtinMultiplyTimeout + , fq "wait" builtinWait ] + where + fq name impl = (( ModuleName [ "$" ], VarName name ), impl ) getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a getArg args = fromMaybe (error "parameter mismatch") . getArgMb args getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a getArgMb (FunctionArguments args) kw = do - fromSomeVarValue SourceLineBuiltin (VarName "") =<< M.lookup kw args + fromSomeVarValue SourceLineBuiltin (LocalVarName (VarName "")) =<< M.lookup kw args -getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( VarName, [ Text ] ), SomeVarValue ) ] +getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( FqVarName, [ Text ] ), SomeVarValue ) ] getArgVars (FunctionArguments args) kw = do maybe [] svvVariables $ M.lookup kw args builtinSend :: SomeVarValue builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ] + \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing) where atypes = [ ( Just "to", SomeArgumentType (ContextDefault @Process) ) @@ -39,7 +45,7 @@ builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) builtinFlush :: SomeVarValue builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ] + \_ args -> TestBlockStep EmptyTestBlock $ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) where atypes = [ ( Just "from", SomeArgumentType (ContextDefault @Process) ) @@ -48,7 +54,11 @@ builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes builtinGuard :: SomeVarValue builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ - \sline args -> TestBlock [ Guard sline (getArgVars args Nothing) (getArg args Nothing) ] + \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing) + +builtinMultiplyTimeout :: SomeVarValue +builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $ + \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @MultiplyTimeout) (getArg args (Just "by")) builtinWait :: SomeVarValue -builtinWait = someConstValue $ TestBlock [ Wait ] +builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait diff --git a/src/TestMode.hs b/src/TestMode.hs new file mode 100644 index 0000000..c052fb9 --- /dev/null +++ b/src/TestMode.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE CPP #-} + +module TestMode ( + testMode, +) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State + +import Data.Bifunctor +import Data.List +import Data.Maybe +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T + +import System.IO.Error + +import Text.Megaparsec.Error +import Text.Megaparsec.Pos + +import Config +import Output +import Parser +import Run +import Script.Expr +import Script.Module +import Test + + +data TestModeInput = TestModeInput + { tmiOutput :: Output + , tmiConfig :: Maybe Config + , tmiParams :: [ Text ] + } + +data TestModeState = TestModeState + { tmsModules :: [ Module ] + , tmsGlobals :: GlobalDefs + , tmsNextTestNumber :: Int + } + +initTestModeState :: TestModeState +initTestModeState = TestModeState + { tmsModules = mempty + , tmsGlobals = mempty + , tmsNextTestNumber = 1 + } + +testMode :: Maybe Config -> IO () +testMode tmiConfig = do + tmiOutput <- startOutput OutputStyleTest False + let testLoop = getLineMb >>= \case + Just line -> do + case T.words line of + cname : tmiParams + | Just (CommandM cmd) <- lookup cname commands -> do + runReaderT cmd $ TestModeInput {..} + | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'" + [] -> return () + testLoop + + Nothing -> return () + + runExceptT (evalStateT testLoop initTestModeState) >>= \case + Left err -> flip runReaderT tmiOutput $ outLine OutputError Nothing $ T.pack err + Right () -> return () + +getLineMb :: MonadIO m => m (Maybe Text) +getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) + +cmdOut :: Text -> Command +cmdOut line = do + out <- asks tmiOutput + flip runReaderT out $ outLine OutputTestRaw Nothing line + +getNextTestNumber :: CommandM Int +getNextTestNumber = do + num <- gets tmsNextTestNumber + modify $ \s -> s { tmsNextTestNumber = num + 1 } + return num + +runSingleTest :: Test -> CommandM Bool +runSingleTest test = do + out <- asks tmiOutput + num <- getNextTestNumber + globals <- gets tmsGlobals + mbconfig <- asks tmiConfig + let opts = defaultTestOptions + { optDefaultTool = fromMaybe "" $ configTool =<< mbconfig + , optTestDir = ".test" <> show num + , optKeep = True + } + liftIO (runTest out opts globals test) + + +newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a) + deriving + ( Functor, Applicative, Monad, MonadIO + , MonadReader TestModeInput, MonadState TestModeState, MonadError String + ) + +instance MonadFail CommandM where + fail = throwError + +type Command = CommandM () + +commands :: [ ( Text, Command ) ] +commands = + [ ( "load", cmdLoad ) + , ( "load-config", cmdLoadConfig ) + , ( "run", cmdRun ) + , ( "run-all", cmdRunAll ) + ] + +cmdLoad :: Command +cmdLoad = do + [ path ] <- asks tmiParams + liftIO (parseTestFiles [ T.unpack path ]) >>= \case + Right ( modules, allModules ) -> do + let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules + modify $ \s -> s + { tmsModules = modules + , tmsGlobals = globalDefs + } + cmdOut "load-done" + + Left (ModuleNotFound moduleName) -> do + cmdOut $ "load-failed module-not-found" <> textModuleName moduleName + Left (FileNotFound notFoundPath) -> do + cmdOut $ "load-failed file-not-found " <> T.pack notFoundPath + Left (ImportModuleError bundle) -> do +#if MIN_VERSION_megaparsec(9,7,0) + mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle +#endif + cmdOut $ "load-failed parse-error" + where + showParseError _ SourcePos {..} _ = concat + [ "parse-error" + , " ", sourceName + , ":", show $ unPos sourceLine + , ":", show $ unPos sourceColumn + ] + +cmdLoadConfig :: Command +cmdLoadConfig = do + Just config <- asks tmiConfig + ( modules, globalDefs ) <- liftIO $ loadModules =<< getConfigTestFiles config + modify $ \s -> s + { tmsModules = modules + , tmsGlobals = globalDefs + } + cmdOut "load-config-done" + +cmdRun :: Command +cmdRun = do + [ name ] <- asks tmiParams + TestModeState {..} <- get + case find ((name ==) . testName) $ concatMap moduleTests tmsModules of + Nothing -> cmdOut "run-not-found" + Just test -> do + runSingleTest test >>= \case + True -> cmdOut "run-done" + False -> cmdOut "run-failed" + +cmdRunAll :: Command +cmdRunAll = do + TestModeState {..} <- get + forM_ (concatMap moduleTests tmsModules) $ \test -> do + res <- runSingleTest test + cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed") + cmdOut "run-all-done" diff --git a/test/asset/definition/basic.et b/test/asset/definition/basic.et new file mode 100644 index 0000000..6ae248e --- /dev/null +++ b/test/asset/definition/basic.et @@ -0,0 +1,22 @@ +def expr_def = 4 + +def fun_expr_def (x) = x + 5 + +def test_def (n): + shell as p on n: + echo $expr_def + + expect from p: + /4/ + +def fun_test_def (n) first x: + shell as p on n: + echo ${expr_def + x} + + expect from p: + /${4 + x}/ + +test Test: + node n + test_def (n) + fun_test_def (n) first 7 diff --git a/test/asset/expansion.et b/test/asset/expansion.et new file mode 100644 index 0000000..d14f9a1 --- /dev/null +++ b/test/asset/expansion.et @@ -0,0 +1,18 @@ +def integer_var = 1 +def number_var = 1.3 +def string_var = "abc" +def regex_var = /a.c/ + +test VariableExpansion: + node n + shell as p on n: + echo "$integer_var" + echo "$number_var" + echo "$string_var" + echo "$string_var" + + expect from p: + /$integer_var/ + /$number_var/ + /$string_var/ + /$regex_var/ diff --git a/test/asset/parser/indent.et b/test/asset/parser/indent.et new file mode 100644 index 0000000..01c4dd8 --- /dev/null +++ b/test/asset/parser/indent.et @@ -0,0 +1,41 @@ +def x1s: + wait + +def x2s: + wait + +def x4s: + wait + +def x8s: + wait + +def x16s: + wait + +def x1t: + wait + +def x2t: + wait + +export def e1s: + wait + +export def e2s: + wait + +export def e4s: + wait + +export def e8s: + wait + +export def e16s: + wait + +export def e1t: + wait + +export def e2t: + wait diff --git a/test/asset/run-fail/bool.et b/test/asset/run-fail/bool.et new file mode 100644 index 0000000..1608a08 --- /dev/null +++ b/test/asset/run-fail/bool.et @@ -0,0 +1,3 @@ +test Test: + node n + guard (True == False) diff --git a/test/asset/run-success/bool.et b/test/asset/run-success/bool.et new file mode 100644 index 0000000..7121cc0 --- /dev/null +++ b/test/asset/run-success/bool.et @@ -0,0 +1,7 @@ +test Test: + node n + guard (True == True) + guard (False == False) + guard (False /= True) + guard ((1 == 1) == True) + guard ((1 == 0) == False) diff --git a/test/asset/run/echo.et b/test/asset/run/echo.et new file mode 100644 index 0000000..9950d7b --- /dev/null +++ b/test/asset/run/echo.et @@ -0,0 +1,4 @@ +test ExpectEcho: + spawn as p + send "abcdef" to p + expect /abcdef/ from p diff --git a/test/asset/run/erebos-tester.yaml b/test/asset/run/erebos-tester.yaml new file mode 100644 index 0000000..937ca97 --- /dev/null +++ b/test/asset/run/erebos-tester.yaml @@ -0,0 +1,2 @@ +tests: ./scripts/**/*.et +tool: ./tools/tool diff --git a/test/asset/run/sysinfo.et b/test/asset/run/sysinfo.et new file mode 100644 index 0000000..1b9f6aa --- /dev/null +++ b/test/asset/run/sysinfo.et @@ -0,0 +1,12 @@ +test SysInfo: + node n + spawn on n as p1 + with p1: + send "network-info" + expect /ip ${n.ifname} ${n.ip}/ + + spawn as p2 + guard (p2.node.ip /= p1.node.ip) + with p2: + send "network-info" + expect /ip ${n.ifname} ${p2.node.ip}/ diff --git a/test/asset/run/tools/echo.sh b/test/asset/run/tools/echo.sh new file mode 100755 index 0000000..53b1eae --- /dev/null +++ b/test/asset/run/tools/echo.sh @@ -0,0 +1,2 @@ +#!/bin/sh +cat diff --git a/test/asset/run/tools/sysinfo.sh b/test/asset/run/tools/sysinfo.sh new file mode 100755 index 0000000..38591f4 --- /dev/null +++ b/test/asset/run/tools/sysinfo.sh @@ -0,0 +1,9 @@ +#!/bin/sh + +while read cmd; do + case "$cmd" in + network-info) + ip -o addr show | sed -e 's/[0-9]*: \([a-z0-9]*\).*inet6\? \([0-9a-f:.]*\).*/ip \1 \2/' + ;; + esac +done diff --git a/test/asset/run/trivial.et b/test/asset/run/trivial.et new file mode 100644 index 0000000..0b2e878 --- /dev/null +++ b/test/asset/run/trivial.et @@ -0,0 +1,7 @@ +test AlwaysSucceeds: + node n + guard (1 == 1) + +test AlwaysFails: + node n + guard (1 == 0) diff --git a/test/script/definition.et b/test/script/definition.et new file mode 100644 index 0000000..d2da737 --- /dev/null +++ b/test/script/definition.et @@ -0,0 +1,18 @@ +module definition + +asset scripts: + path: ../asset/definition + +test Definition: + spawn as p + with p: + send "load ${scripts.path}/basic.et" + expect /load-done/ + + send "run Test" + expect /child-stdout p 4/ + expect /match p 4/ + expect /child-stdout p 11/ + expect /match p 11/ + expect /(.*)/ capture done + guard (done == "run-done") diff --git a/test/script/expansion.et b/test/script/expansion.et new file mode 100644 index 0000000..86a81dc --- /dev/null +++ b/test/script/expansion.et @@ -0,0 +1,15 @@ +module expansion + +asset expansion: + path: ../asset/expansion.et + +test VariableExpansion: + spawn as p + with p: + send "load ${expansion.path}" + expect /load-done/ + send "run VariableExpansion" + for str in [ "1", "1.3", "abc", "abc" ]: + expect /child-stdout p $str/ + expect /match p $str/ + expect /run-done/ diff --git a/test/script/parser.et b/test/script/parser.et new file mode 100644 index 0000000..554e345 --- /dev/null +++ b/test/script/parser.et @@ -0,0 +1,13 @@ +module parser + +asset scripts: + path: ../asset/parser + +test Parser: + spawn as p + with p: + send "load non-existing-file.et" + expect /load-failed file-not-found .*/ + + send "load ${scripts.path}/indent.et" + expect /load-done/ diff --git a/test/script/run.et b/test/script/run.et new file mode 100644 index 0000000..7cc1670 --- /dev/null +++ b/test/script/run.et @@ -0,0 +1,105 @@ +module run + +asset scripts: + path: ../asset/run + +asset scripts_success: + path: ../asset/run-success + +asset scripts_fail: + path: ../asset/run-fail + + +test TrivialRun: + spawn as p + with p: + send "load ${scripts.path}/trivial.et" + expect /load-done/ + + send "run AlwaysSucceeds" + local: + expect /(run-.*)/ capture done + guard (done == "run-done") + + send "run AlwaysFails" + local: + expect /match-fail .*/ + expect /(run-.*)/ capture done + guard (done == "run-failed") + + +test SimpleRun: + let should_succeed = [ "bool" ] + let should_fail = [ "bool" ] + spawn as p + + with p: + for file in should_succeed: + send "load ${scripts_success.path}/$file.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run Test" + local: + expect /(run-.*)/ capture done + guard (done == "run-done") + flush + + for file in should_fail: + send "load ${scripts_fail.path}/$file.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run Test" + local: + expect /(run-.*)/ capture done + guard (done == "run-failed") + flush + + +test RunConfig: + node n + shell on n: + cp ${scripts.path}/erebos-tester.yaml . + mkdir tools + cp ${scripts.path}/tools/echo.sh ./tools/tool + mkdir scripts + # TODO: it seems that namespaces are not properly cleaned up after the failed test + #cp ${scripts.path}/trivial.et ./scripts/ + cp ${scripts.path}/echo.et ./scripts/ + + spawn as p on n + + with p: + send "load-config" + expect /load-config-done/ + send "run-all" + #expect /run-test-result AlwaysSucceeds done/ + #expect /run-test-result AlwaysFails failed/ + expect /child-stdin p abcdef/ + expect /child-stdout p abcdef/ + expect /match p abcdef/ + expect /run-test-result ExpectEcho done/ + expect /run-all-done/ + + +test GetSysInfo: + node n + shell on n: + cp ${scripts.path}/erebos-tester.yaml . + mkdir tools + cp ${scripts.path}/tools/sysinfo.sh ./tools/tool + mkdir scripts + cp ${scripts.path}/sysinfo.et ./scripts/ + + spawn as p on n + + with p: + send "load-config" + expect /load-config-done/ + send "run SysInfo" + expect /run-done/ |