1 files changed, 42 insertions, 19 deletions

diff --git a/src/Process.hs b/src/Process.hs
index 48ed40f..31641c9 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -7,6 +7,7 @@ module Process (
     lineReadingLoop,
     spawnOn,
     closeProcess,
+    closeTestProcess,
     withProcess,
 ) where
 
@@ -18,11 +19,15 @@ import Control.Monad.Except
 import Control.Monad.Reader
 
 import Data.Function
+import Data.Scientific
 import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
 
+import System.Directory
+import System.Environment
 import System.Exit
+import System.FilePath
 import System.IO
 import System.IO.Error
 import System.Posix.Signals
@@ -33,11 +38,11 @@ import Network
 import Network.Ip
 import Output
 import Run.Monad
-import Test
+import Script.Expr.Class
 
 data Process = Process
     { procName :: ProcName
-    , procHandle :: ProcessHandle
+    , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode )
     , procStdin :: Handle
     , procOutput :: TVar [Text]
     , procKillWith :: Maybe Signal
@@ -89,27 +94,40 @@ 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 shell wrapper.
+    cmd' <- liftIO $ do
+        case span (/= ' ') cmd of
+            ( path, rest )
+                | any isPathSeparator path && isRelative path
+                -> do
+                    path' <- makeAbsolute path
+                    return (path' ++ rest)
+            _ -> return cmd
+
     let netns = either getNetns getNetns target
-    let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" "
-    (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd)
-        { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
-        , env = Just [("EREBOS_DIR", either netDir nodeDir target)]
-        }
+    currentEnv <- liftIO $ getEnvironment
+    (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
             { procName = pname
-            , procHandle = handle
+            , procHandle = Left handle
             , procStdin = hin
             , procOutput = pout
             , procKillWith = killWith
             , procNode = either (const undefined) id target
             }
 
-    forkTest $ lineReadingLoop process hout $ \line -> do
+    void $ forkTest $ lineReadingLoop process hout $ \line -> do
         outProc OutputChildStdout process line
         liftIO $ atomically $ modifyTVar pout (++[line])
-    forkTest $ lineReadingLoop process herr $ \line -> do
+    void $ forkTest $ lineReadingLoop process herr $ \line -> do
         case pname of
              ProcNameTcpdump -> return ()
              _ -> outProc OutputChildStderr process line
@@ -120,24 +138,29 @@ spawnOn target pname killWith cmd = do
 
     return process
 
-closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m ()
-closeProcess p = do
+closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Scientific -> Process -> m ()
+closeProcess timeout p = do
     liftIO $ hClose $ procStdin p
     case procKillWith p of
         Nothing -> return ()
-        Just sig -> liftIO $ getPid (procHandle p) >>= \case
+        Just sig -> liftIO $ either getPid (\_ -> return Nothing) (procHandle p) >>= \case
             Nothing -> return ()
             Just pid -> signalProcess sig pid
 
     liftIO $ void $ forkIO $ do
-        threadDelay 1000000
-        terminateProcess $ procHandle p
-    liftIO (waitForProcess (procHandle p)) >>= \case
+        threadDelay $ floor $ 1000000 * timeout
+        either terminateProcess (killThread . fst) $ procHandle p
+    liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) >>= \case
         ExitSuccess -> return ()
         ExitFailure code -> do
             outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code
             throwError Failed
 
+closeTestProcess :: Process -> TestRun ()
+closeTestProcess process = do
+    timeout <- liftIO . readMVar =<< asks (teTimeout . fst)
+    closeProcess timeout process
+
 withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a
 withProcess target pname killWith cmd inner = do
     procVar <- asks $ teProcesses . fst
@@ -147,5 +170,5 @@ withProcess target pname killWith cmd inner = do
 
     inner process `finally` do
         ps <- liftIO $ takeMVar procVar
-        closeProcess process `finally` do
+        closeTestProcess process `finally` do
             liftIO $ putMVar procVar $ filter (/=process) ps