Hello community, here is the log from the commit of package ghc-typed-process for openSUSE:Leap:15.2 checked in at 2020-02-19 18:41:57 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Leap:15.2/ghc-typed-process (Old) and /work/SRC/openSUSE:Leap:15.2/.ghc-typed-process.new.26092 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-typed-process" Wed Feb 19 18:41:57 2020 rev:13 rq:771509 version:0.2.6.0 Changes: -------- --- /work/SRC/openSUSE:Leap:15.2/ghc-typed-process/ghc-typed-process.changes 2020-01-15 15:02:42.925819187 +0100 +++ /work/SRC/openSUSE:Leap:15.2/.ghc-typed-process.new.26092/ghc-typed-process.changes 2020-02-19 18:41:58.362257384 +0100 @@ -1,0 +2,34 @@ +Fri Nov 8 16:15:05 UTC 2019 - Peter Simons <[email protected]> + +- Drop obsolete group attributes. + +------------------------------------------------------------------- +Thu Jul 4 02:03:36 UTC 2019 - [email protected] + +- Update typed-process to version 0.2.6.0. + ## Unreleased + + * The cleanup thread applies an `unmask` to the actions which wait for a + process to exit, allowing the action to be interruptible. + +------------------------------------------------------------------- +Thu Jun 27 02:02:48 UTC 2019 - [email protected] + +- Update typed-process to version 0.2.5.0. + # ChangeLog for typed-process + + ## 0.2.5.0 + + * Add a `nullStream` [#24](https://github.com/fpco/typed-process/pull/24) + * Add `withProcessWait`, `withProcessWait_`, `withProcessTerm`, and `withProcessTerm_` + [#25](https://github.com/fpco/typed-process/issues/25) + +------------------------------------------------------------------- +Sat Jun 8 02:02:43 UTC 2019 - [email protected] + +- Update typed-process to version 0.2.4.1. + ## 0.2.4.1 + + * Fix a `Handle` leak in `withProcessInterleave` and its derivatives. + +------------------------------------------------------------------- Old: ---- typed-process-0.2.4.0.tar.gz New: ---- typed-process-0.2.6.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-typed-process.spec ++++++ --- /var/tmp/diff_new_pack.tGo4P9/_old 2020-02-19 18:41:58.750258198 +0100 +++ /var/tmp/diff_new_pack.tGo4P9/_new 2020-02-19 18:41:58.750258198 +0100 @@ -19,11 +19,10 @@ %global pkg_name typed-process %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.2.4.0 +Version: 0.2.6.0 Release: 0 Summary: Run external processes, with strong typing of streams License: MIT -Group: Development/Libraries/Haskell URL: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel @@ -33,6 +32,7 @@ BuildRequires: ghc-rpm-macros BuildRequires: ghc-stm-devel BuildRequires: ghc-transformers-devel +BuildRequires: ghc-unliftio-core-devel %if %{with tests} BuildRequires: ghc-base64-bytestring-devel BuildRequires: ghc-hspec-devel @@ -44,7 +44,6 @@ %package devel Summary: Haskell %{pkg_name} library development files -Group: Development/Libraries/Haskell Requires: %{name} = %{version}-%{release} Requires: ghc-compiler = %{ghc_version} Requires(post): ghc-compiler = %{ghc_version} ++++++ typed-process-0.2.4.0.tar.gz -> typed-process-0.2.6.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/typed-process-0.2.4.0/ChangeLog.md new/typed-process-0.2.6.0/ChangeLog.md --- old/typed-process-0.2.4.0/ChangeLog.md 2019-01-16 13:42:37.000000000 +0100 +++ new/typed-process-0.2.6.0/ChangeLog.md 2019-07-02 16:13:24.000000000 +0200 @@ -1,3 +1,20 @@ +# ChangeLog for typed-process + +## Unreleased + +* The cleanup thread applies an `unmask` to the actions which wait for a + process to exit, allowing the action to be interruptible. + +## 0.2.5.0 + +* Add a `nullStream` [#24](https://github.com/fpco/typed-process/pull/24) +* Add `withProcessWait`, `withProcessWait_`, `withProcessTerm`, and `withProcessTerm_` + [#25](https://github.com/fpco/typed-process/issues/25) + +## 0.2.4.1 + +* Fix a `Handle` leak in `withProcessInterleave` and its derivatives. + ## 0.2.4.0 * Add `readProcessInterleaved` and `readProcessInterleaved_` to support diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/typed-process-0.2.4.0/README.md new/typed-process-0.2.6.0/README.md --- old/typed-process-0.2.4.0/README.md 2018-08-14 11:32:26.000000000 +0200 +++ new/typed-process-0.2.6.0/README.md 2019-02-28 12:48:21.000000000 +0100 @@ -29,7 +29,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.IO (hPutStr, hClose) import System.Process.Typed @@ -85,7 +85,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed @@ -113,7 +113,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed @@ -129,7 +129,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed @@ -157,7 +157,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed @@ -189,7 +189,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed @@ -220,7 +220,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed @@ -234,7 +234,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed @@ -247,7 +247,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed @@ -265,7 +265,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed import System.Exit (ExitCode) @@ -291,7 +291,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed import Data.ByteString.Lazy (ByteString) @@ -312,12 +312,12 @@ from a process to a file. This is superior to the memory approach as it does not have the risk of using large amounts of memory, though it is more inconvenient. Together with the -[`UnliftIO.Temporary`](https://www.stackage.org/haddock/lts-10.2/unliftio-0.2.2.0/UnliftIO-Temporary.html), we +[`UnliftIO.Temporary`](https://www.stackage.org/haddock/lts/unliftio/UnliftIO-Temporary.html), we can do some nice things: ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed import UnliftIO.Temporary (withSystemTempFile) @@ -341,7 +341,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed import System.IO (hClose) @@ -371,7 +371,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed @@ -383,7 +383,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed @@ -396,7 +396,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed import System.IO @@ -422,7 +422,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed import System.IO @@ -456,7 +456,7 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-10.2 script +-- stack --resolver lts-12.21 script {-# LANGUAGE OverloadedStrings #-} import System.Process.Typed diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/typed-process-0.2.4.0/src/System/Process/Typed/Internal.hs new/typed-process-0.2.6.0/src/System/Process/Typed/Internal.hs --- old/typed-process-0.2.4.0/src/System/Process/Typed/Internal.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/typed-process-0.2.6.0/src/System/Process/Typed/Internal.hs 2019-06-25 10:03:14.000000000 +0200 @@ -0,0 +1,12 @@ +{-# LANGUAGE CPP #-} +module System.Process.Typed.Internal ( + nullDevice +) where + +-- | The name of the system null device +nullDevice :: FilePath +#if WINDOWS +nullDevice = "\\\\.\\NUL" +#else +nullDevice = "/dev/null" +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/typed-process-0.2.4.0/src/System/Process/Typed.hs new/typed-process-0.2.6.0/src/System/Process/Typed.hs --- old/typed-process-0.2.4.0/src/System/Process/Typed.hs 2019-01-16 13:42:37.000000000 +0100 +++ new/typed-process-0.2.6.0/src/System/Process/Typed.hs 2019-07-03 06:58:46.000000000 +0200 @@ -3,8 +3,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Please see the README.md file for examples of using this API. module System.Process.Typed @@ -45,6 +45,7 @@ -- * Stream specs , mkStreamSpec , inherit + , nullStream , closed , byteStringInput , byteStringOutput @@ -55,6 +56,10 @@ -- * Launch a process , startProcess , stopProcess + , withProcessWait + , withProcessWait_ + , withProcessTerm + , withProcessTerm_ , withProcess , withProcess_ , readProcess @@ -92,21 +97,24 @@ import qualified Data.ByteString as S import Data.ByteString.Lazy.Internal (defaultChunkSize) -import Control.Exception (assert, evaluate, throwIO, Exception, SomeException, finally, bracket, onException, catch, try) +import qualified Control.Exception as E +import Control.Exception hiding (bracket, finally) 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 (Handle, hClose, IOMode(ReadWriteMode), withBinaryFile) import System.IO.Error (isPermissionError) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (async, cancel, waitCatch) +import Control.Concurrent.Async (async, asyncWithUnmask, cancel, waitCatch) import Control.Concurrent.STM (newEmptyTMVarIO, atomically, putTMVar, TMVar, readTMVar, tryReadTMVar, STM, tryPutTMVar, throwSTM, catchSTM) import System.Exit (ExitCode (ExitSuccess)) +import System.Process.Typed.Internal 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) +import Control.Monad.IO.Unlift #if MIN_VERSION_process(1, 4, 0) && !WINDOWS import System.Posix.Types (GroupID, UserID) @@ -206,7 +214,7 @@ -- -- @since 0.1.0.0 data StreamSpec (streamType :: StreamType) a = StreamSpec - { ssStream :: !P.StdStream + { ssStream :: !(forall b. (P.StdStream -> IO b) -> IO b) , ssCreate :: !(ProcessConfig () () () -> Maybe Handle -> Cleanup a) } deriving Functor @@ -491,7 +499,15 @@ mkStreamSpec :: P.StdStream -> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ())) -> StreamSpec streamType a -mkStreamSpec ss f = StreamSpec ss (\pc mh -> Cleanup (f pc mh)) +mkStreamSpec ss f = mkManagedStreamSpec ($ ss) f + +-- | Create a new 'StreamSpec' from a function that accepts a +-- 'P.StdStream' and a helper function. This function is the same as +-- the helper in 'mkStreamSpec' +mkManagedStreamSpec :: (forall b. (P.StdStream -> IO b) -> IO b) + -> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ())) + -> StreamSpec streamType a +mkManagedStreamSpec ss f = StreamSpec ss (\pc mh -> Cleanup (f pc mh)) -- | A stream spec which simply inherits the stream of the parent -- process. @@ -500,14 +516,32 @@ inherit :: StreamSpec anyStreamType () inherit = mkStreamSpec P.Inherit (\_ Nothing -> pure ((), return ())) +-- | A stream spec which is empty when used for for input and discards +-- output. Note this requires your platform's null device to be +-- available when the process is started. +-- +-- @since 0.2.5.0 +nullStream :: StreamSpec anyStreamType () +nullStream = mkManagedStreamSpec opener cleanup + where + opener f = + withBinaryFile nullDevice ReadWriteMode $ \handle -> + f (P.UseHandle handle) + cleanup _ _ = + pure ((), return ()) + -- | A stream spec which will close the stream for the child process. +-- You usually do not want to use this, as it will leave the +-- corresponding file descriptor unassigned and hence available for +-- re-use in the child process. Prefer 'nullStream' unless you're +-- certain you want this behavior. -- -- @since 0.1.0.0 closed :: StreamSpec anyStreamType () #if MIN_VERSION_process(1, 4, 0) closed = mkStreamSpec P.NoStream (\_ Nothing -> pure ((), return ())) #else -closed = mkStreamSpec P.CreatePipe (\_ (Just h) -> (((), return ()) <$ hClose h)) +closed = mkStreamSpec P.CreatePipe (\_ (Just h) -> ((), return ()) <$ hClose h) #endif -- | An input stream spec which sets the input to the given @@ -596,100 +630,104 @@ => ProcessConfig stdin stdout stderr -> m (Process stdin stdout stderr) startProcess pConfig'@ProcessConfig {..} = liftIO $ do - let cp0 = - case pcCmdSpec of - P.ShellCommand cmd -> P.shell cmd - P.RawCommand cmd args -> P.proc cmd args - cp = cp0 - { P.std_in = ssStream pcStdin - , P.std_out = ssStream pcStdout - , P.std_err = ssStream pcStderr - , P.cwd = pcWorkingDir - , P.env = pcEnv - , P.close_fds = pcCloseFds - , P.create_group = pcCreateGroup - , P.delegate_ctlc = pcDelegateCtlc + ssStream pcStdin $ \realStdin -> + ssStream pcStdout $ \realStdout -> + ssStream pcStderr $ \realStderr -> do + + let cp0 = + case pcCmdSpec of + P.ShellCommand cmd -> P.shell cmd + P.RawCommand cmd args -> P.proc cmd args + cp = cp0 + { P.std_in = realStdin + , P.std_out = realStdout + , P.std_err = realStderr + , P.cwd = pcWorkingDir + , P.env = pcEnv + , P.close_fds = pcCloseFds + , P.create_group = pcCreateGroup + , P.delegate_ctlc = pcDelegateCtlc #if MIN_VERSION_process(1, 3, 0) - , P.detach_console = pcDetachConsole - , P.create_new_console = pcCreateNewConsole - , P.new_session = pcNewSession + , P.detach_console = pcDetachConsole + , P.create_new_console = pcCreateNewConsole + , P.new_session = pcNewSession #endif #if MIN_VERSION_process(1, 4, 0) && !WINDOWS - , P.child_group = pcChildGroup - , P.child_user = pcChildUser + , P.child_group = pcChildGroup + , P.child_user = pcChildUser #endif - } + } - (minH, moutH, merrH, pHandle) <- P.createProcess_ "startProcess" cp + (minH, moutH, merrH, pHandle) <- P.createProcess_ "startProcess" cp - ((pStdin, pStdout, pStderr), pCleanup1) <- runCleanup $ (,,) - <$> ssCreate pcStdin pConfig minH - <*> ssCreate pcStdout pConfig moutH - <*> ssCreate pcStderr pConfig merrH - - pExitCode <- newEmptyTMVarIO - waitingThread <- async $ do - 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 - - 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 - -- Process already exited, nothing to do - Right _ec -> return () - - -- 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 - success <- atomically $ tryPutTMVar pExitCode ec - evaluate $ assert success () + ((pStdin, pStdout, pStderr), pCleanup1) <- runCleanup $ (,,) + <$> ssCreate pcStdin pConfig minH + <*> ssCreate pcStdout pConfig moutH + <*> ssCreate pcStderr pConfig merrH + + pExitCode <- newEmptyTMVarIO + waitingThread <- asyncWithUnmask $ \unmask -> do + ec <- unmask $ -- make sure the masking state from a bracket isn't inherited + 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 + + 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 + -- Process already exited, nothing to do + Right _ec -> return () + + -- 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 + success <- atomically $ tryPutTMVar pExitCode ec + evaluate $ assert success () - return Process {..} + return Process {..} where pConfig = clearStreams pConfig' @@ -718,27 +756,75 @@ -- | Uses the bracket pattern to call 'startProcess' and ensures that -- 'stopProcess' is called. -- --- In version 0.2.0.0, this function was monomorphized to @IO@ to --- avoid a dependency on the exceptions package. +-- This function is usually /not/ what you want. You're likely better +-- off using 'withProcessWait'. See +-- <https://github.com/fpco/typed-process/issues/25>. +-- +-- @since 0.2.5.0 +withProcessTerm :: (MonadUnliftIO m) + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a +withProcessTerm config = bracket (startProcess config) stopProcess + +-- | Uses the bracket pattern to call 'startProcess'. Unlike +-- 'withProcessTerm', this function will wait for the child process to +-- exit, and only kill it with 'stopProcess' in the event that the +-- inner function throws an exception. +-- +-- @since 0.2.5.0 +withProcessWait :: (MonadUnliftIO m) + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a +withProcessWait config f = + bracket + (startProcess config) + stopProcess + (\p -> f p <* waitExitCode p) + +-- | Deprecated synonym for 'withProcessTerm'. -- -- @since 0.1.0.0 -withProcess :: ProcessConfig stdin stdout stderr - -> (Process stdin stdout stderr -> IO a) - -> IO a -withProcess config = bracket (startProcess config) stopProcess +withProcess :: (MonadUnliftIO m) + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a +withProcess = withProcessTerm +{-# DEPRECATED withProcess "Please consider using withProcessWait, or instead use withProcessTerm" #-} + +-- | Same as 'withProcessTerm', but also calls 'checkExitCode' +-- +-- @since 0.2.5.0 +withProcessTerm_ :: (MonadUnliftIO m) + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a +withProcessTerm_ config = bracket + (startProcess config) + (\p -> stopProcess p `finally` checkExitCode p) --- | Same as 'withProcess', but also calls 'checkExitCode' +-- | Same as 'withProcessWait', but also calls 'checkExitCode' -- --- In version 0.2.0.0, this function was monomorphized to @IO@ to --- avoid a dependency on the exceptions package. +-- @since 0.2.5.0 +withProcessWait_ :: (MonadUnliftIO m) + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a +withProcessWait_ config f = bracket + (startProcess config) + stopProcess + (\p -> f p <* checkExitCode p) + +-- | Deprecated synonym for 'withProcessTerm_'. -- -- @since 0.1.0.0 -withProcess_ :: ProcessConfig stdin stdout stderr - -> (Process stdin stdout stderr -> IO a) - -> IO a -withProcess_ config = bracket - (startProcess config) - (\p -> stopProcess p `finally` checkExitCode p) +withProcess_ :: (MonadUnliftIO m) + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a +withProcess_ = withProcessTerm_ +{-# DEPRECATED withProcess_ "Please consider using withProcessWait_, or instead use withProcessTerm_" #-} -- | Run a process, capture its standard output and error as a -- 'L.ByteString', wait for it to complete, and then return its exit @@ -763,6 +849,8 @@ -- | Same as 'readProcess', but instead of returning the 'ExitCode', -- checks it with 'checkExitCode'. -- +-- Exceptions thrown by this function will include stdout and stderr. +-- -- @since 0.1.0.0 readProcess_ :: MonadIO m => ProcessConfig stdin stdoutIgnored stderrIgnored @@ -797,6 +885,8 @@ -- | Same as 'readProcessStdout', but instead of returning the -- 'ExitCode', checks it with 'checkExitCode'. -- +-- Exceptions thrown by this function will include stdout. +-- -- @since 0.2.1.0 readProcessStdout_ :: MonadIO m @@ -830,6 +920,8 @@ -- | Same as 'readProcessStderr', but instead of returning the -- 'ExitCode', checks it with 'checkExitCode'. -- +-- Exceptions thrown by this function will include stderr. +-- -- @since 0.2.1.0 readProcessStderr_ :: MonadIO m @@ -845,25 +937,24 @@ where pc' = setStderr byteStringOutput pc -withProcessInterleave - :: ProcessConfig stdin stdoutIgnored stderrIgnored - -> (Process stdin (STM L.ByteString) () -> IO a) - -> IO a -withProcessInterleave pc inner = do +withProcessInterleave :: (MonadUnliftIO m) + => ProcessConfig stdin stdoutIgnored stderrIgnored + -> (Process stdin (STM L.ByteString) () -> m a) + -> m a +withProcessInterleave pc inner = -- Create a pipe to be shared for both stdout and stderr - (readEnd, writeEnd) <- P.createPipe - - -- Use the writer end of the pipe for both stdout and stderr. For - -- the stdout half, use byteStringFromHandle to read the data into - -- a lazy ByteString in memory. - let pc' = setStdout (mkStreamSpec (P.UseHandle writeEnd) (\pc'' Nothing -> byteStringFromHandle pc'' readEnd)) - $ setStderr (useHandleOpen writeEnd) - pc - withProcess pc' $ \p -> do - -- Now that the process is forked, close the writer end of this - -- pipe, otherwise the reader end will never give an EOF. - hClose writeEnd - inner p + bracket P.createPipe (\(r, w) -> hClose r >> hClose w) $ \(readEnd, writeEnd) -> do + -- Use the writer end of the pipe for both stdout and stderr. For + -- the stdout half, use byteStringFromHandle to read the data into + -- a lazy ByteString in memory. + let pc' = setStdout (mkStreamSpec (P.UseHandle writeEnd) (\pc'' Nothing -> byteStringFromHandle pc'' readEnd)) + $ setStderr (useHandleOpen writeEnd) + pc + withProcess pc' $ \p -> do + -- Now that the process is forked, close the writer end of this + -- pipe, otherwise the reader end will never give an EOF. + liftIO $ hClose writeEnd + inner p -- | Same as 'readProcess', but interleaves stderr with stdout. -- @@ -885,13 +976,15 @@ -- | Same as 'readProcessInterleaved', but instead of returning the 'ExitCode', -- checks it with 'checkExitCode'. -- +-- Exceptions thrown by this function will include stdout. +-- -- @since 0.2.4.0 readProcessInterleaved_ :: MonadIO m => ProcessConfig stdin stdoutIgnored stderrIgnored -> m L.ByteString readProcessInterleaved_ pc = - liftIO $ do + liftIO $ withProcessInterleave pc $ \p -> atomically $ do stdout' <- getStdout p checkExitCodeSTM p `catchSTM` \ece -> throwSTM ece @@ -944,6 +1037,9 @@ -- | Wait for a process to exit, and ensure that it exited -- successfully. If not, throws an 'ExitCodeException'. -- +-- Exceptions thrown by this function will not include stdout or stderr (This prevents unbounded memory usage from reading them into memory). +-- However, some callers such as 'readProcess_' catch the exception, add the stdout and stderr, and rethrow. +-- -- @since 0.1.0.0 checkExitCode :: MonadIO m => Process stdin stdout stderr -> m () checkExitCode = liftIO . atomically . checkExitCodeSTM @@ -993,6 +1089,9 @@ -- exit code. Note that 'checkExitCode' is called by other functions -- as well, like 'runProcess_' or 'readProcess_'. -- +-- Note that several functions that throw an 'ExitCodeException' intentionally do not populate 'eceStdout' or 'eceStderr'. +-- This prevents unbounded memory usage for large stdout and stderrs. +-- -- @since 0.1.0.0 data ExitCodeException = ExitCodeException { eceExitCode :: ExitCode @@ -1047,3 +1146,9 @@ -- @since 0.1.1 unsafeProcessHandle :: Process stdin stdout stderr -> P.ProcessHandle unsafeProcessHandle = pHandle + +bracket :: MonadUnliftIO m => IO a -> (a -> IO b) -> (a -> m c) -> m c +bracket before after thing = withRunInIO $ \run -> E.bracket before after (run . thing) + +finally :: MonadUnliftIO m => m a -> IO () -> m a +finally thing after = withRunInIO $ \run -> E.finally (run thing) after diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/typed-process-0.2.4.0/test/System/Process/TypedSpec.hs new/typed-process-0.2.6.0/test/System/Process/TypedSpec.hs --- old/typed-process-0.2.4.0/test/System/Process/TypedSpec.hs 2019-01-16 13:42:37.000000000 +0100 +++ new/typed-process-0.2.6.0/test/System/Process/TypedSpec.hs 2019-07-03 06:58:46.000000000 +0200 @@ -3,6 +3,7 @@ module System.Process.TypedSpec (spec) where import System.Process.Typed +import System.Process.Typed.Internal import System.IO import Control.Concurrent.Async (Concurrently (..)) import Control.Concurrent.STM (atomically) @@ -21,12 +22,36 @@ spec :: Spec spec = do + -- This is mainly to make sure we use the right device filename on Windows + it "Null device is accessible" $ do + withBinaryFile nullDevice WriteMode $ \fp -> do + hPutStrLn fp "Hello world" + withBinaryFile nullDevice ReadMode $ \fp -> do + atEnd <- hIsEOF fp + atEnd `shouldBe` True + it "bytestring stdin" $ do let bs :: IsString s => s bs = "this is a test" res <- readProcess (setStdin bs "cat") res `shouldBe` (ExitSuccess, bs, "") + it "null stdin" $ do + res <- readProcess (setStdin nullStream "cat") + res `shouldBe` (ExitSuccess, "", "") + + it "null stdout" $ do + -- In particular, writing to that doesn't terminate the process with an error + bs <- readProcessStderr_ $ setStdout nullStream $ setStdin nullStream $ + proc "sh" ["-c", "echo hello; echo world >&2"] + bs `shouldBe` "world\n" + + it "null stderr" $ do + -- In particular, writing to that doesn't terminate the process with an error + bs <- readProcessStdout_ $ setStderr nullStream $ setStdin nullStream $ + proc "sh" ["-c", "echo hello >&2; echo world"] + bs `shouldBe` "world\n" + it "useHandleOpen" $ withSystemTempFile "use-handle-open" $ \fp h -> do let bs :: IsString s => s bs = "this is a test 2" @@ -74,7 +99,7 @@ runProcess_ "false" `shouldThrow` \ExitCodeException{} -> True it "async" $ withSystemTempFile "httpbin" $ \fp h -> do - lbs <- withProcess (setStdin createPipe $ setStdout byteStringOutput "base64") $ \p -> + lbs <- withProcessWait (setStdin createPipe $ setStdout byteStringOutput "base64") $ \p -> runConcurrently $ Concurrently (do bs <- S.readFile "README.md" @@ -87,6 +112,31 @@ raw <- S.readFile fp encoded `shouldBe` B64.encode raw + describe "withProcessWait" $ + it "succeeds with sleep" $ do + p <- withProcessWait (proc "sleep" ["1"]) pure + checkExitCode p :: IO () + + describe "withProcessWait_" $ + it "succeeds with sleep" + ((withProcessWait_ (proc "sleep" ["1"]) $ const $ pure ()) :: IO ()) + + -- These tests fail on older GHCs/process package versions + -- because, apparently, waitForProcess isn't interruptible. See + -- https://github.com/fpco/typed-process/pull/26#issuecomment-505702573. + + {- + describe "withProcessTerm" $ do + it "fails with sleep" $ do + p <- withProcessTerm (proc "sleep" ["1"]) pure + checkExitCode p `shouldThrow` anyException + + describe "withProcessTerm_" $ do + it "fails with sleep" $ + withProcessTerm_ (proc "sleep" ["1"]) (const $ pure ()) + `shouldThrow` anyException + -} + it "interleaved output" $ withSystemTempFile "interleaved-output" $ \fp h -> do S.hPut h "\necho 'stdout'\n>&2 echo 'stderr'\necho 'stdout'" hClose h diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/typed-process-0.2.4.0/typed-process.cabal new/typed-process-0.2.6.0/typed-process.cabal --- old/typed-process-0.2.4.0/typed-process.cabal 2019-01-16 13:42:41.000000000 +0100 +++ new/typed-process-0.2.6.0/typed-process.cabal 2019-07-02 07:42:38.000000000 +0200 @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 11c70077cb1b56f53730fd5ab768dd6b89dd6c3850649afb4cae269796982aff +-- hash: f8fdbd0397d67fa0c8d6c96e3e95d3d6eb56d94fc13f0350fc60ff855d44d671 name: typed-process -version: 0.2.4.0 +version: 0.2.6.0 synopsis: Run external processes, with strong typing of streams description: Please see the tutorial at <https://haskell-lang.org/library/typed-process> category: System @@ -29,6 +29,7 @@ library exposed-modules: System.Process.Typed + System.Process.Typed.Internal other-modules: Paths_typed_process hs-source-dirs: @@ -40,6 +41,7 @@ , process >=1.2 , stm , transformers + , unliftio-core if os(windows) cpp-options: -DWINDOWS default-language: Haskell2010 @@ -64,6 +66,7 @@ , temporary , transformers , typed-process + , unliftio-core default-language: Haskell2010 test-suite typed-process-test-single-threaded @@ -85,4 +88,5 @@ , temporary , transformers , typed-process + , unliftio-core default-language: Haskell2010
