Replace 'ip netns exec' with direct setns syscallHEADmaster

2 files changed, 19 insertions, 9 deletions

diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs
index a4fdf50..3750793 100644
--- a/src/Network/Ip.hs
+++ b/src/Network/Ip.hs
@@ -19,6 +19,7 @@ module Network.Ip (
     addNetworkNamespace,
     setNetworkNamespace,
     textNetnsName,
+    runInNetworkNamespace,
     callOn,
 
     Link(..),
@@ -33,6 +34,7 @@ module Network.Ip (
     addRoute,
 ) where
 
+import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
@@ -142,12 +144,20 @@ 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
diff --git a/src/Process.hs b/src/Process.hs
index 290aedf..61a9fe8 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -93,7 +93,7 @@ lineReadingLoop process h act =
 spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process
 spawnOn target pname killWith cmd = do
     -- When executing command given with relative path, turn it to absolute one,
-    -- because working directory will be changed for the "ip netns exec" wrapper.
+    -- because working directory will be changed for the shell wrapper.
     cmd' <- liftIO $ do
         case span (/= ' ') cmd of
             ( path, rest )
@@ -104,13 +104,13 @@ spawnOn target pname killWith cmd = do
             _ -> return cmd
 
     let netns = either getNetns getNetns target
-    let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" "
     currentEnv <- liftIO $ getEnvironment
-    (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd')
-        { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
-        , cwd = Just (either netDir nodeDir target)
-        , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv
-        }
+    (Just hin, Just hout, Just herr, handle) <- liftIO $ do
+        runInNetworkNamespace netns $ createProcess (shell cmd')
+            { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
+            , cwd = Just (either netDir nodeDir target)
+            , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv
+            }
     pout <- liftIO $ newTVarIO []
 
     let process = Process