summaryrefslogtreecommitdiff
path: root/src/Network/Ip.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-04-25 22:07:43 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2023-04-25 22:07:43 +0200
commitdab23fd7890ea2c27096015bb49ec526fafa14c7 (patch)
tree1473bcbadf3237879c0d132b5cd57871db0815a9 /src/Network/Ip.hs
parent7ed6a184f15975d694657124c01d00ef6b394531 (diff)
Link type and associated functions
Diffstat (limited to 'src/Network/Ip.hs')
-rw-r--r--src/Network/Ip.hs74
1 files changed, 70 insertions, 4 deletions
diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs
index 1365f66..13fc284 100644
--- a/src/Network/Ip.hs
+++ b/src/Network/Ip.hs
@@ -10,14 +10,22 @@ module Network.Ip (
ipSubnet,
lanSubnet,
+ MonadPIO(..),
+
NetworkNamespace,
HasNetns(..),
addNetworkNamespace,
textNetnsName,
callOn,
-) where
-import Control.Concurrent.STM
+ Link(..),
+ Loopback, loopback,
+ VEth, addVEth,
+ Bridge, addBridge,
+ addAddress,
+ setMaster,
+ linkUp, linkDown,
+) where
import Control.Monad.Writer
@@ -56,16 +64,27 @@ lanSubnet :: IpPrefix -> IpPrefix
lanSubnet (IpPrefix prefix) = IpPrefix (take 3 $ prefix ++ repeat 0)
+class Monad m => MonadPIO m where
+ postpone :: IO () -> m ()
+
+instance MonadPIO IO where
+ postpone = id
+
+instance Monad m => MonadPIO (WriterT [IO ()] m) where
+ postpone = tell . (:[])
+
+
newtype NetworkNamespace = NetworkNamespace
{ netnsName :: Text
}
deriving (Eq, Ord)
class HasNetns a where getNetns :: a -> NetworkNamespace
+instance HasNetns NetworkNamespace where getNetns = id
-addNetworkNamespace :: Text -> WriterT [IO ()] STM NetworkNamespace
+addNetworkNamespace :: MonadPIO m => Text -> m NetworkNamespace
addNetworkNamespace name = do
- tell $ (:[]) $ callCommand $ T.unpack $ "ip netns add \"" <> name <> "\""
+ postpone $ callCommand $ T.unpack $ "ip netns add \"" <> name <> "\""
return $ NetworkNamespace
{ netnsName = name
}
@@ -76,3 +95,50 @@ textNetnsName = netnsName
callOn :: HasNetns a => a -> Text -> IO ()
callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> ns <> "\" " <> cmd
where NetworkNamespace ns = getNetns n
+
+
+data Link a = Link
+ { linkName :: Text
+ , linkNetns :: NetworkNamespace
+ }
+
+instance HasNetns (Link a) where getNetns = linkNetns
+
+data Loopback
+
+loopback :: HasNetns n => n -> Link Loopback
+loopback = Link "lo" . getNetns
+
+data VEth
+
+addVEth :: (HasNetns n, HasNetns n', MonadPIO m) => (n, Text) -> (n', Text) -> m (Link VEth, Link VEth)
+addVEth (netns, name) (netns', name') = do
+ postpone $ callOn netns $ "ip link add \"" <> name <> "\" type veth peer name \"" <> name' <> "\" netns \"" <> textNetnsName (getNetns netns') <> "\""
+ return $ (,)
+ (Link name $ getNetns netns )
+ (Link name' $ getNetns netns')
+
+data Bridge
+
+addBridge :: (HasNetns n, MonadPIO m) => n -> Text -> m (Link Bridge)
+addBridge netns name = do
+ postpone $ callOn netns $ "ip link add name \"" <> name <> "\" type bridge"
+ return $ Link name $ getNetns netns
+
+addAddress :: MonadPIO m => Link a -> IpAddress -> m ()
+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
+ 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 <> "\""
+
+linkUp :: MonadPIO m => Link a -> m ()
+linkUp link = do
+ postpone $ callOn link $ "ip link set dev \"" <> linkName link <> "\" up"
+
+linkDown :: MonadPIO m => Link a -> m ()
+linkDown link = do
+ postpone $ callOn link $ "ip link set dev \"" <> linkName link <> "\" down"