summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--erebos-tester.cabal1
-rw-r--r--src/Network.hs83
-rw-r--r--src/Network/Ip.hs6
-rw-r--r--src/Run.hs28
-rw-r--r--src/Run/Monad.hs3
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
diff --git a/src/Run.hs b/src/Run.hs
index 67948d4..1a0b981 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -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