diff --git a/ChangeLog.md b/ChangeLog.md index f44b4a4..3eb42fc 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # ChangeLog for typed-process +## 0.2.12.0 + +* Ensure that `waitForProcess` is never called more than once + [#70](https://github.com/fpco/typed-process/pull/70) + +* Don't deadlock on `delegate_ctlc` + [#73](https://github.com/fpco/typed-process/pull/73) + ## 0.2.11.0 * Expose more from `System.Process.Typed.Internal` diff --git a/package.yaml b/package.yaml index 5b6a7e5..0339e8a 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: typed-process -version: 0.2.11.0 +version: 0.2.12.0 synopsis: Run external processes, with strong typing of streams description: Please see the tutorial at category: System diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs index c94701a..2a37e53 100644 --- a/src/System/Process/Typed.hs +++ b/src/System/Process/Typed.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} @@ -130,13 +131,15 @@ module System.Process.Typed ) where import Control.Exception hiding (bracket, finally) +import Control.Monad ((>=>), guard) import Control.Monad.IO.Class import qualified System.Process as P import System.IO (hClose) import System.IO.Error (isPermissionError) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (asyncWithUnmask, cancel, waitCatch) -import Control.Concurrent.STM (newEmptyTMVarIO, atomically, putTMVar, TMVar, readTMVar, tryReadTMVar, STM, tryPutTMVar, throwSTM, catchSTM) +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)) import System.Process.Typed.Internal import qualified Data.ByteString.Lazy as L @@ -165,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) @@ -219,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 @@ -236,30 +238,20 @@ 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 pExitCode :: IO ExitCode let pCleanup = pCleanup1 `finally` do - -- First: stop calling waitForProcess, so that we can - -- avoid race conditions where the process is removed from - -- the system process table while we're trying to - -- terminate it. - cancel waitingThread - - -- Now check if the process had already exited - eec <- waitCatch waitingThread - - case eec of + _ :: ExitCode <- Async.poll pExitCode >>= \ case -- Process already exited, nothing to do - Right _ec -> return () + Just r -> either throwIO return r -- Process didn't exit yet, let's terminate it and -- then call waitForProcess ourselves - Left _ -> do + Nothing -> do terminateProcess pHandle - ec <- P.waitForProcess pHandle - success <- atomically $ tryPutTMVar pExitCode ec - evaluate $ assert success () + waitForProcess + return () return Process {..} where @@ -602,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'. -- @@ -614,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'. @@ -631,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 diff --git a/test/System/Process/TypedSpec.hs b/test/System/Process/TypedSpec.hs index 45003f9..fec29be 100644 --- a/test/System/Process/TypedSpec.hs +++ b/test/System/Process/TypedSpec.hs @@ -5,6 +5,7 @@ module System.Process.TypedSpec (spec) where import System.Process.Typed import System.Process.Typed.Internal import System.IO +import Control.Exception import Control.Concurrent.Async (Concurrently (..)) import Control.Concurrent.STM (atomically) import Test.Hspec @@ -170,3 +171,12 @@ spec = do it "empty param are showed" $ let expected = "Raw command: podman exec --detach-keys \"\" ctx bash\n" in show (proc "podman" ["exec", "--detach-keys", "", "ctx", "bash"]) `shouldBe` expected + + describe "stopProcess" $ do + it "never calls waitForProcess more than once (fix for #69)" $ do + -- https://github.com/fpco/typed-process/issues/70 + let config = setStdout createPipe (proc "echo" ["foo"]) + withProcessWait config $ \p -> do + _ <- S.hGetContents (getStdout p) + throwIO DivideByZero + `shouldThrow` (== DivideByZero)