diff options
| -rw-r--r-- | src/Network.hs | 24 | ||||
| -rw-r--r-- | src/Network/Ip.hs | 19 | ||||
| -rw-r--r-- | src/Process.hs | 3 | ||||
| -rw-r--r-- | src/Run.hs | 1 |
4 files changed, 32 insertions, 15 deletions
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)] @@ -25,6 +25,7 @@ import System.Process import GDB import Network +import Network.Ip import Output import Process import Run.Monad |