1 files changed, 38 insertions, 2 deletions
diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs
index 8f0887a..69a6b43 100644
--- a/src/Network/Ip.hs
+++ b/src/Network/Ip.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 module Network.Ip (
     IpPrefix(..),
     textIpNetwork,
@@ -17,7 +19,9 @@ module Network.Ip (
     NetworkNamespace,
     HasNetns(..),
     addNetworkNamespace,
+    setNetworkNamespace,
     textNetnsName,
+    runInNetworkNamespace,
     callOn,
 
     Link(..),
@@ -32,7 +36,9 @@ module Network.Ip (
     addRoute,
 ) where
 
+import Control.Concurrent
 import Control.Concurrent.STM
+import Control.Exception
 import Control.Monad
 import Control.Monad.Writer
 
@@ -42,6 +48,11 @@ import Data.Text qualified as T
 import Data.Typeable
 import Data.Word
 
+import Foreign.C.Error
+import Foreign.C.Types
+
+import System.Posix.IO
+import System.Posix.Types
 import System.Process
 
 newtype IpPrefix = IpPrefix [Word8]
@@ -122,12 +133,37 @@ addNetworkNamespace netnsName = do
     netnsRoutesActive <- liftSTM $ newTVar []
     return $ NetworkNamespace {..}
 
+setNetworkNamespace :: MonadIO m => NetworkNamespace -> m ()
+setNetworkNamespace netns = liftIO $ do
+    let path = "/var/run/netns/" <> T.unpack (textNetnsName netns)
+#if MIN_VERSION_unix(2,8,0)
+        open = openFd path ReadOnly defaultFileFlags { cloexec = True }
+#else
+        open = openFd path ReadOnly Nothing defaultFileFlags
+#endif
+    res <- bracket open closeFd $ \(Fd fd) -> do
+        c_setns fd c_CLONE_NEWNET
+    when (res /= 0) $ do
+        throwErrno "setns failed"
+
+foreign import ccall unsafe "sched.h setns" c_setns :: CInt -> CInt -> IO CInt
+c_CLONE_NEWNET :: CInt
+c_CLONE_NEWNET = 0x40000000
+
+runInNetworkNamespace :: NetworkNamespace -> IO a -> IO a
+runInNetworkNamespace netns act = do
+    mvar <- newEmptyMVar
+    void $ forkOS $ do
+        setNetworkNamespace netns
+        putMVar mvar =<< act
+    takeMVar mvar
+
+
 textNetnsName :: NetworkNamespace -> Text
 textNetnsName = netnsName
 
 callOn :: HasNetns a => a -> Text -> IO ()
-callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> ns <> "\" " <> cmd
-    where ns = textNetnsName $ getNetns n
+callOn n cmd = runInNetworkNamespace (getNetns n) $ callCommand $ T.unpack cmd
 
 
 data Link a = Link