1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
|
module Network (
Internet(..),
Network(..),
Node(..),
NodeName(..), textNodeName, unpackNodeName,
nextNodeName,
newInternet, delInternet,
newSubnet,
newNode,
) where
import Control.Arrow
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.IO.Class
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word
import System.Directory
import System.FilePath
import System.Process
import Network.Ip
import Test
{-
NETWORK STRUCTURE
=================
Local network (namespace "s<PREFIX>", e.g. "s1_2"):
(upstream, if any) (to subnets, if any and prefix length < 24)
↑ veth_s1 (IP: prefix.1(.0)*.254)
veth0 veth_s2 (IP: prefix.2(.0)*.254) → veth0 in subnet namespace
| veth_s3 (IP: prefix.3(.0)*.254)
br0 (IP: prefix(.0)*.1/24) ...
/ | \
veth2 ... veth253
↓ ↓ ↓
(to nodes)
Node (namespace "s<PREFIX>:<NODE>", e.g. "s1_2:p0"):
(upstream)
↑
veth0 (IP: prefix.N/24)
-}
data Internet = Internet
{ inetDir :: FilePath
, inetRoot :: Network
}
data Network = Network
{ netPrefix :: IpPrefix
, netNodes :: TVar [Node]
, netSubnets :: TVar [(Word8, Network)]
, netDir :: FilePath
}
textNetworkName :: Network -> Text
textNetworkName Network { netPrefix = IpPrefix prefix } = T.intercalate "_" (map (T.pack . show) prefix)
data Node = Node
{ nodeIp :: IpAddress
, nodeName :: NodeName
, nodeNetwork :: Network
, nodeDir :: FilePath
}
data NodeName = NodeName Text Word
deriving (Eq, Ord)
textNodeName :: NodeName -> Text
textNodeName (NodeName name 0) = name
textNodeName (NodeName name num) = name <> T.pack "~" <> T.pack (show num)
unpackNodeName :: NodeName -> String
unpackNodeName = T.unpack . textNodeName
nextNodeName :: VarName -> [NodeName] -> NodeName
nextNodeName (VarName tname) = go 0
where
go n [] = NodeName tname n
go n (NodeName tname' m : ns) | tname == tname' = go (max n m + 1) ns
| otherwise = go n ns
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"
textExprValue n = "s:" <> textNetworkName n
emptyVarValue = Network (IpPrefix []) undefined undefined undefined
instance ExprType Node where
textExprType _ = T.pack "node"
textExprValue n = T.pack "n:" <> textNodeName (nodeName n)
emptyVarValue = Node (IpAddress (IpPrefix []) 0) (NodeName T.empty 0) undefined undefined
recordMembers = map (first T.pack)
[ ("ip", RecordSelector $ textIpAddress . nodeIp)
]
nextPrefix :: IpPrefix -> [Word8] -> Word8
nextPrefix _ used = maximum (0 : used) + 1
newInternet :: MonadIO m => FilePath -> m Internet
newInternet dir = do
inet <- liftIO $ atomically $ do
Internet
<$> pure dir
<*> newNetwork (IpPrefix [1]) dir
initNetwork $ inetRoot inet
return inet
delInternet :: MonadIO m => Internet -> m ()
delInternet _ = liftIO $ do
callCommand $ "ip -all netns delete"
newSubnet :: MonadIO m => Network -> Maybe VarName -> m Network
newSubnet net vname = do
(sub, idx) <- liftIO $ atomically $ do
idx <- nextPrefix (netPrefix net) . map fst <$> readTVar (netSubnets net)
sub <- newNetwork
(ipSubnet idx (netPrefix net))
(netDir net </> maybe (T.unpack $ textNetnsName $ netnsName net) (("sub_"++) . unpackVarName) vname)
modifyTVar (netSubnets net) ((idx, sub) :)
return (sub, idx)
initNetwork sub
let lan = lanSubnet $ netPrefix sub
lanIp = IpAddress lan
bridge = lanIp 1
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 (netnsName 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"
-- 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
<> " src " <> textIpAddress router
callOn sub $ "ip route add default via " <> textIpAddress router <> " dev br0 src " <> textIpAddress bridge
return sub
newNetwork :: IpPrefix -> FilePath -> STM Network
newNetwork prefix dir = do
Network
<$> pure prefix
<*> newTVar []
<*> newTVar []
<*> pure dir
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 \"" <> 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"
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
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 = lanIp idx
, nodeNetwork = net
, nodeDir = netDir net </> ("node_" ++ unpackNodeName nname)
}
writeTVar (netNodes net) (node : nodes)
return (node, idx)
let dir = nodeDir node
exists <- doesPathExist dir
when exists $ ioError $ userError $ dir ++ " exists"
createDirectoryIfMissing True dir
let veth = T.pack $ "veth" <> show idx
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"
callOn node $ "ip link set dev lo up"
callOn node $ "ip route add default via " <> textIpAddress (lanIp 1) <> " dev veth0 src " <> textIpAddress (nodeIp node)
return node
|