summaryrefslogtreecommitdiff
path: root/src/Network.hs
blob: d892404ea696e177aefdb7da6bc1e462307e6592 (plain)
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