From 1cb63a938a45bd2c1338dfcf30d342b8f573e335 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Mon, 22 May 2023 19:18:52 +0100 Subject: [PATCH 1/4] Add redundant waitForProcess to make duplication more obvious It can never run because of the throwIO before it --- src/System/Process/Typed.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs index 731c0f9..9c69eaf 100644 --- a/src/System/Process/Typed.hs +++ b/src/System/Process/Typed.hs @@ -273,7 +273,7 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do -- runtime! | isPermissionError e && not multiThreadedRuntime && isWindows -> P.waitForProcess pHandle - | otherwise -> throwIO e + | otherwise -> throwIO e >> P.waitForProcess pHandle Right () -> P.waitForProcess pHandle success <- atomically $ tryPutTMVar pExitCode ec evaluate $ assert success () From ff029bcc17d7e0a067722d5600b92371b45e6568 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Mon, 22 May 2023 19:19:37 +0100 Subject: [PATCH 2/4] Remove duplication between branches --- src/System/Process/Typed.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs index 9c69eaf..b2a0374 100644 --- a/src/System/Process/Typed.hs +++ b/src/System/Process/Typed.hs @@ -257,8 +257,7 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do -- then call waitForProcess ourselves Left _ -> do eres <- try $ P.terminateProcess pHandle - ec <- - case eres of + case eres of Left e -- On Windows, with the single-threaded runtime, it -- seems that if a process has already exited, the @@ -272,9 +271,10 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do -- Recommendation: always use the multi-threaded -- runtime! | isPermissionError e && not multiThreadedRuntime && isWindows -> - P.waitForProcess pHandle - | otherwise -> throwIO e >> P.waitForProcess pHandle - Right () -> P.waitForProcess pHandle + pure () + | otherwise -> throwIO e + Right () -> pure () + ec <- P.waitForProcess pHandle success <- atomically $ tryPutTMVar pExitCode ec evaluate $ assert success () From 8a0026ae15472dd778eb3ad9941270775abadd88 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Mon, 22 May 2023 19:32:12 +0100 Subject: [PATCH 3/4] Pull out terminateProcess wrapper function --- src/System/Process/Typed.hs | 39 ++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs index b2a0374..c94701a 100644 --- a/src/System/Process/Typed.hs +++ b/src/System/Process/Typed.hs @@ -256,24 +256,7 @@ 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 - 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 -> - pure () - | otherwise -> throwIO e - Right () -> pure () + terminateProcess pHandle ec <- P.waitForProcess pHandle success <- atomically $ tryPutTMVar pExitCode ec evaluate $ assert success () @@ -282,6 +265,26 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do where pConfig = clearStreams pConfig' + terminateProcess pHandle = do + eres <- try $ P.terminateProcess pHandle + 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 -> + pure () + | otherwise -> throwIO e + Right () -> pure () + foreign import ccall unsafe "rtsSupportsBoundThreads" multiThreadedRuntime :: Bool From cb67af7446706a78d062b46ed9fd1c07947d071f Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Mon, 22 May 2023 20:48:48 +0700 Subject: [PATCH 4/4] refactoring: Use `tryJust` instead of pattern guards --- src/System/Process/Typed.hs | 36 +++++++++++++++++------------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs index c94701a..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) @@ -265,25 +266,22 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do where pConfig = clearStreams pConfig' - terminateProcess pHandle = do - eres <- try $ P.terminateProcess pHandle - 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 -> - pure () - | otherwise -> throwIO e - Right () -> pure () + 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