diff options
| -rw-r--r-- | src/Main.hs | 25 | ||||
| -rw-r--r-- | src/Parser.hs | 2 | ||||
| -rw-r--r-- | src/Process.hs | 7 | ||||
| -rw-r--r-- | src/Process.hs-boot | 4 | ||||
| -rw-r--r-- | src/Test.hs | 8 |
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 |