summaryrefslogtreecommitdiff
path: root/src/Network.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-04-25 22:07:43 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2023-04-25 22:07:43 +0200
commitdab23fd7890ea2c27096015bb49ec526fafa14c7 (patch)
tree1473bcbadf3237879c0d132b5cd57871db0815a9 /src/Network.hs
parent7ed6a184f15975d694657124c01d00ef6b394531 (diff)
Link type and associated functions
Diffstat (limited to 'src/Network.hs')
-rw-r--r--src/Network.hs55
1 files changed, 26 insertions, 29 deletions
diff --git a/src/Network.hs b/src/Network.hs
index e223277..247ef02 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -58,6 +58,7 @@ data Internet = Internet
data Network = Network
{ netPrefix :: IpPrefix
, netNetns :: NetworkNamespace
+ , netBridge :: Link Bridge
, netNodes :: TVar [Node]
, netSubnets :: TVar [(Word8, Network)]
, netDir :: FilePath
@@ -98,7 +99,7 @@ instance HasNetns Node where getNetns = nodeNetns
instance ExprType Network where
textExprType _ = T.pack "network"
textExprValue n = "s:" <> textNetworkName (netPrefix n)
- emptyVarValue = Network (IpPrefix []) undefined undefined undefined undefined
+ emptyVarValue = Network (IpPrefix []) undefined undefined undefined undefined undefined
instance ExprType Node where
textExprType _ = T.pack "node"
@@ -115,12 +116,10 @@ nextPrefix _ used = maximum (0 : used) + 1
newInternet :: MonadIO m => FilePath -> m Internet
newInternet dir = do
- inet <- atomicallyWithIO $ do
+ atomicallyWithIO $ do
Internet
<$> pure dir
<*> newNetwork (IpPrefix [1]) dir
- initNetwork $ inetRoot inet
- return inet
delInternet :: MonadIO m => Internet -> m ()
delInternet _ = liftIO $ do
@@ -135,7 +134,6 @@ newSubnet net vname = do
(netDir net </> maybe (T.unpack $ textNetnsName $ getNetns net) (("sub_"++) . unpackVarName) vname)
lift $ modifyTVar (netSubnets net) ((idx, sub) :)
return (sub, idx)
- initNetwork sub
let lan = lanSubnet $ netPrefix sub
lanIp = IpAddress lan
@@ -143,41 +141,40 @@ newSubnet net vname = do
router = lanIp 254
liftIO $ do
- let veth = T.pack $ "veth_s" <> show idx
- callOn net $ "ip link add " <> veth <> " type veth peer name veth0 netns \"" <> textNetnsName (getNetns sub) <> "\""
- callOn net $ "ip addr add dev " <> veth <> " " <> textIpAddressCidr router
- callOn sub $ "ip link set dev veth0 master br0 up" -- this end needs to go up first,
- -- otherwise it sometimes gets stuck with NO-CARRIER for a while.
- callOn net $ "ip link set dev " <> veth <> " up"
+ (vethNet, vethSub) <- addVEth (net, "veth_s" <> T.pack (show idx)) (sub, "veth0")
+ addAddress vethNet router
+ setMaster vethSub (netBridge sub) -- this end needs to go up first, otherwise it
+ linkUp vethSub -- sometimes gets stuck with NO-CARRIER for a while.
+ linkUp vethNet
-- If the new subnet can be split further, routing rule for the whole prefix is needed
when (allowsSubnets (netPrefix sub)) $ callOn net $ "ip route add "
<> textIpNetwork (netPrefix sub)
<> " via " <> textIpAddress bridge
- <> " dev " <> veth
+ <> " dev " <> linkName vethNet
<> " src " <> textIpAddress router
callOn sub $ "ip route add default via " <> textIpAddress router <> " dev br0 src " <> textIpAddress bridge
return sub
newNetwork :: IpPrefix -> FilePath -> WriterT [IO ()] STM Network
newNetwork prefix dir = do
+ postpone $ createDirectoryIfMissing True dir
+
+ netns <- addNetworkNamespace ("s" <> textNetworkName prefix)
+ bridge <- addBridge netns "br0"
+
+ addAddress bridge $ IpAddress (lanSubnet prefix) 1
+ linkUp $ bridge
+ linkUp $ loopback netns
+
Network
<$> pure prefix
- <*> addNetworkNamespace ("s" <> textNetworkName prefix)
+ <*> pure netns
+ <*> pure bridge
<*> lift (newTVar [])
<*> lift (newTVar [])
<*> pure dir
-initNetwork :: MonadIO m => Network -> m ()
-initNetwork net = liftIO $ do
- let lan = lanSubnet $ netPrefix net
- lanIp = IpAddress lan
- createDirectoryIfMissing True $ netDir 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"
- callOn net $ "ip link set dev lo up"
-
newNode :: MonadIO m => Network -> VarName -> m Node
newNode net vname = liftIO $ do
let lan = lanSubnet $ netPrefix net
@@ -202,12 +199,12 @@ newNode net vname = liftIO $ do
when exists $ ioError $ userError $ dir ++ " exists"
createDirectoryIfMissing True dir
- let veth = T.pack $ "veth" <> show idx
- callOn net $ "ip link add " <> veth <> " type veth peer name veth0 netns \"" <> textNetnsName (getNetns 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"
- callOn node $ "ip link set dev lo up"
+ (vethNet, vethNode) <- addVEth (net, "veth" <> T.pack (show idx)) (node, "veth0")
+ setMaster vethNet $ netBridge net
+ linkUp vethNet
+ addAddress vethNode $ nodeIp node
+ linkUp $ vethNode
+ linkUp $ loopback node
callOn node $ "ip route add default via " <> textIpAddress (lanIp 1) <> " dev veth0 src " <> textIpAddress (nodeIp node)
return node