diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.2.3.0 + +* Add support for the single-threaded runtime via polling + ## 0.2.2.0 * Add inherit versions of setter functions diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,6 +19,12 @@ 5. Providing a more composable API, designed to be easy to use for both simple and complex use cases +__NOTE__ It's highly recommended that you compile any program using this +library with the multi-threaded runtime, usually by adding `ghc-options: +-threaded` to your executable stanza in your cabal or `package.yaml` file. The +single-threaded runtime necessitates some inefficient polling to be used under +the surface. + ## Synopsis ```haskell diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs --- a/src/System/Process/Typed.hs +++ b/src/System/Process/Typed.hs @@ -6,15 +6,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} -{-| -Please see the README.md file for examples of using this API. - -__Applications using this library MUST use @-threaded@__ to link with the -threaded version of the RTS. 'spawnProcess' and the others spawn a Haskell -thread that blocks until the process exits. Without @-threaded@ this will block -/all/ the Haskell threads in your program until the spawned process exits. - --} +-- | Please see the README.md file for examples of using this API. module System.Process.Typed ( -- * Types ProcessConfig @@ -98,18 +90,21 @@ import qualified Data.ByteString as S import Data.ByteString.Lazy.Internal (defaultChunkSize) -import Control.Exception (assert, evaluate, throwIO, Exception, SomeException, finally, bracket, onException, catch) +import Control.Exception (assert, evaluate, throwIO, Exception, SomeException, finally, bracket, onException, catch, try) import Control.Monad (void) import Control.Monad.IO.Class import qualified System.Process as P import Data.Typeable (Typeable) import System.IO (Handle, hClose) +import System.IO.Error (isPermissionError) +import Control.Concurrent (threadDelay) import Control.Concurrent.Async (async, cancel, waitCatch) import Control.Concurrent.STM (newEmptyTMVarIO, atomically, putTMVar, TMVar, readTMVar, tryReadTMVar, STM, tryPutTMVar, throwSTM, catchSTM) import System.Exit (ExitCode (ExitSuccess)) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import Data.String (IsString (fromString)) +import GHC.RTS.Flags (getConcFlags, ctxtSwitchTime) #if MIN_VERSION_process(1, 4, 0) && !WINDOWS import System.Posix.Types (GroupID, UserID) @@ -624,7 +619,21 @@ pExitCode <- newEmptyTMVarIO waitingThread <- async $ do - ec <- P.waitForProcess pHandle + ec <- + if multiThreadedRuntime + then P.waitForProcess pHandle + else do + switchTime <- (fromIntegral . (`div` 1000) . ctxtSwitchTime) + <$> getConcFlags + let minDelay = 1 + maxDelay = max minDelay switchTime + loop delay = do + threadDelay delay + mec <- P.getProcessExitCode pHandle + case mec of + Nothing -> loop $ min maxDelay (delay * 2) + Just ec -> pure ec + loop minDelay atomically $ putTMVar pExitCode ec return ec @@ -645,14 +654,41 @@ -- Process didn't exit yet, let's terminate it and -- then call waitForProcess ourselves Left _ -> do - P.terminateProcess pHandle - ec <- P.waitForProcess pHandle + 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 success <- atomically $ tryPutTMVar pExitCode ec evaluate $ assert success () return Process {..} where pConfig = clearStreams pConfig' + +foreign import ccall unsafe "rtsSupportsBoundThreads" + multiThreadedRuntime :: Bool + +isWindows :: Bool +#if WINDOWS +isWindows = True +#else +isWindows = False +#endif -- | Close a process and release any resources acquired. This will -- ensure 'P.terminateProcess' is called, wait for the process to diff --git a/typed-process.cabal b/typed-process.cabal --- a/typed-process.cabal +++ b/typed-process.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.21.2. +cabal-version: >= 1.10 + +-- This file has been generated from package.yaml by hpack version 0.29.0. -- -- see: https://github.com/sol/hpack -- --- hash: 11068332a1f3de188a488a22fdb0b1bc49f70ccc1dd04c322123278d6d6124e3 +-- hash: 8fd30ba42322fffadc01326bcc1370fa86c650057800ca91d5381d89e91df797 name: typed-process -version: 0.2.2.0 +version: 0.2.3.0 synopsis: Run external processes, with strong typing of streams description: Please see the tutorial at category: System @@ -16,8 +18,6 @@ license: MIT license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 - extra-source-files: ChangeLog.md README.md @@ -35,7 +35,7 @@ src build-depends: async - , base >=4.7 && <5 + , base >=4.8 && <5 , bytestring , process >=1.2 , stm @@ -55,7 +55,28 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: async - , base >=4.7 && <5 + , base >=4.8 && <5 + , base64-bytestring + , bytestring + , hspec + , process >=1.2 + , stm + , temporary + , transformers + , typed-process + default-language: Haskell2010 + +test-suite typed-process-test-single-threaded + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + System.Process.TypedSpec + Paths_typed_process + hs-source-dirs: + test + build-depends: + async + , base >=4.8 && <5 , base64-bytestring , bytestring , hspec