Use current timeout value when waiting for process termination

3 files changed, 15 insertions, 8 deletions

diff --git a/src/Process.hs b/src/Process.hs
index 61a9fe8..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
@@ -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
diff --git a/src/Run.hs b/src/Run.hs
index 4d68fb6..d5b0d29 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -111,7 +111,7 @@ runTest out opts gdefs test = do
     void $ installHandler processStatusChanged oldHandler Nothing
 
     Right () <- runExceptT $ flip runReaderT out $ do
-        maybe (return ()) (closeProcess . snd) mgdb
+        maybe (return ()) (closeProcess 1 . snd) mgdb
     [] <- readMVar procVar
 
     failed <- atomically $ readTVar (teFailed tenv)
diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs
index 5c70f2a..9bbf06c 100644
--- a/src/Script/Shell.hs
+++ b/src/Script/Shell.hs
@@ -90,5 +90,5 @@ withShellProcess node pname script inner = do
 
     inner process `finally` do
         ps <- liftIO $ takeMVar procVar
-        closeProcess process `finally` do
+        closeTestProcess process `finally` do
             liftIO $ putMVar procVar $ filter (/=process) ps