From 71786719c2480090c1d2df88bc390b088185d7cb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 1 Apr 2023 19:32:24 +0200
Subject: Network namespace type

---
 src/Network.hs    | 24 ++++++++++--------------
 src/Network/Ip.hs | 19 +++++++++++++++++++
 src/Process.hs    |  3 ++-
 src/Run.hs        |  1 +
 4 files changed, 32 insertions(+), 15 deletions(-)

(limited to 'src')

diff --git a/src/Network.hs b/src/Network.hs
index 4cc74cb..6e3568d 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -5,9 +5,6 @@ module Network (
     NodeName(..), textNodeName, unpackNodeName,
     nextNodeName,
 
-    HasNetns(..),
-    callOn,
-
     newInternet, delInternet,
     newSubnet,
     newNode,
@@ -92,13 +89,12 @@ nextNodeName (VarName tname) = go 0
                                   | otherwise       = go n ns
 
 
-class HasNetns a where netnsName :: a -> Text
-instance HasNetns Network where netnsName n = "s" <> textNetworkName n
-instance HasNetns Node where netnsName n = netnsName (nodeNetwork n) <> ":" <> textNodeName (nodeName n)
-
-callOn :: HasNetns a => a -> Text -> IO ()
-callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> netnsName n <> "\" " <> cmd
+instance HasNetns Network where
+    netnsName n = NetworkNamespace $ "s" <> textNetworkName n
 
+instance HasNetns Node where
+    netnsName n = NetworkNamespace $
+        textNetnsName (netnsName (nodeNetwork n)) <> ":" <> textNodeName (nodeName n)
 
 instance ExprType Network where
     textExprType _ = T.pack "network"
@@ -137,7 +133,7 @@ newSubnet net vname = do
         idx <- nextPrefix (netPrefix net) . map fst <$> readTVar (netSubnets net)
         sub <- newNetwork
             (ipSubnet idx (netPrefix net))
-            (netDir net </> maybe (T.unpack $ netnsName net) (("sub_"++) . unpackVarName) vname)
+            (netDir net </> maybe (T.unpack $ textNetnsName $ netnsName net) (("sub_"++) . unpackVarName) vname)
         modifyTVar (netSubnets net) ((idx, sub) :)
         return (sub, idx)
     initNetwork sub
@@ -149,7 +145,7 @@ newSubnet net vname = do
 
     liftIO $ do
         let veth = T.pack $ "veth_s" <> show idx
-        callOn net $ "ip link add " <> veth <> " type veth peer name veth0 netns \"" <> netnsName sub <> "\""
+        callOn net $ "ip link add " <> veth <> " type veth peer name veth0 netns \"" <> textNetnsName (netnsName sub) <> "\""
         callOn net $ "ip addr add dev " <> veth <> " " <> textIpAddressCidr router
         callOn net $ "ip link set dev " <> veth <> " up"
 
@@ -177,7 +173,7 @@ initNetwork net = liftIO $ do
     let lan = lanSubnet $ netPrefix net
         lanIp = IpAddress lan
     createDirectoryIfMissing True $ netDir net
-    callCommand $ T.unpack $ "ip netns add \"" <> netnsName net <> "\""
+    callCommand $ T.unpack $ "ip netns add \"" <> textNetnsName (netnsName net) <> "\""
     callOn net $ "ip link add name br0 type bridge"
     callOn net $ "ip addr add " <> textIpAddressCidr (lanIp 1) <> " broadcast " <> textIpAddress (lanIp 255) <> " dev br0"
     callOn net $ "ip link set dev br0 up"
@@ -206,8 +202,8 @@ newNode net vname = liftIO $ do
     createDirectoryIfMissing True dir
 
     let veth = T.pack $ "veth" <> show idx
-    callCommand $ T.unpack $ "ip netns add \"" <> netnsName node <> "\""
-    callOn net  $ "ip link add " <> veth <> " type veth peer name veth0 netns \"" <> netnsName node <> "\""
+    callCommand $ T.unpack $ "ip netns add \"" <> textNetnsName (netnsName node) <> "\""
+    callOn net  $ "ip link add " <> veth <> " type veth peer name veth0 netns \"" <> textNetnsName (netnsName node) <> "\""
     callOn net  $ "ip link set dev " <> veth <> " master br0 up"
     callOn node $ "ip addr add " <> textIpAddressCidr (nodeIp node) <> " broadcast " <> textIpAddress (lanIp 255) <> " dev veth0"
     callOn node $ "ip link set dev veth0 up"
diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs
index 76cc8f4..7488829 100644
--- a/src/Network/Ip.hs
+++ b/src/Network/Ip.hs
@@ -9,12 +9,19 @@ module Network.Ip (
     allowsSubnets,
     ipSubnet,
     lanSubnet,
+
+    NetworkNamespace(..),
+    HasNetns(..),
+    textNetnsName,
+    callOn,
 ) where
 
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Word
 
+import System.Process
+
 newtype IpPrefix = IpPrefix [Word8]
     deriving (Eq, Ord)
 
@@ -43,3 +50,15 @@ ipSubnet num (IpPrefix prefix) = IpPrefix (prefix ++ [num])
 lanSubnet :: IpPrefix -> IpPrefix
 lanSubnet (IpPrefix prefix) = IpPrefix (take 3 $ prefix ++ repeat 0)
 
+
+newtype NetworkNamespace = NetworkNamespace Text
+    deriving (Eq, Ord)
+
+class HasNetns a where netnsName :: a -> NetworkNamespace
+
+textNetnsName :: NetworkNamespace -> Text
+textNetnsName (NetworkNamespace name) = name
+
+callOn :: HasNetns a => a -> Text -> IO ()
+callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> ns <> "\" " <> cmd
+    where NetworkNamespace ns = netnsName n
diff --git a/src/Process.hs b/src/Process.hs
index a90a734..09745fb 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -29,6 +29,7 @@ import System.Process
 
 import {-# SOURCE #-} GDB
 import Network
+import Network.Ip
 import Output
 import Run.Monad
 import Test
@@ -89,7 +90,7 @@ lineReadingLoop process h act =
 spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process
 spawnOn target pname killWith cmd = do
     let netns = either netnsName netnsName target
-    let prefix = T.unpack $ "ip netns exec \"" <> netns <> "\" "
+    let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" "
     (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd)
         { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
         , env = Just [("EREBOS_DIR", either netDir nodeDir target)]
diff --git a/src/Run.hs b/src/Run.hs
index d771116..3591926 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -25,6 +25,7 @@ import System.Process
 
 import GDB
 import Network
+import Network.Ip
 import Output
 import Process
 import Run.Monad
-- 
cgit v1.2.3