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
|
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
, netUpstream :: Maybe (Link VEth)
, 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
, nodeUpstream :: Link VEth
, 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 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 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 = 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) :)
let lan = lanSubnet $ netPrefix sub
lanIp = IpAddress lan
bridge = lanIp 1
router = lanIp 254
(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)) $ do
addRoute (netPrefix sub) bridge vethNet router
addRoute (IpPrefix []) router (netBridge sub) bridge
return sub { netUpstream = Just vethSub }
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
<*> pure Nothing
<*> lift (newTVar [])
<*> lift (newTVar [])
<*> pure dir
newNode :: MonadIO m => Network -> VarName -> m Node
newNode nodeNetwork vname = atomicallyWithIO $ do
let lan = lanSubnet $ netPrefix nodeNetwork
lanIp = IpAddress lan
nodes <- lift $ readTVar (netNodes nodeNetwork)
let nodeName = nextNodeName vname $ map Network.nodeName nodes
idx = fromIntegral $ 2 + length nodes
nodeIp = lanIp idx
nodeDir = netDir nodeNetwork </> ("node_" ++ unpackNodeName nodeName)
nodeNetns <- addNetworkNamespace $ textNetnsName (getNetns nodeNetwork) <> ":" <> textNodeName nodeName
(vethNet, nodeUpstream) <- addVEth (nodeNetwork, "veth" <> T.pack (show idx)) (nodeNetns, "veth0")
postpone $ do
exists <- doesPathExist nodeDir
when exists $ ioError $ userError $ nodeDir ++ " exists"
createDirectoryIfMissing True nodeDir
let node = Node {..}
lift $ writeTVar (netNodes nodeNetwork) (node : nodes)
setMaster vethNet $ netBridge nodeNetwork
linkUp vethNet
addAddress nodeUpstream $ nodeIp
linkUp $ nodeUpstream
linkUp $ loopback node
addRoute (IpPrefix []) (lanIp 1) nodeUpstream nodeIp
return node
|