From e2a44c2118c62817e26eb88ed3ac4f292b908047 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Fri, 7 Oct 2022 18:15:29 +0200
Subject: Packet loss command using netem qdisc
---
src/Main.hs | 30 ++++++++++++++++++++++++++----
src/Parser.hs | 7 +++++++
src/Test.hs | 1 +
3 files changed, 34 insertions(+), 4 deletions(-)
(limited to 'src')
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
--
cgit v1.2.3