From 95e2468b3c92e6689a5de4a2c03a79b3ef035f8b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 2 Apr 2023 21:02:47 +0200
Subject: Disconnect commands

---
 src/Run.hs | 45 +++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 43 insertions(+), 2 deletions(-)

(limited to 'src/Run.hs')

diff --git a/src/Run.hs b/src/Run.hs
index 3591926..5b0ac2e 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -12,6 +12,7 @@ import Control.Monad.Reader
 
 import Data.Map qualified as M
 import Data.Maybe
+import Data.Set qualified as S
 import Data.Scientific
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -60,6 +61,8 @@ runTest out opts test = do
             { tsNetwork = error "network not initialized"
             , tsVars = []
             , tsNodePacketLoss = M.empty
+            , tsDisconnectedUp = S.empty
+            , tsDisconnectedBridge = S.empty
             }
 
     let sigHandler SignalInfo { siginfoSpecific = chld } = do
@@ -149,6 +152,18 @@ evalSteps = mapM_ $ \case
     Guard line expr -> do
         testStepGuard line expr
 
+    DisconnectNode node inner -> do
+        n <- eval node
+        withDisconnectedUp n $ evalSteps inner
+
+    DisconnectNodes net inner -> do
+        n <- eval net
+        withDisconnectedBridge n $ evalSteps inner
+
+    DisconnectUpstream net inner -> do
+        n <- eval net
+        withDisconnectedUp n $ evalSteps inner
+
     PacketLoss loss node inner -> do
         l <- eval loss
         n <- eval node
@@ -190,16 +205,42 @@ withNode netexpr tvname inner = do
     node <- newNode net (either fromTypedVarName fromTypedVarName tvname)
     either (flip withVar node . fromTypedVarName) (const id) tvname $ inner node
 
+withDisconnectedUp :: HasNetns n => n -> TestRun a -> TestRun a
+withDisconnectedUp n inner = do
+    let netns = netnsName n
+    disconnected <- asks $ S.member netns . tsDisconnectedUp . snd
+    if disconnected
+      then inner
+      else do
+        local (fmap $ \s -> s { tsDisconnectedUp = S.insert netns $ tsDisconnectedUp s }) $ do
+            liftIO $ callOn n $ "ip link set veth0 down"
+            x <- inner
+            liftIO $ callOn n $ "ip link set veth0 up"
+            return x
+
+withDisconnectedBridge :: HasNetns n => n -> TestRun a -> TestRun a
+withDisconnectedBridge n inner = do
+    let netns = netnsName n
+    disconnected <- asks $ S.member netns . tsDisconnectedBridge . snd
+    if disconnected
+      then inner
+      else do
+        local (fmap $ \s -> s { tsDisconnectedBridge = S.insert netns $ tsDisconnectedBridge s }) $ do
+            liftIO $ callOn n $ "ip link set br0 down"
+            x <- inner
+            liftIO $ callOn n $ "ip link set br0 up"
+            return x
+
 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
+    x <- local (fmap $ \s -> s { tsNodePacketLoss = M.insertWith (\l l' -> 1 - (1 - l) * (1 - l')) (netnsName node) loss $ tsNodePacketLoss s }) $ do
         resetLoss
         inner
     resetLoss
     return x
   where
     resetLoss = do
-        tl <- asks $ fromMaybe 0 . M.lookup (nodeName node) . tsNodePacketLoss . snd
+        tl <- asks $ fromMaybe 0 . M.lookup (netnsName node) . tsNodePacketLoss . snd
         liftIO $ callOn node $ "tc qdisc replace dev veth0 root netem loss " <> T.pack (show (tl * 100)) <> "%"
 
 
-- 
cgit v1.2.3