diff options
| -rw-r--r-- | src/Main.hs | 30 | ||||
| -rw-r--r-- | src/Parser.hs | 7 | ||||
| -rw-r--r-- | src/Test.hs | 1 |
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 |