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
214
215
216
|
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 Control.Monad.Writer
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
, netNetns :: NetworkNamespace
, netBridge :: Link Bridge
, netNodes :: TVar [Node]
, netSubnets :: TVar [(Word8, Network)]
, netDir :: FilePath
}
textNetworkName :: IpPrefix -> Text
textNetworkName (IpPrefix prefix) = T.intercalate "_" (map (T.pack . show) prefix)
data Node = Node
{ nodeIp :: IpAddress
, nodeName :: NodeName
, nodeNetns :: NetworkNamespace
, 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 getNetns = netNetns
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 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 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
atomicallyWithIO $ do
Internet
<$> pure dir
<*> newNetwork (IpPrefix [1]) dir
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) <- atomicallyWithIO $ do
idx <- lift $ nextPrefix (netPrefix net) . map fst <$> readTVar (netSubnets net)
sub <- newNetwork
(ipSubnet idx (netPrefix net))
(netDir net </> maybe (T.unpack $ textNetnsName $ getNetns net) (("sub_"++) . unpackVarName) vname)
lift $ modifyTVar (netSubnets net) ((idx, sub) :)
return (sub, idx)
let lan = lanSubnet $ netPrefix sub
lanIp = IpAddress lan
bridge = lanIp 1
router = lanIp 254
liftIO $ do
(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 " <> 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
<*> pure netns
<*> pure bridge
<*> lift (newTVar [])
<*> lift (newTVar [])
<*> pure dir
newNode :: MonadIO m => Network -> VarName -> m Node
newNode net vname = liftIO $ do
let lan = lanSubnet $ netPrefix net
lanIp = IpAddress lan
(node, idx) <- atomicallyWithIO $ do
nodes <- lift $ readTVar (netNodes net)
let nname = nextNodeName vname $ map nodeName nodes
netns <- addNetworkNamespace $ textNetnsName (getNetns net) <> ":" <> textNodeName nname
let idx = fromIntegral $ 2 + length nodes
node = Node { nodeName = nname
, nodeNetns = netns
, nodeIp = lanIp idx
, nodeNetwork = net
, nodeDir = netDir net </> ("node_" ++ unpackNodeName nname)
}
lift $ writeTVar (netNodes net) (node : nodes)
return (node, idx)
let dir = nodeDir node
exists <- doesPathExist dir
when exists $ ioError $ userError $ dir ++ " exists"
createDirectoryIfMissing True dir
(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
atomicallyWithIO :: MonadIO m => WriterT [IO ()] STM a -> m a
atomicallyWithIO act = liftIO $ do
(x, fin) <- atomically $ runWriterT act
sequence_ fin
return x
|