From 5eb83b2a5485f5f735eb77f277819e42e39e8c56 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Fri, 16 Jan 2026 22:47:16 +0100
Subject: Use getProcessStatus for more detailed info when possible

---
 src/Process.hs | 30 ++++++++++++++++++++++++------
 1 file changed, 24 insertions(+), 6 deletions(-)

(limited to 'src/Process.hs')

diff --git a/src/Process.hs b/src/Process.hs
index 3cf0938..e04bfe7 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -36,6 +36,7 @@ import System.Exit
 import System.FilePath
 import System.IO
 import System.IO.Error
+import System.Posix.Process
 import System.Posix.Signals
 import System.Process
 
@@ -181,19 +182,36 @@ spawnOn target procName procKillWith cmd = do
 closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Scientific -> Process -> m ()
 closeProcess timeout p = do
     liftIO $ hClose $ procStdin p
+    mbPid <- liftIO $ either getPid (\_ -> return Nothing) (procHandle p)
     case procKillWith p of
         Nothing -> return ()
-        Just sig -> liftIO $ either getPid (\_ -> return Nothing) (procHandle p) >>= \case
+        Just sig -> case mbPid of
             Nothing -> return ()
-            Just pid -> signalProcess sig pid
+            Just pid -> liftIO $ signalProcess sig pid
 
     liftIO $ void $ forkIO $ do
         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
+
+    status <- case mbPid of
+        Nothing -> Just . Exited <$> liftIO (either waitForProcess (takeMVar . snd) (procHandle p))
+        Just pid -> liftIO (getProcessStatus True False pid)
+    case status of
+        Just (Exited ExitSuccess) -> do
+            return ()
+        Just (Exited (ExitFailure code)) -> do
+            outProc OutputChildFail p $ "exit code: " <> T.pack (show code)
+            throwError Failed
+        Just (Terminated sig _)
+            | Just sig == procKillWith p -> return ()
+            | otherwise -> do
+                outProc OutputChildFail p $ "killed with signal " <> T.pack (show sig)
+                throwError Failed
+        Just (Stopped sig) -> do
+            outProc OutputChildFail p $ "stopped with signal " <> T.pack (show sig)
+            throwError Failed
+        Nothing -> do
+            outProc OutputChildFail p $ "no exit status"
             throwError Failed
 
 closeTestProcess :: Process -> TestRun ()
-- 
cgit v1.2.3