Execute shell commands in appropriate network namespace

Changelog: Execute shell commands in appropriate network namespace

3 files changed, 29 insertions, 3 deletions

diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs
index 8f0887a..a4fdf50 100644
--- a/src/Network/Ip.hs
+++ b/src/Network/Ip.hs
@@ -17,6 +17,7 @@ module Network.Ip (
     NetworkNamespace,
     HasNetns(..),
     addNetworkNamespace,
+    setNetworkNamespace,
     textNetnsName,
     callOn,
 
@@ -33,6 +34,7 @@ module Network.Ip (
 ) where
 
 import Control.Concurrent.STM
+import Control.Exception
 import Control.Monad
 import Control.Monad.Writer
 
@@ -42,6 +44,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,6 +129,19 @@ 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)
+        open = openFd path ReadOnly defaultFileFlags { cloexec = True }
+    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
+
 textNetnsName :: NetworkNamespace -> Text
 textNetnsName = netnsName
 
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index e107017..abef32d 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -7,6 +7,7 @@ module Run.Monad (
 
     finally,
     forkTest,
+    forkTestUsing,
 ) where
 
 import Control.Concurrent
@@ -110,9 +111,12 @@ finally act handler = do
     return x
 
 forkTest :: TestRun () -> TestRun ThreadId
-forkTest act = do
+forkTest = forkTestUsing forkIO
+
+forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId
+forkTestUsing fork act = do
     tenv <- ask
-    liftIO $ forkIO $ do
+    liftIO $ fork $ do
         runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case
             Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e)
             Right () -> return ()
diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs
index b00dc5f..5c70f2a 100644
--- a/src/Script/Shell.hs
+++ b/src/Script/Shell.hs
@@ -20,6 +20,7 @@ import System.IO
 import System.Process hiding (ShellCommand)
 
 import Network
+import Network.Ip
 import Output
 import Process
 import Run.Monad
@@ -37,6 +38,7 @@ newtype ShellScript = ShellScript [ ShellStatement ]
 
 executeScript :: Node -> ProcName -> MVar ExitCode -> Handle -> Handle -> Handle -> ShellScript -> TestRun ()
 executeScript node pname statusVar pstdin pstdout pstderr (ShellScript statements) = do
+    setNetworkNamespace $ getNetns node
     forM_ statements $ \ShellStatement {..} -> case shellCommand of
         "echo" -> liftIO $ do
             T.hPutStrLn pstdout $ T.intercalate " " shellArguments
@@ -65,7 +67,7 @@ spawnShell procNode procName script = do
     ( pstdin, procStdin ) <- liftIO $ createPipe
     ( hout, pstdout ) <- liftIO $ createPipe
     ( herr, pstderr ) <- liftIO $ createPipe
-    procHandle <- fmap (Right . (, statusVar)) $ forkTest $ do
+    procHandle <- fmap (Right . (, statusVar)) $ forkTestUsing forkOS $ do
         executeScript procNode procName statusVar pstdin pstdout pstderr script
 
     let procKillWith = Nothing