From 2143eb381fc28e2d676a9c9a433426b1b2dbf737 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Fri, 7 Oct 2022 11:09:44 +0200
Subject: Process variables and expression type

---
 src/Main.hs         | 25 ++++++++++---------------
 src/Parser.hs       |  2 ++
 src/Process.hs      |  7 +++++++
 src/Process.hs-boot |  4 ++++
 src/Test.hs         |  8 ++++----
 5 files changed, 27 insertions(+), 19 deletions(-)
 create mode 100644 src/Process.hs-boot

(limited to 'src')

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
 
-- 
cgit v1.2.3