summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-10-07 11:09:44 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-10-07 18:27:32 +0200
commit2143eb381fc28e2d676a9c9a433426b1b2dbf737 (patch)
tree4842e6c9a23d64b98a06c758d85fe9db94d40dad /src
parent4161f5776e5e7a01fb9eb62351c0f648bb918076 (diff)
Process variables and expression type
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs25
-rw-r--r--src/Parser.hs2
-rw-r--r--src/Process.hs7
-rw-r--r--src/Process.hs-boot4
-rw-r--r--src/Test.hs8
5 files changed, 27 insertions, 19 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 221bfb4..46fdaa6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -7,7 +7,6 @@ import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
-import Data.List
import Data.Maybe
import Data.Scientific
import Data.Text (Text)
@@ -90,6 +89,9 @@ instance MonadEval TestRun where
instance MonadOutput TestRun where
getOutput = asks $ teOutput . fst
+withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a
+withVar name value = local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s })
+
forkTest :: TestRun () -> TestRun ()
forkTest act = do
tenv <- ask
@@ -181,8 +183,7 @@ createNode (TypedVarName vname) inner = do
callOn node $ "ip link set dev lo up"
return node
- local (fmap $ \s -> s { tsVars = (vname, SomeVarValue node) : tsVars s }) $ do
- inner node
+ withVar vname node $ inner node
callOn :: Node -> String -> IO ()
callOn node cmd = callCommand $ "ip netns exec \"" ++ unpackNodeName (nodeName node) ++ "\" " ++ cmd
@@ -235,12 +236,6 @@ spawnOn target pname killWith cmd = do
liftIO $ modifyMVar_ (netProcesses net) $ return . (process:)
return process
-getProcess :: ProcName -> TestRun Process
-getProcess pname = do
- net <- asks $ tsNetwork . snd
- Just p <- find ((pname==).procName) <$> liftIO (readMVar (netProcesses net))
- return p
-
tryMatch :: Regex -> [Text] -> Maybe ((Text, [Text]), [Text])
tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexec re x = Just ((x, capture), xs)
| otherwise = fmap (x:) <$> tryMatch re xs
@@ -309,27 +304,27 @@ evalSteps = mapM_ $ \case
outLine OutputError T.empty $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
throwError ()
value <- eval expr
- local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s }) $ do
- evalSteps inner
+ withVar name value $ evalSteps inner
- Spawn pname nname inner -> do
+ Spawn (TypedVarName vname@(VarName tname)) nname inner -> do
either createNode ((>>=) . eval) nname $ \node -> do
+ let pname = ProcName tname
opts <- asks $ teOptions . fst
p <- spawnOn (Right node) pname Nothing $
fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
- evalSteps inner `finally` do
+ withVar vname p (evalSteps inner) `finally` do
net <- asks $ tsNetwork . snd
ps <- liftIO $ takeMVar (netProcesses net)
closeProcess p `finally` do
liftIO $ putMVar (netProcesses net) $ filter (/=p) ps
Send pname expr -> do
- p <- getProcess pname
+ p <- eval pname
line <- eval expr
send p line
Expect line pname expr captures inner -> do
- p <- getProcess pname
+ p <- eval pname
expect line p expr captures $ evalSteps inner
Guard line expr -> do
diff --git a/src/Parser.hs b/src/Parser.hs
index a38d0c9..517aa27 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -222,7 +222,9 @@ someExpr = join inner <?> "expression"
, [ prefix "-" $ [ SomeUnOp (negate @Integer) ]
]
, [ binary "*" $ [ SomeBinOp ((*) @Integer) ]
+ {- TODO: parsing issues with regular expressions
, binary "/" $ [ SomeBinOp (div @Integer) ]
+ -}
]
, [ binary "+" $ [ SomeBinOp ((+) @Integer) ]
, binary "-" $ [ SomeBinOp ((-) @Integer) ]
diff --git a/src/Process.hs b/src/Process.hs
index bb33953..04c5076 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -21,6 +21,7 @@ import System.Posix.Signals
import System.Process
import Output
+import Test
data Process = Process
{ procName :: ProcName
@@ -33,6 +34,12 @@ data Process = Process
instance Eq Process where
(==) = (==) `on` procStdin
+instance ExprType Process where
+ textExprType _ = T.pack "proc"
+ textExprValue n = T.pack "p:" <> textProcName (procName n)
+ emptyVarValue = Process (ProcName T.empty) undefined undefined undefined undefined
+
+
data ProcName = ProcName Text
| ProcNameTcpdump
| ProcNameGDB
diff --git a/src/Process.hs-boot b/src/Process.hs-boot
new file mode 100644
index 0000000..7ddb5ea
--- /dev/null
+++ b/src/Process.hs-boot
@@ -0,0 +1,4 @@
+module Process where
+
+data Process
+data ProcName
diff --git a/src/Test.hs b/src/Test.hs
index 659107f..9175589 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -24,7 +24,7 @@ import Text.Regex.TDFA
import Text.Regex.TDFA.Text
import {-# SOURCE #-} Network
-import Process
+import {-# SOURCE #-} Process
import Util
data Test = Test
@@ -33,9 +33,9 @@ data Test = Test
}
data TestStep = forall a. ExprType a => Let SourceLine VarName (Expr a) [TestStep]
- | Spawn ProcName (Either (TypedVarName Node) (Expr Node)) [TestStep]
- | Send ProcName (Expr Text)
- | Expect SourceLine ProcName (Expr Regex) [TypedVarName Text] [TestStep]
+ | Spawn (TypedVarName Process) (Either (TypedVarName Node) (Expr Node)) [TestStep]
+ | Send (Expr Process) (Expr Text)
+ | Expect SourceLine (Expr Process) (Expr Regex) [TypedVarName Text] [TestStep]
| Guard SourceLine (Expr Bool)
| Wait