diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs index 731c0f9..57dd9ee 100644 --- a/src/System/Process/Typed.hs +++ b/src/System/Process/Typed.hs @@ -130,6 +130,7 @@ 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) @@ -256,25 +257,8 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do -- Process didn't exit yet, let's terminate it and -- then call waitForProcess ourselves Left _ -> do - eres <- try $ P.terminateProcess pHandle - ec <- - case eres of - Left e - -- On Windows, with the single-threaded runtime, it - -- seems that if a process has already exited, the - -- call to terminateProcess will fail with a - -- permission denied error. To work around this, we - -- catch this exception and then immediately - -- waitForProcess. There's a chance that there may be - -- other reasons for this permission error to appear, - -- in which case this code may allow us to wait too - -- long for a child process instead of erroring out. - -- Recommendation: always use the multi-threaded - -- runtime! - | isPermissionError e && not multiThreadedRuntime && isWindows -> - P.waitForProcess pHandle - | otherwise -> throwIO e - Right () -> P.waitForProcess pHandle + terminateProcess pHandle + ec <- P.waitForProcess pHandle success <- atomically $ tryPutTMVar pExitCode ec evaluate $ assert success () @@ -282,6 +266,23 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do where pConfig = clearStreams pConfig' + terminateProcess :: P.ProcessHandle -> IO () + terminateProcess p = do + -- On Windows, with the single-threaded runtime, it seems that if a + -- process has already exited, the call to terminateProcess will fail + -- with a permission denied error. To work around this, we ignore this + -- exception. There's a chance that there may be other reasons for this + -- permission error to appear, in which case this code may allow us to + -- wait too long for a child process (on a subsequent call to + -- `waitForProcess`) instead of erroring out here. + -- Recommendation: always use the multi-threaded runtime! + ignorePermissionErrorOnSingleThreadedWindows $ P.terminateProcess p + + ignorePermissionErrorOnSingleThreadedWindows :: IO () -> IO () + ignorePermissionErrorOnSingleThreadedWindows = tryJust (guard . p) >=> either return return + where + p e = isPermissionError e && not multiThreadedRuntime && isWindows + foreign import ccall unsafe "rtsSupportsBoundThreads" multiThreadedRuntime :: Bool