Don't deadlock on delegate_ctlc (fixes fpco#73)

Author: sol

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