Packet loss command using netem qdisc

3 files changed, 34 insertions, 4 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 28b88ae..4ceaac4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -7,6 +7,8 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 
+import Data.Map (Map)
+import Data.Map qualified as M
 import Data.Maybe
 import Data.Scientific
 import Data.Text (Text)
@@ -63,6 +65,7 @@ data TestEnv = TestEnv
 data TestState = TestState
     { tsNetwork :: Network
     , tsVars :: [(VarName, SomeVarValue)]
+    , tsNodePacketLoss :: Map NodeName Scientific
     }
 
 newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT () IO) a }
@@ -90,6 +93,19 @@ instance MonadOutput TestRun where
 withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a
 withVar name value = local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s })
 
+withNodePacketLoss :: Node -> Scientific -> TestRun a -> TestRun a
+withNodePacketLoss node loss inner = do
+    x <- local (fmap $ \s -> s { tsNodePacketLoss = M.insertWith (\l l' -> 1 - (1 - l) * (1 - l')) (nodeName node) loss $ tsNodePacketLoss s }) $ do
+        resetLoss
+        inner
+    resetLoss
+    return x
+  where
+    resetLoss = do
+        tl <- asks $ fromMaybe 0 . M.lookup (nodeName node) . tsNodePacketLoss . snd
+        liftIO $ callOn node $ "tc qdisc replace dev veth0 root netem loss " ++ show (tl * 100) ++ "%"
+        liftIO $ putStrLn $ "tc qdisc replace dev veth0 root netem loss " ++ show (tl * 100) ++ "%"
+
 forkTest :: TestRun () -> TestRun ()
 forkTest act = do
     tenv <- ask
@@ -174,10 +190,10 @@ createNode (TypedVarName vname) inner = do
         createDirectoryIfMissing True dir
 
         callCommand $ "ip netns add \""++ name ++ "\""
-        callCommand $ "ip link add \"veth_" ++ name ++ ".0\" group 1 type veth peer name \"veth_" ++ name ++ ".1\" netns \"" ++ name ++ "\""
-        callCommand $ "ip link set dev \"veth_" ++ name ++ ".0\" master br0 up"
-        callOn node $ "ip addr add " ++ T.unpack (nodeIp node) ++ "/24 broadcast 192.168.0.255 dev \"veth_" ++ name ++ ".1\""
-        callOn node $ "ip link set dev \"veth_" ++ name++ ".1\" up"
+        callCommand $ "ip link add \"veth_" ++ name ++ "\" group 1 type veth peer name veth0 netns \"" ++ name ++ "\""
+        callCommand $ "ip link set dev \"veth_" ++ name ++ "\" master br0 up"
+        callOn node $ "ip addr add " ++ T.unpack (nodeIp node) ++ "/24 broadcast 192.168.0.255 dev veth0"
+        callOn node $ "ip link set dev veth0 up"
         callOn node $ "ip link set dev lo up"
         return node
 
@@ -329,6 +345,11 @@ evalSteps = mapM_ $ \case
     Guard line expr -> do
         testStepGuard line expr
 
+    PacketLoss loss node inner -> do
+        l <- eval loss
+        n <- eval node
+        withNodePacketLoss n l $ evalSteps inner
+
     Wait -> do
         outPrompt $ T.pack "Waiting..."
         void $ liftIO $ getLine
@@ -343,6 +364,7 @@ runTest out opts test = do
     tstate <- TestState
         <$> pure (error "network not initialized")
         <*> pure []
+        <*> pure M.empty
     (fmap $ either (const False) id) $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ initNetwork $ \net -> do
         let sigHandler SignalInfo { siginfoSpecific = chld } = do
                 processes <- readMVar (netProcesses net)
diff --git a/src/Parser.hs b/src/Parser.hs
index 29583e1..7773bae 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -500,6 +500,12 @@ testGuard = command "guard" $ Guard
     <$> cmdLine
     <*> param ""
 
+testPacketLoss :: TestParser [TestStep]
+testPacketLoss = command "packet_loss" $ PacketLoss
+    <$> param ""
+    <*> param "on"
+    <*> innerBlock
+
 
 testWait :: TestParser [TestStep]
 testWait = do
@@ -526,6 +532,7 @@ testStep = choice
     , testSend
     , testExpect
     , testGuard
+    , testPacketLoss
     , testWait
     ]
 
diff --git a/src/Test.hs b/src/Test.hs
index ab7e125..5a45930 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -37,6 +37,7 @@ data TestStep = forall a. ExprType a => Let SourceLine VarName (Expr a) [TestSte
               | Send (Expr Process) (Expr Text)
               | Expect SourceLine (Expr Process) (Expr Regex) [TypedVarName Text] [TestStep]
               | Guard SourceLine (Expr Bool)
+              | PacketLoss (Expr Scientific) (Expr Node) [TestStep]
               | Wait
 
 newtype SourceLine = SourceLine Text