diff -Nru haskell-typed-process-0.2.3.0/ChangeLog.md haskell-typed-process-0.2.5.0/ChangeLog.md --- haskell-typed-process-0.2.3.0/ChangeLog.md 2018-08-14 09:32:26.000000000 +0000 +++ haskell-typed-process-0.2.5.0/ChangeLog.md 2019-06-26 04:52:47.000000000 +0000 @@ -1,3 +1,20 @@ +# 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) + +## 0.2.4.1 + +* Fix a `Handle` leak in `withProcessInterleave` and its derivatives. + +## 0.2.4.0 + +* Add `readProcessInterleaved` and `readProcessInterleaved_` to support + capturing output from stdout and stderr in a single ByteString value. + ## 0.2.3.0 * Add support for the single-threaded runtime via polling diff -Nru haskell-typed-process-0.2.3.0/debian/changelog haskell-typed-process-0.2.5.0/debian/changelog --- haskell-typed-process-0.2.3.0/debian/changelog 2018-10-01 14:50:20.000000000 +0000 +++ haskell-typed-process-0.2.5.0/debian/changelog 2019-08-08 11:46:22.000000000 +0000 @@ -1,3 +1,15 @@ +haskell-typed-process (0.2.5.0-1build1) eoan; urgency=medium + + * Rebuild against new GHC abi. + + -- Gianfranco Costamagna Thu, 08 Aug 2019 13:46:22 +0200 + +haskell-typed-process (0.2.5.0-1) unstable; urgency=medium + + * New upstream release + + -- Clint Adams Sun, 28 Jul 2019 15:44:47 -0400 + haskell-typed-process (0.2.3.0-2) unstable; urgency=medium * Remove build dependency on libghc-stm-dev (provided by ghc-8.4.3) diff -Nru haskell-typed-process-0.2.3.0/README.md haskell-typed-process-0.2.5.0/README.md --- haskell-typed-process-0.2.3.0/README.md 2018-08-14 09:32:26.000000000 +0000 +++ haskell-typed-process-0.2.5.0/README.md 2019-02-28 11:48:21.000000000 +0000 @@ -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 -Nru haskell-typed-process-0.2.3.0/src/System/Process/Typed/Internal.hs haskell-typed-process-0.2.5.0/src/System/Process/Typed/Internal.hs --- haskell-typed-process-0.2.3.0/src/System/Process/Typed/Internal.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-typed-process-0.2.5.0/src/System/Process/Typed/Internal.hs 2019-06-25 08:03:14.000000000 +0000 @@ -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 -Nru haskell-typed-process-0.2.3.0/src/System/Process/Typed.hs haskell-typed-process-0.2.5.0/src/System/Process/Typed.hs --- haskell-typed-process-0.2.3.0/src/System/Process/Typed.hs 2018-08-14 09:32:26.000000000 +0000 +++ haskell-typed-process-0.2.5.0/src/System/Process/Typed.hs 2019-06-26 04:52:47.000000000 +0000 @@ -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 @@ -65,6 +70,8 @@ , readProcessStdout_ , readProcessStderr , readProcessStderr_ + , readProcessInterleaved + , readProcessInterleaved_ -- * Interact with a process @@ -95,12 +102,13 @@ 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.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)) @@ -204,7 +212,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 @@ -489,7 +497,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. @@ -498,14 +514,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 @@ -534,7 +568,18 @@ -- -- @since 0.1.0.0 byteStringOutput :: StreamSpec 'STOutput (STM L.ByteString) -byteStringOutput = mkStreamSpec P.CreatePipe $ \pc (Just h) -> do +byteStringOutput = mkStreamSpec P.CreatePipe $ \pc (Just h) -> byteStringFromHandle pc h + +-- | Helper function (not exposed) for both 'byteStringOutput' and +-- 'withProcessInterleave'. This will consume all of the output from +-- the given 'Handle' in a separate thread and provide access to the +-- resulting 'L.ByteString' via STM. Second action will close the +-- reader handle. +byteStringFromHandle + :: ProcessConfig () () () + -> Handle -- ^ reader handle + -> IO (STM L.ByteString, IO ()) +byteStringFromHandle pc h = do mvar <- newEmptyTMVarIO void $ async $ do @@ -583,100 +628,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 <- 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 () - return Process {..} + return Process {..} where pConfig = clearStreams pConfig' @@ -705,27 +754,73 @@ -- | 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 +-- . +-- +-- @since 0.2.5.0 +withProcessTerm + :: ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> IO a) + -> IO 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 + :: ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> IO a) + -> IO 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 = withProcessTerm +{-# DEPRECATED withProcess "Please consider using withProcessWait, or instead use withProcessTerm" #-} --- | Same as 'withProcess', but also calls 'checkExitCode' +-- | Same as 'withProcessTerm', 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 +withProcessTerm_ + :: ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> IO a) + -> IO a +withProcessTerm_ config = bracket + (startProcess config) + (\p -> stopProcess p `finally` checkExitCode p) + +-- | Same as 'withProcessWait', but also calls 'checkExitCode' +-- +-- @since 0.2.5.0 +withProcessWait_ + :: ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> IO a) + -> IO 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_ = 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 @@ -750,6 +845,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 @@ -784,6 +881,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 @@ -799,12 +898,13 @@ where pc' = setStdout byteStringOutput pc --- | Same as 'readProcess', but only read the stderr of the process. Original settings for stderr remain. +-- | Same as 'readProcess', but only read the stderr of the process. +-- Original settings for stdout remain. -- -- @since 0.2.1.0 readProcessStderr :: MonadIO m - => ProcessConfig stdin stderrIgnored stderr + => ProcessConfig stdin stdout stderrIgnored -> m (ExitCode, L.ByteString) readProcessStderr pc = liftIO $ withProcess pc' $ \p -> atomically $ (,) @@ -816,10 +916,12 @@ -- | 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 - => ProcessConfig stdin stderrIgnored stderr + => ProcessConfig stdin stdout stderrIgnored -> m L.ByteString readProcessStderr_ pc = liftIO $ withProcess pc' $ \p -> atomically $ do @@ -831,6 +933,61 @@ where pc' = setStderr byteStringOutput pc +withProcessInterleave + :: ProcessConfig stdin stdoutIgnored stderrIgnored + -> (Process stdin (STM L.ByteString) () -> IO a) + -> IO a +withProcessInterleave pc inner = + -- Create a pipe to be shared for both stdout and stderr + 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. + hClose writeEnd + inner p + +-- | Same as 'readProcess', but interleaves stderr with stdout. +-- +-- Motivation: Use this function if you need stdout interleaved with stderr +-- output (e.g. from an HTTP server) in order to debug failures. +-- +-- @since 0.2.4.0 +readProcessInterleaved + :: MonadIO m + => ProcessConfig stdin stdoutIgnored stderrIgnored + -> m (ExitCode, L.ByteString) +readProcessInterleaved pc = + liftIO $ + withProcessInterleave pc $ \p -> + atomically $ (,) + <$> waitExitCodeSTM p + <*> getStdout p + +-- | 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 $ + withProcessInterleave pc $ \p -> atomically $ do + stdout' <- getStdout p + checkExitCodeSTM p `catchSTM` \ece -> throwSTM ece + { eceStdout = stdout' + } + return stdout' + -- | Run the given process, wait for it to exit, and returns its -- 'ExitCode'. -- @@ -876,6 +1033,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 @@ -925,6 +1085,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 diff -Nru haskell-typed-process-0.2.3.0/test/System/Process/TypedSpec.hs haskell-typed-process-0.2.5.0/test/System/Process/TypedSpec.hs --- haskell-typed-process-0.2.3.0/test/System/Process/TypedSpec.hs 2018-03-19 12:34:42.000000000 +0000 +++ haskell-typed-process-0.2.5.0/test/System/Process/TypedSpec.hs 2019-06-26 04:52:47.000000000 +0000 @@ -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" @@ -86,3 +111,58 @@ let encoded = S.filter (/= 10) $ L.toStrict lbs raw <- S.readFile fp encoded `shouldBe` B64.encode raw + + describe "withProcessWait" $ do + it "succeeds with sleep" $ do + p <- withProcessWait (proc "sleep" ["1"]) pure + checkExitCode p + + describe "withProcessWait_" $ do + it "succeeds with sleep" $ do + withProcessWait_ (proc "sleep" ["1"]) $ const $ pure () + + -- 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 + + let config = proc "sh" [fp] + -- Assert, that our bash script doesn't send output only to stdout and + -- we assume that we captured from stderr as well + onlyErr <- readProcessStderr_ (setStdout createPipe config) + onlyErr `shouldBe` "stderr\n" + + (res, lbs1) <- readProcessInterleaved config + res `shouldBe` ExitSuccess + lbs1 `shouldBe` "stdout\nstderr\nstdout\n" + + lbs2 <- readProcessInterleaved_ config + lbs1 `shouldBe` lbs2 + + it "interleaved output handles large data" $ withSystemTempFile "interleaved-output" $ \fp h -> do + S.hPut h "\nfor i in {1..4064}; do\necho 'stdout';\n>&2 echo 'stderr';\necho 'stdout';\ndone" + hClose h + + let config = proc "sh" [fp] + (result, lbs1) <- readProcessInterleaved config + result `shouldBe` ExitSuccess + lbs2 <- readProcessInterleaved_ config + lbs1 `shouldBe` lbs2 + + let expected = "stdout\nstderr\nstdout\n" + L.take (L.length expected) lbs1 `shouldBe` expected diff -Nru haskell-typed-process-0.2.3.0/typed-process.cabal haskell-typed-process-0.2.5.0/typed-process.cabal --- haskell-typed-process-0.2.3.0/typed-process.cabal 2018-08-14 09:31:51.000000000 +0000 +++ haskell-typed-process-0.2.5.0/typed-process.cabal 2019-06-25 08:04:51.000000000 +0000 @@ -1,13 +1,13 @@ -cabal-version: >= 1.10 +cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.29.0. +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 8fd30ba42322fffadc01326bcc1370fa86c650057800ca91d5381d89e91df797 +-- hash: ad27eee8ecda9f23b7e99ea05885ad76c916b5210115a132a56a28c79437d01c name: typed-process -version: 0.2.3.0 +version: 0.2.5.0 synopsis: Run external processes, with strong typing of streams description: Please see the tutorial at category: System @@ -19,8 +19,8 @@ license-file: LICENSE build-type: Simple extra-source-files: - ChangeLog.md README.md + ChangeLog.md source-repository head type: git @@ -29,6 +29,7 @@ library exposed-modules: System.Process.Typed + System.Process.Typed.Internal other-modules: Paths_typed_process hs-source-dirs: