summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--erebos-tester.cabal1
-rw-r--r--src/Network.hs60
-rw-r--r--src/Network/Ip.hs45
3 files changed, 80 insertions, 26 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index 043dd79..992e45e 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -37,6 +37,7 @@ executable erebos-tester-core
other-modules: Config
GDB
Network
+ Network.Ip
Output
Parser
Paths_erebos_tester
diff --git a/src/Network.hs b/src/Network.hs
index ec0b380..d3262df 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -26,6 +26,7 @@ import System.Directory
import System.FilePath
import System.Process
+import Network.Ip
import Test
{-
@@ -57,18 +58,18 @@ data Internet = Internet
}
data Network = Network
- { netPrefix :: [Word8]
+ { netPrefix :: IpPrefix
, netNodes :: TVar [Node]
, netSubnets :: TVar [(Word8, Network)]
, netDir :: FilePath
}
textNetworkName :: Network -> Text
-textNetworkName n = T.intercalate "_" (map (T.pack . show) (netPrefix n))
+textNetworkName Network { netPrefix = IpPrefix prefix } = T.intercalate "_" (map (T.pack . show) prefix)
data Node = Node
- { nodeName :: NodeName
- , nodeIp :: Text
+ { nodeIp :: IpAddress
+ , nodeName :: NodeName
, nodeNetwork :: Network
, nodeDir :: FilePath
}
@@ -102,30 +103,27 @@ callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> netnsName n <> "\"
instance ExprType Network where
textExprType _ = T.pack "network"
textExprValue n = "s:" <> textNetworkName n
- emptyVarValue = Network [] undefined undefined undefined
+ emptyVarValue = Network (IpPrefix []) undefined undefined undefined
instance ExprType Node where
textExprType _ = T.pack "node"
textExprValue n = T.pack "n:" <> textNodeName (nodeName n)
- emptyVarValue = Node (NodeName T.empty 0) T.empty undefined undefined
+ emptyVarValue = Node (IpAddress (IpPrefix []) 0) (NodeName T.empty 0) undefined undefined
recordMembers = map (first T.pack)
- [ ("ip", RecordSelector $ nodeIp)
+ [ ("ip", RecordSelector $ textIpAddress . nodeIp)
]
-nextPrefix :: [Word8] -> [Word8] -> Word8
+nextPrefix :: IpPrefix -> [Word8] -> Word8
nextPrefix _ used = maximum (0 : used) + 1
-makeIpAddress :: [Word8] -> Word8 -> Text
-makeIpAddress prefix num = T.intercalate "." $ map (T.pack . show) $ prefix ++ replicate (3 - length prefix) 0 ++ [num]
-
newInternet :: MonadIO m => FilePath -> m Internet
newInternet dir = do
inet <- liftIO $ atomically $ do
Internet
<$> pure dir
- <*> newNetwork [1] dir
+ <*> newNetwork (IpPrefix [1]) dir
initNetwork $ inetRoot inet
return inet
@@ -138,28 +136,34 @@ newSubnet net vname = do
sub <- liftIO $ atomically $ do
pref <- nextPrefix (netPrefix net) . map fst <$> readTVar (netSubnets net)
sub <- newNetwork
- (netPrefix net ++ [pref])
+ (ipSubnet pref (netPrefix net))
(netDir net </> maybe (T.unpack $ netnsName net) (("sub_"++) . unpackVarName) vname)
modifyTVar (netSubnets net) ((pref, sub) :)
return sub
initNetwork sub
+
+ let lan = lanSubnet $ netPrefix sub
+ lanIp = IpAddress lan
+ bridge = lanIp 1
+ router = lanIp 254
+
liftIO $ do
callOn net $ "ip link add \"veth_" <> netnsName sub <> "\" type veth peer name veth0 netns \"" <> netnsName sub <> "\""
- callOn net $ "ip addr add dev \"veth_" <> netnsName sub <> "\" " <> makeIpAddress (netPrefix sub) 254 <> "/24"
+ callOn net $ "ip addr add dev \"veth_" <> netnsName sub <> "\" " <> textIpAddressCidr router
callOn net $ "ip link set dev \"veth_" <> netnsName sub <> "\" up"
-- If the new subnet can be split further, routing rule for the whole prefix is needed
- when (length (netPrefix sub) < 3) $ callOn net $ "ip route add "
- <> makeIpAddress (netPrefix sub) 0 <> "/" <> (T.pack $ show $ length (netPrefix sub) * 8)
- <> " via " <> makeIpAddress (netPrefix sub) 1
- <> " dev \"veth_" <> netnsName sub
- <> "\" src " <> makeIpAddress (netPrefix sub) 254
+ when (allowsSubnets (netPrefix sub)) $ callOn net $ "ip route add "
+ <> textIpNetwork (netPrefix sub)
+ <> " via " <> textIpAddress bridge
+ <> " dev \"veth_" <> netnsName sub <> "\""
+ <> " src " <> textIpAddress router
callOn sub $ "ip link set dev veth0 master br0 up"
- callOn sub $ "ip route add default via " <> makeIpAddress (netPrefix sub) 254 <> " dev br0 src " <> makeIpAddress (netPrefix sub) 1
+ callOn sub $ "ip route add default via " <> textIpAddress router <> " dev br0 src " <> textIpAddress bridge
return sub
-newNetwork :: [Word8] -> FilePath -> STM Network
+newNetwork :: IpPrefix -> FilePath -> STM Network
newNetwork prefix dir = do
Network
<$> pure prefix
@@ -169,22 +173,26 @@ newNetwork prefix dir = do
initNetwork :: MonadIO m => Network -> m ()
initNetwork net = liftIO $ do
+ let lan = lanSubnet $ netPrefix net
+ lanIp = IpAddress lan
createDirectoryIfMissing True $ netDir net
callCommand $ T.unpack $ "ip netns add \"" <> netnsName net <> "\""
callOn net $ "ip link add name br0 type bridge"
- callOn net $ "ip addr add " <> makeIpAddress (netPrefix net) 1 <> " broadcast " <> makeIpAddress (netPrefix net) 255 <> " dev br0"
+ callOn net $ "ip addr add " <> textIpAddressCidr (lanIp 1) <> " broadcast " <> textIpAddress (lanIp 255) <> " dev br0"
callOn net $ "ip link set dev br0 up"
callOn net $ "ip link set dev lo up"
- callOn net $ "ip route add " <> makeIpAddress (netPrefix net) 0 <> "/24 dev br0 src " <> makeIpAddress (netPrefix net) 1
newNode :: MonadIO m => Network -> VarName -> m Node
newNode net vname = liftIO $ do
+ let lan = lanSubnet $ netPrefix net
+ lanIp = IpAddress lan
+
(node, idx) <- atomically $ do
nodes <- readTVar (netNodes net)
let nname = nextNodeName vname $ map nodeName nodes
idx = fromIntegral $ 2 + length nodes
node = Node { nodeName = nname
- , nodeIp = makeIpAddress (netPrefix net) idx
+ , nodeIp = lanIp idx
, nodeNetwork = net
, nodeDir = netDir net </> ("node_" ++ unpackNodeName nname)
}
@@ -200,9 +208,9 @@ newNode net vname = liftIO $ do
callCommand $ T.unpack $ "ip netns add \"" <> netnsName node <> "\""
callOn net $ "ip link add " <> veth <> " type veth peer name veth0 netns \"" <> netnsName node <> "\""
callOn net $ "ip link set dev " <> veth <> " master br0 up"
- callOn node $ "ip addr add " <> nodeIp node <> "/24 broadcast " <> makeIpAddress (netPrefix net) 255 <> " dev veth0"
+ callOn node $ "ip addr add " <> textIpAddressCidr (nodeIp node) <> " broadcast " <> textIpAddress (lanIp 255) <> " dev veth0"
callOn node $ "ip link set dev veth0 up"
callOn node $ "ip link set dev lo up"
- callOn node $ "ip route add default via " <> makeIpAddress (netPrefix net) 1 <> " dev veth0 src " <> nodeIp node
+ callOn node $ "ip route add default via " <> textIpAddress (lanIp 1) <> " dev veth0 src " <> textIpAddress (nodeIp node)
return node
diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs
new file mode 100644
index 0000000..76cc8f4
--- /dev/null
+++ b/src/Network/Ip.hs
@@ -0,0 +1,45 @@
+module Network.Ip (
+ IpPrefix(..),
+ textIpNetwork,
+
+ IpAddress(..),
+ textIpAddress,
+ textIpAddressCidr,
+
+ allowsSubnets,
+ ipSubnet,
+ lanSubnet,
+) where
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Word
+
+newtype IpPrefix = IpPrefix [Word8]
+ deriving (Eq, Ord)
+
+textIpNetwork :: IpPrefix -> Text
+textIpNetwork (IpPrefix prefix) =
+ T.intercalate "." (map (T.pack . show) $ prefix ++ replicate (4 - length prefix) 0)
+ <> "/" <> T.pack (show (8 * length prefix))
+
+data IpAddress = IpAddress IpPrefix Word8
+ deriving (Eq, Ord)
+
+textIpAddress :: IpAddress -> Text
+textIpAddress (IpAddress (IpPrefix prefix) num) =
+ T.intercalate "." $ map (T.pack . show) $ prefix ++ replicate (3 - length prefix) 0 ++ [num]
+
+textIpAddressCidr :: IpAddress -> Text
+textIpAddressCidr ip@(IpAddress (IpPrefix prefix) _) =
+ textIpAddress ip <> "/" <> T.pack (show (8 * length prefix))
+
+allowsSubnets :: IpPrefix -> Bool
+allowsSubnets (IpPrefix prefix) = length prefix < 3
+
+ipSubnet :: Word8 -> IpPrefix -> IpPrefix
+ipSubnet num (IpPrefix prefix) = IpPrefix (prefix ++ [num])
+
+lanSubnet :: IpPrefix -> IpPrefix
+lanSubnet (IpPrefix prefix) = IpPrefix (take 3 $ prefix ++ repeat 0)
+