From 4c1437057cc6a0d3a3e8408ca1236b98d4081d20 Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Thu, 11 May 2023 18:22:05 +0700
Subject: [PATCH] Don't deadlock on `delegate_ctlc` (fixes #73)
---
src/System/Process/Typed.hs | 20 ++++++++++----------
1 file changed, 10 insertions(+), 10 deletions(-)
diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs
index e4212f6..2a37e53 100644
--- a/src/System/Process/Typed.hs
+++ b/src/System/Process/Typed.hs
@@ -137,7 +137,7 @@ import qualified System.Process as P
import System.IO (hClose)
import System.IO.Error (isPermissionError)
import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async (asyncWithUnmask)
+import Control.Concurrent.Async (Async, asyncWithUnmask)
import qualified Control.Concurrent.Async as Async
import Control.Concurrent.STM (newEmptyTMVarIO, atomically, putTMVar, TMVar, readTMVar, tryReadTMVar, STM, throwSTM, catchSTM)
import System.Exit (ExitCode (ExitSuccess, ExitFailure))
@@ -168,7 +168,7 @@ data Process stdin stdout stderr = Process
, pStdout :: !stdout
, pStderr :: !stderr
, pHandle :: !P.ProcessHandle
- , pExitCode :: !(TMVar ExitCode)
+ , pExitCode :: !(Async ExitCode)
}
instance Show (Process stdin stdout stderr) where
show p = "Running process: " ++ show (pConfig p)
@@ -222,8 +222,7 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do
<*> ssCreate pcStdout pConfig moutH
<*> ssCreate pcStderr pConfig merrH
- pExitCode <- newEmptyTMVarIO
- waitingThread <- asyncWithUnmask $ \unmask -> do
+ pExitCode <- asyncWithUnmask $ \unmask -> do
ec <- unmask $ -- make sure the masking state from a bracket isn't inherited
if multiThreadedRuntime
then P.waitForProcess pHandle
@@ -239,12 +238,11 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do
Nothing -> loop $ min maxDelay (delay * 2)
Just ec -> pure ec
loop minDelay
- atomically $ putTMVar pExitCode ec
return ec
- let waitForProcess = Async.wait waitingThread :: IO ExitCode
+ let waitForProcess = Async.wait pExitCode :: IO ExitCode
let pCleanup = pCleanup1 `finally` do
- _ :: ExitCode <- Async.poll waitingThread >>= \ case
+ _ :: ExitCode <- Async.poll pExitCode >>= \ case
-- Process already exited, nothing to do
Just r -> either throwIO return r
@@ -596,7 +594,7 @@ waitExitCode = liftIO . atomically . waitExitCodeSTM
--
-- @since 0.1.0.0
waitExitCodeSTM :: Process stdin stdout stderr -> STM ExitCode
-waitExitCodeSTM = readTMVar . pExitCode
+waitExitCodeSTM = Async.waitSTM . pExitCode
-- | Check if a process has exited and, if so, return its 'ExitCode'.
--
@@ -608,7 +606,9 @@ getExitCode = liftIO . atomically . getExitCodeSTM
--
-- @since 0.1.0.0
getExitCodeSTM :: Process stdin stdout stderr -> STM (Maybe ExitCode)
-getExitCodeSTM = tryReadTMVar . pExitCode
+getExitCodeSTM p = Async.pollSTM (pExitCode p) >>= \ case
+ Nothing -> return Nothing
+ Just er -> either throwSTM (return . Just) er
-- | Wait for a process to exit, and ensure that it exited
-- successfully. If not, throws an 'ExitCodeException'.
@@ -625,7 +625,7 @@ checkExitCode = liftIO . atomically . checkExitCodeSTM
-- @since 0.1.0.0
checkExitCodeSTM :: Process stdin stdout stderr -> STM ()
checkExitCodeSTM p = do
- ec <- readTMVar (pExitCode p)
+ ec <- Async.waitSTM (pExitCode p)
case ec of
ExitSuccess -> return ()
_ -> throwSTM ExitCodeException