diff options
Diffstat (limited to 'src/Process.hs')
| -rw-r--r-- | src/Process.hs | 33 |
1 files changed, 20 insertions, 13 deletions
diff --git a/src/Process.hs b/src/Process.hs index 290aedf..31641c9 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -7,6 +7,7 @@ module Process ( lineReadingLoop, spawnOn, closeProcess, + closeTestProcess, withProcess, ) where @@ -18,9 +19,10 @@ 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 @@ -93,7 +95,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 +106,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 @@ -136,8 +138,8 @@ 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 () @@ -146,7 +148,7 @@ closeProcess p = do Just pid -> signalProcess sig pid liftIO $ void $ forkIO $ do - threadDelay 1000000 + threadDelay $ floor $ 1000000 * timeout either terminateProcess (killThread . fst) $ procHandle p liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) >>= \case ExitSuccess -> return () @@ -154,6 +156,11 @@ closeProcess p = 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 @@ -163,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 |