diff options
| -rw-r--r-- | erebos-tester.cabal | 1 | ||||
| -rw-r--r-- | src/Network.hs | 83 | ||||
| -rw-r--r-- | src/Network/Ip.hs | 6 | ||||
| -rw-r--r-- | src/Run.hs | 28 | ||||
| -rw-r--r-- | src/Run/Monad.hs | 3 |
5 files changed, 62 insertions, 59 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal index 0078481..135af97 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -62,6 +62,7 @@ executable erebos-tester-core MultiParamTypeClasses OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables TupleSections TypeApplications diff --git a/src/Network.hs b/src/Network.hs index 247ef02..50dc7a3 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -59,6 +59,7 @@ data Network = Network { netPrefix :: IpPrefix , netNetns :: NetworkNamespace , netBridge :: Link Bridge + , netUpstream :: Maybe (Link VEth) , netNodes :: TVar [Node] , netSubnets :: TVar [(Word8, Network)] , netDir :: FilePath @@ -71,6 +72,7 @@ data Node = Node { nodeIp :: IpAddress , nodeName :: NodeName , nodeNetns :: NetworkNamespace + , nodeUpstream :: Link VEth , nodeNetwork :: Network , nodeDir :: FilePath } @@ -99,12 +101,12 @@ 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 + 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 + emptyVarValue = Node (IpAddress (IpPrefix []) 0) (NodeName T.empty 0) undefined undefined undefined undefined recordMembers = map (first T.pack) [ ("ip", RecordSelector $ textIpAddress . nodeIp) @@ -126,27 +128,25 @@ 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) +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 - 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 + (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 + postpone $ do -- 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) @@ -154,7 +154,7 @@ newSubnet net vname = do <> " dev " <> linkName vethNet <> " src " <> textIpAddress router callOn sub $ "ip route add default via " <> textIpAddress router <> " dev br0 src " <> textIpAddress bridge - return sub + return sub { netUpstream = Just vethSub } newNetwork :: IpPrefix -> FilePath -> WriterT [IO ()] STM Network newNetwork prefix dir = do @@ -171,41 +171,38 @@ newNetwork prefix dir = do <$> pure prefix <*> pure netns <*> pure bridge + <*> pure Nothing <*> lift (newTVar []) <*> lift (newTVar []) <*> pure dir newNode :: MonadIO m => Network -> VarName -> m Node -newNode net vname = liftIO $ do - let lan = lanSubnet $ netPrefix net +newNode nodeNetwork vname = atomicallyWithIO $ do + let lan = lanSubnet $ netPrefix nodeNetwork 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 + 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 vethNode $ nodeIp node - linkUp $ vethNode + addAddress nodeUpstream $ nodeIp + linkUp $ nodeUpstream linkUp $ loopback node - callOn node $ "ip route add default via " <> textIpAddress (lanIp 1) <> " dev veth0 src " <> textIpAddress (nodeIp node) + postpone $ callOn node $ "ip route add default via " <> textIpAddress (lanIp 1) <> " dev veth0 src " <> textIpAddress nodeIp return node diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs index 13fc284..e3d95cb 100644 --- a/src/Network/Ip.hs +++ b/src/Network/Ip.hs @@ -130,10 +130,10 @@ addAddress link addr@(IpAddress prefix _) = do let bcast = IpAddress prefix 255 postpone $ callOn link $ "ip addr add " <> textIpAddressCidr addr <> " broadcast " <> textIpAddress bcast <> " dev \"" <> linkName link <> "\"" -setMaster :: (MonadPIO m, MonadFail m) => Link a -> Link Bridge -> m () -setMaster link bridge = do +setMaster :: MonadPIO m => Link a -> Link Bridge -> m () +setMaster link bridge = postpone $ do when (getNetns link /= getNetns bridge) $ fail "link and bridge in different network namespaces" - postpone $ callOn link $ "ip link set dev \"" <> linkName link <> "\" master \"" <> linkName bridge <> "\"" + callOn link $ "ip link set dev \"" <> linkName link <> "\" master \"" <> linkName bridge <> "\"" linkUp :: MonadPIO m => Link a -> m () linkUp link = do @@ -154,15 +154,17 @@ evalSteps = mapM_ $ \case DisconnectNode node inner -> do n <- eval node - withDisconnectedUp n $ evalSteps inner + withDisconnectedUp (nodeUpstream n) $ evalSteps inner DisconnectNodes net inner -> do n <- eval net - withDisconnectedBridge n $ evalSteps inner + withDisconnectedBridge (netBridge n) $ evalSteps inner DisconnectUpstream net inner -> do n <- eval net - withDisconnectedUp n $ evalSteps inner + case netUpstream n of + Just link -> withDisconnectedUp link $ evalSteps inner + Nothing -> evalSteps inner PacketLoss loss node inner -> do l <- eval loss @@ -205,30 +207,30 @@ withNode netexpr tvname inner = do node <- newNode net (either fromTypedVarName fromTypedVarName tvname) either (flip withVar node . fromTypedVarName) (const id) tvname $ inner node -withDisconnectedUp :: HasNetns n => n -> TestRun a -> TestRun a -withDisconnectedUp n inner = do - let netns = getNetns n +withDisconnectedUp :: Link VEth -> TestRun a -> TestRun a +withDisconnectedUp link inner = do + let netns = getNetns link disconnected <- asks $ S.member netns . tsDisconnectedUp . snd if disconnected then inner else do local (fmap $ \s -> s { tsDisconnectedUp = S.insert netns $ tsDisconnectedUp s }) $ do - liftIO $ callOn n $ "ip link set veth0 down" + linkDown link x <- inner - liftIO $ callOn n $ "ip link set veth0 up" + linkUp link return x -withDisconnectedBridge :: HasNetns n => n -> TestRun a -> TestRun a -withDisconnectedBridge n inner = do - let netns = getNetns n +withDisconnectedBridge :: Link Bridge -> TestRun a -> TestRun a +withDisconnectedBridge bridge inner = do + let netns = getNetns bridge disconnected <- asks $ S.member netns . tsDisconnectedBridge . snd if disconnected then inner else do local (fmap $ \s -> s { tsDisconnectedBridge = S.insert netns $ tsDisconnectedBridge s }) $ do - liftIO $ callOn n $ "ip link set br0 down" + linkDown bridge x <- inner - liftIO $ callOn n $ "ip link set br0 up" + linkUp bridge return x withNodePacketLoss :: Node -> Scientific -> TestRun a -> TestRun a diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 1036749..037f585 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -97,6 +97,9 @@ instance MonadEval TestRun where instance MonadOutput TestRun where getOutput = asks $ teOutput . fst +instance MonadPIO TestRun where + postpone = liftIO + finally :: MonadError e m => m a -> m b -> m a finally act handler = do |