diff options
| -rw-r--r-- | README.md | 33 | ||||
| -rw-r--r-- | src/Output.hs | 4 | ||||
| -rw-r--r-- | src/Process.hs | 7 | ||||
| -rw-r--r-- | src/Run.hs | 5 | ||||
| -rw-r--r-- | src/Script/Expr.hs | 18 |
5 files changed, 57 insertions, 10 deletions
@@ -362,6 +362,39 @@ wait Wait for user input before continuing. Useful mostly for debugging or test development. +### Shell interpreter + +**Experimental feature**: Functionality is not fully implemented and behavior may change in incompatible ways between releases. + +Using the `shell` expression, it's possible to embed a shell script inside a test script. +The shell script is not passed to an external interpreter, but rather executed by the tester itself, +which allows the use of variables from the rest of the test script: + +``` +test: + node some_node + let x = "abc" + shell as sh on some_node: + echo $x > some_file + echo ${some_node.ip} >> some_file + cat some_file | sed 's/a/A/' > other_file +``` + +The syntax is intended to be generally similar to the classic Bourne shell, +however, only limited functionality is implemented so far (that includes executing commands, pipelines or input/output redirection). + +The general form of the `shell` expression is: + +``` +shell [as <name>] on <node>: + <shell commands> +``` + +Where `<node>` is the network node on which to run the script (it will be run in the network namespace of the node, and with working directory set to the node root), +and `<name>`, if given, is the name of the variable that will refer to the shell process (this can be used e.g. in the `expect` command to check the standard output of the script). +As with the `spawn` command, the resulting process is terminated at the end of the current scope. + + ### Functions When calling a function, parameters are usually passed using argument keywords diff --git a/src/Output.hs b/src/Output.hs index b91bbdd..ca79dab 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -53,6 +53,7 @@ data OutputType = OutputChildStdout | OutputChildStderr | OutputChildStdin + | OutputChildExec | OutputChildInfo | OutputChildFail | OutputMatch @@ -83,6 +84,7 @@ outColor :: OutputType -> Text outColor OutputChildStdout = T.pack "0" outColor OutputChildStderr = T.pack "31" outColor OutputChildStdin = T.pack "0" +outColor OutputChildExec = T.pack "33" outColor OutputChildInfo = T.pack "0" outColor OutputChildFail = T.pack "31" outColor OutputMatch = T.pack "32" @@ -95,6 +97,7 @@ outSign :: OutputType -> Text outSign OutputChildStdout = " " outSign OutputChildStderr = T.pack "!" outSign OutputChildStdin = T.empty +outSign OutputChildExec = "*" outSign OutputChildInfo = T.pack "." outSign OutputChildFail = T.pack "!!" outSign OutputMatch = T.pack "+" @@ -112,6 +115,7 @@ outTestLabel = \case OutputChildStdout -> "child-stdout" OutputChildStderr -> "child-stderr" OutputChildStdin -> "child-stdin" + OutputChildExec -> "child-exec" OutputChildInfo -> "child-info" OutputChildFail -> "child-fail" OutputMatch -> "match" diff --git a/src/Process.hs b/src/Process.hs index 1389987..a575e76 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -3,7 +3,7 @@ module Process ( ProcName(..), textProcName, unpackProcName, send, - outProc, + outProc, outProcName, lineReadingLoop, startProcessIOLoops, spawnOn, @@ -88,7 +88,10 @@ send p line = liftIO $ do hFlush (procStdin p) outProc :: MonadOutput m => OutputType -> Process -> Text -> m () -outProc otype p line = outLine otype (Just $ textProcName $ procName p) line +outProc otype p line = outProcName otype (procName p) line + +outProcName :: MonadOutput m => OutputType -> ProcName -> Text -> m () +outProcName otype pname line = outLine otype (Just $ textProcName pname) line lineReadingLoop :: MonadOutput m => Process -> Handle -> (Text -> m ()) -> m () lineReadingLoop process h act = @@ -188,9 +188,10 @@ runStep = \case opts <- asks $ teOptions . fst let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) - cmd = unwords $ tool : map (T.unpack . escape) args + cmd = T.unwords $ T.pack tool : map escape args escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" - withProcess (Right node) pname Nothing cmd $ runStep . inner + outProcName OutputChildExec pname cmd + withProcess (Right node) pname Nothing (T.unpack cmd) $ runStep . inner SpawnShell mbname node script inner -> do let tname | Just (TypedVarName (VarName name)) <- mbname = name diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs index 7a446c5..bd84a70 100644 --- a/src/Script/Expr.hs +++ b/src/Script/Expr.hs @@ -28,6 +28,7 @@ module Script.Expr ( ) where import Control.Monad +import Control.Monad.Except import Control.Monad.Reader import Data.Char @@ -132,14 +133,17 @@ withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a withTypedVar (TypedVarName name) = withVar name -newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a) - deriving (Functor, Applicative, Monad) +newtype SimpleEval a = SimpleEval (ReaderT ( GlobalDefs, VariableDictionary ) (Except String) a) + deriving (Functor, Applicative, Monad, MonadError String) runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a -runSimpleEval (SimpleEval x) = curry $ runReader x +runSimpleEval (SimpleEval x) gdefs dict = either error id $ runExcept $ runReaderT x ( gdefs, dict ) + +trySimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> Maybe a +trySimpleEval (SimpleEval x) gdefs dict = either (const Nothing) Just $ runExcept $ runReaderT x ( gdefs, dict ) instance MonadFail SimpleEval where - fail = error . ("eval failed: " <>) + fail = throwError . ("eval failed: " <>) instance MonadEval SimpleEval where askGlobalDefs = SimpleEval (asks fst) @@ -415,8 +419,10 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper e@(App (AnnRecord sel) _ x) | Just (var, sels) <- gatherSelectors x -> do - val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e - return [ (( var, sels ++ [ sel ] ), val ) ] + gdefs <- askGlobalDefs + dict <- askDictionary + let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval e) gdefs dict + return $ catMaybes [ (( var, sels ++ [ sel ] ), ) <$> mbVal ] | otherwise -> do helper x App _ f x -> (++) <$> helper f <*> helper x |