diff --git a/lib/Pipes/Cliff.hs b/lib/Pipes/Cliff.hs --- a/lib/Pipes/Cliff.hs +++ b/lib/Pipes/Cliff.hs @@ -54,12 +54,6 @@ , procSpec , squelch - -- * Type synonyms - , Stdin - , Outstream - , Stdout - , Stderr - -- * Creating processes -- $process @@ -72,11 +66,8 @@ , pipeInputOutputError -- * 'Proxy' combinators - , forwardRight - , wrapRight , conveyor , safeEffect - , immortal -- * Querying and terminating the process , ProcessHandle @@ -203,6 +194,11 @@ handle this issue; she can just perform a 'Control.Exception.bracket' and may combine this with the @ContT@ monad in @transformers@ or @mtl@ if she wishes, or perhaps with the @managed@ library. + +An earlier version of this library (see version 0.8.0.0) tried to use +the return value of a 'Proxy' to indicate the return value of both +processes in the pipeline, not just one. I removed this because it +interfered heavily with composability. You might wonder why, if you are using an external process as a pipeline, why can't you create, well, a 'Pipe'? Wouldn't diff --git a/lib/Pipes/Cliff/Core.hs b/lib/Pipes/Cliff/Core.hs --- a/lib/Pipes/Cliff/Core.hs +++ b/lib/Pipes/Cliff/Core.hs @@ -472,9 +472,12 @@ mapM_ runFnlzr fnlzrs -- | Gets the exit code of the process that belongs to the 'ProcessHandle'. --- Side effects: may block if process has not yet exited. Usually you --- can get the exit code through more idiomatic @pipes@ functions, as --- the various 'Proxy' return the 'ExitCode'. +-- Often you can get the exit code through more idiomatic @pipes@ +-- functions, as the various 'Proxy' return the 'ExitCode'. Sometimes +-- though it can be difficult to use the @pipes@ idioms to get the +-- exit code, so this function is here. +-- +-- Side effects: may block if process has not yet exited. waitForProcess :: ProcessHandle -> IO ExitCode waitForProcess pnl = phConsole pnl >>= csExitCode @@ -569,8 +572,7 @@ -- to an exhausted mailbox. This will signal to the other side of -- the mailbox that the mailbox is sealed. -- --- In addition to returning the two 'Proxy', also returns an STM --- action that will manually seal the mailbox. +-- Also returns an STM action to seal the box manually. newMailbox :: (MonadSafe mi, MonadSafe mo) => IO (Consumer a mi (), Producer a mo (), STM ()) @@ -582,74 +584,6 @@ >> produceFromBox fromBox return (csmr, pdcr, seal) --- * Type synonyms - --- | Consumer that reads values for a process standard input. Its --- input value is described in 'Outstream'. The result type is a --- tuple @(a, b)@, where @a@ is the return code from the upstream --- process, and @b@ is the return code from this process. @a@ will be --- Nothing if the downstream process terminated before the upstream --- one, or @Just@ if the upstream process terminated first. The --- 'Consumer' process's process exit code is always available and is --- returned in @b@. -type Stdin m a - = Consumer (Either a ByteString) m (Maybe a, ExitCode) - --- | Producer of values from a process standard output or error. 'yield' a --- @'Left'@ if the stream is done producing values, or a --- @'Right' 'ByteString'@ if the stream is still producing values. --- 'Outstream' is polymorphic in its return type, @r@, becasuse the --- 'Outstream' never stops yielding values; instead, it just 'yield's --- its exit code over and over again after the process terminates. - -type Outstream r m a - = Producer (Either a ByteString) m r - --- | Producer of values from a process standard output. -type Stdout r m a = Outstream r m a - --- | Producer of values from a process standard error. -type Stderr r m a = Outstream r m a - - --- * 'Proxy' combinators - --- | Forwards only Right values; terminates on the first Left value --- and returns its value. Useful to forward the output of an --- 'Outstream' to a pipeline that expects only 'ByteString's. -forwardRight :: Monad m => Pipe (Either a b) b m a -forwardRight = do - ei <- await - case ei of - Left l -> return l - Right r -> yield r >> forwardRight - --- | Forwards all values, after rewrapping them in a Right. Useful to --- convert a producer of 'ByteString' into a 'Producer' of 'Either' --- which can be fed to a 'Stdin'. -wrapRight :: Monad m => Pipe a (Either l a) m r -wrapRight = do - x <- await - yield (Right x) - wrapRight - --- | Converts a 'Producer' that returns a particular type --- to one that never returns a value at all but that, instead, takes --- that return type and 'yield's it forever as a 'Left'. Use it with --- '>>=', like so: --- --- @ --- alwaysUnit :: Monad m => Producer (Either () a) m r --- alwaysUnit = return () >>= immortal --- @ --- --- This is useful to convert a producer of values that might terminate --- into one that does not terminate, so that it can be fed into a --- 'Stdin'. For an example of its use, see --- 'Penny.Cliff.Examples.limitedAlphaNumbers'. -immortal :: Monad m => r -> Producer' (Either r a) m r' -immortal a = forever (yield (Left a)) - -- * Exception safety -- | Creates a process, uses it, and terminates it when the last @@ -704,10 +638,10 @@ -- ^ Has the 'Handle' that will be closed. -> (Handle -> mi a) -- ^ The remainder of the computation. - -> IO (mi a) + -> mi a initHandle desc get pnl mkProxy = mask_ $ do - cnsl <- phConsole $ pnl - return $ mask $ \restore -> + cnsl <- liftIO $ phConsole $ pnl + mask $ \restore -> let han = get cnsl fnlzr = closeHandleNoThrow han desc (cmdspec . phCreateProcess $ pnl) (handler . phCreateProcess $ pnl) @@ -725,7 +659,7 @@ consumeToHandle :: (MonadSafe mi, MonadCatch (Base mi)) => ProcessHandle - -> IO (Consumer ByteString mi ()) + -> Consumer ByteString mi () consumeToHandle pnl = initHandle Input get pnl fn where get cnsl = case csIn cnsl of @@ -747,7 +681,7 @@ :: (MonadSafe mi, MonadCatch (Base mi)) => Outbound -> ProcessHandle - -> IO (Producer ByteString mi ()) + -> Producer ByteString mi () produceFromHandle outb pnl = initHandle (Outbound outb) get pnl fn where get cnsl = case outb of @@ -800,44 +734,29 @@ -- terminates the process. -- -- * Returns a 'Consumer'. The 'Consumer' consumes to the mailbox. --- The 'Consumer' forwards all 'Right' values obtained from the --- 'yield' to the mailbox. The 'Consumer' ceases consumption on the --- first 'Left' value. --- --- The returned 'Consumer' will, on the first 'Left' value, manually --- seal the mailbox that transmits to the spawned thread. This causes --- the background 'Effect' to shut down which will, in turn, cause the --- 'MonadSafe' computation to invoke its finalizers which will close --- the process's stdin. That should cause the process to shut down. --- Then we wait for the background thead to finish, and then wait for --- the process's exit code. +-- This 'Consumer' returns the exit code of this process (but remember +-- that the ultimate result of the 'Proxy' depends on which component +-- terminates first). -- --- The returned 'Proxy' always returns the exit code of this process. --- In addition, if the upstream 'Producer' terminated first, that --- return value is returned as well. If this process terminated first --- (perhaps because the user shut it down manually, or it otherwise --- shut down without needing all of its stdin) then there will be no --- return value from the upstream 'Producer' to return. +-- Does not register in the 'MonadSafe' an action to cancel the +-- background thread. Data might still be moving to the process even +-- if the 'Proxy' has shut down. Let the thread terminate through +-- mailbox closure or a broken pipe. runInputHandle :: (MonadSafe mi, MonadCatch (Base mi)) => ProcessHandle -- ^ - -> IO (Stdin mi r) + -> Consumer ByteString mi ExitCode -- ^ -runInputHandle pnl = mask_ $ do - csmr <- consumeToHandle pnl - (toBox, fromBox, seal) <- newMailbox - asyncId <- conveyor $ fromBox >-> csmr - addReleaser pnl (cancel asyncId) - let f proxyRes = do - liftIO . atomically $ seal - thisCode <- liftIO $ finishProxy asyncId pnl - return $ case proxyRes of - Just firstCode -> (Just firstCode, thisCode) - Nothing -> (Nothing, thisCode) +runInputHandle pnl = mask $ \restore -> do + (toBox, fromBox, seal) <- liftIO newMailbox + asyncId <- liftIO . conveyor $ fromBox >-> (consumeToHandle pnl) + liftIO $ addReleaser pnl (cancel asyncId) + restore $ do + toBox + liftIO $ atomically seal + liftIO $ finishProxy asyncId pnl - return (((fmap Just forwardRight) >-> fmap (const Nothing) toBox) >>= f) - -- | Takes all steps necessary to get a 'Producer' for standard -- input. Sets up a mailbox, runs a conveyor in the background. Then @@ -848,24 +767,23 @@ -- ^ -> ProcessHandle -- ^ - -> IO (Outstream r mi ExitCode) + -> Producer ByteString mi ExitCode -- ^ -runOutputHandle outb pnl = mask_ $ do - pdcFromHan <- produceFromHandle outb pnl - (toBox, fromBox, _) <- newMailbox - asyncId <- conveyor $ pdcFromHan >-> toBox - addReleaser pnl (cancel asyncId) - let f () = do - code <- liftIO $ finishProxy asyncId pnl - forever (yield (Left code)) - return $ (fromBox >-> wrapRight) >>= f +runOutputHandle outb pnl = mask $ \restore -> do + (toBox, fromBox, seal) <- liftIO newMailbox + asyncId <- liftIO . conveyor $ (produceFromHandle outb pnl) >-> toBox + liftIO $ addReleaser pnl (cancel asyncId) + restore $ do + fromBox + liftIO $ atomically seal + liftIO $ finishProxy asyncId pnl -- * Creating Proxy -- | Create a 'Consumer' for standard input. pipeInput - :: (MonadSafe m, MonadCatch (Base m)) + :: (MonadSafe mi, MonadCatch (Base mi)) => NonPipe -- ^ Standard output @@ -875,11 +793,11 @@ -> CreateProcess - -> IO (Stdin m a, ProcessHandle) + -> IO (Consumer ByteString mi ExitCode, ProcessHandle) -- ^ A 'Consumer' for standard input pipeInput out err cp = mask_ $ do pnl <- newProcessHandle Nothing (Just out) (Just err) cp - inp <- runInputHandle pnl + let inp = runInputHandle pnl return (inp, pnl) @@ -895,11 +813,11 @@ -> CreateProcess - -> IO (Stdout r mo ExitCode, ProcessHandle) + -> IO (Producer ByteString mo ExitCode, ProcessHandle) -- ^ A 'Producer' for standard output pipeOutput inp err cp = mask_ $ do pnl <- newProcessHandle (Just inp) Nothing (Just err) cp - pdcr <- runOutputHandle Output pnl + let pdcr = runOutputHandle Output pnl return (pdcr, pnl) @@ -915,12 +833,12 @@ -> CreateProcess - -> IO (Stderr r me ExitCode, ProcessHandle) + -> IO (Producer ByteString me ExitCode, ProcessHandle) -- ^ A 'Producer' for standard error pipeError inp out cp = mask_ $ do pnl <- newProcessHandle (Just inp) (Just out) Nothing cp - pdcr <- runOutputHandle Error pnl + let pdcr = runOutputHandle Error pnl return (pdcr, pnl) -- | Create a 'Consumer' for standard input and a 'Producer' for @@ -934,14 +852,16 @@ -> CreateProcess - -> IO ((Stdin mi a, Stdout r mo ExitCode), ProcessHandle) + -> IO ( (Consumer ByteString mi ExitCode , Producer ByteString mo ExitCode) + , ProcessHandle + ) -- ^ A 'Consumer' for standard input, a 'Producer' for standard -- output pipeInputOutput err cp = mask_ $ do pnl <- newProcessHandle Nothing Nothing (Just err) cp - csmr <- runInputHandle pnl - pdcr <- runOutputHandle Output pnl + let csmr = runInputHandle pnl + pdcr = runOutputHandle Output pnl return ((csmr, pdcr), pnl) -- | Create a 'Consumer' for standard input and a 'Producer' for @@ -955,13 +875,15 @@ -- ^ Standard output -> CreateProcess - -> IO ((Stdin mi a, Stderr r me ExitCode), ProcessHandle) + -> IO ( (Consumer ByteString mi ExitCode, Producer ByteString me ExitCode) + , ProcessHandle + ) -- ^ A 'Consumer' for standard input, a 'Producer' for standard -- error pipeInputError out cp = do pnl <- newProcessHandle Nothing (Just out) Nothing cp - csmr <- runInputHandle pnl - pdcr <- runOutputHandle Error pnl + let csmr = runInputHandle pnl + pdcr = runOutputHandle Error pnl return ((csmr, pdcr), pnl) @@ -976,14 +898,16 @@ -> CreateProcess - -> IO ((Stdout ro mo ExitCode, Stderr re me ExitCode), ProcessHandle) + -> IO ( (Producer ByteString mo ExitCode, Producer ByteString me ExitCode) + , ProcessHandle + ) -- ^ A 'Producer' for standard output and a 'Producer' for standard -- error pipeOutputError inp cp = do pnl <- newProcessHandle (Just inp) Nothing Nothing cp - pdcrOut <- runOutputHandle Output pnl - pdcrErr <- runOutputHandle Error pnl + let pdcrOut = runOutputHandle Output pnl + pdcrErr = runOutputHandle Error pnl return ((pdcrOut, pdcrErr), pnl) @@ -996,7 +920,10 @@ => CreateProcess - -> IO ( (Stdin mi a, Stdout ro mo ExitCode, Stderr re me ExitCode) + -> IO ( ( Consumer ByteString mi ExitCode + , Producer ByteString mo ExitCode + , Producer ByteString me ExitCode + ) , ProcessHandle ) -- ^ A 'Consumer' for standard input, a 'Producer' for standard @@ -1004,7 +931,7 @@ pipeInputOutputError cp = do pnl <- newProcessHandle Nothing Nothing Nothing cp - csmr <- runInputHandle pnl - pdcrOut <- runOutputHandle Output pnl - pdcrErr <- runOutputHandle Error pnl + let csmr = runInputHandle pnl + pdcrOut = runOutputHandle Output pnl + pdcrErr = runOutputHandle Error pnl return ((csmr, pdcrOut, pdcrErr), pnl) diff --git a/lib/Pipes/Cliff/Examples.hs b/lib/Pipes/Cliff/Examples.hs --- a/lib/Pipes/Cliff/Examples.hs +++ b/lib/Pipes/Cliff/Examples.hs @@ -44,26 +44,35 @@ -- standard error. This is normal. To suppress them, see the -- 'handler' option. -numsToLess :: IO (Maybe ExitCode, ExitCode) +numsToLess :: IO ExitCode numsToLess = do (toLess, _) <- pipeInput Inherit Inherit (procSpec "less" []) - safeEffect $ produceNumbers >-> wrapRight >-> toLess + safeEffect $ produceNumbers >-> toLess -- | Streams an infinite list of numbers to @tr@ and then to @less@. -- Perfectly useless, but shows how to build pipelines. Also -- squlches warning messages using the 'handler' option. +-- +-- Note that, consistent with usual @pipes@ usage, the value of +-- @code1@ and @code2@ is not necessarily the last exit code in the +-- pipeline. Rather, it is the exit code of the process that +-- terminated first. Use 'waitForProcess' if you need to determine +-- the exit value of a particular process. It's also possible to use +-- a bit of 'fmap' to see which process in a pipeline did terminate +-- first; for an example of that, search the "Pipes.Tutorial" module +-- for @echo3.hs@. alphaNumbers :: IO (ExitCode, ExitCode) alphaNumbers = do ((toTr, fromTr), _) <- pipeInputOutput Inherit (procSpec "tr" ["[0-9]", "[a-z]"]) { handler = squelch } (toLess, _) <- pipeInput Inherit Inherit (procSpec "less" []) { handler = squelch } - toTrAsync <- conveyor $ produceNumbers >-> wrapRight >-> toTr + toTrAsync <- conveyor $ produceNumbers >-> toTr toLessAsync <- conveyor $ fromTr >-> toLess - (_, trCode) <- wait toTrAsync - (_, lessCode) <- wait toLessAsync - return (trCode, lessCode) + code1 <- wait toTrAsync + code2 <- wait toLessAsync + return (code1, code2) -- | Produces an infinite stream of numbers, sends it to @tr@ for some @@ -87,12 +96,11 @@ ((toSh, fromShOut, fromShErr), _) <- pipeInputOutputError (procSpec "sh" ["-c", script]) (toLess, _) <- pipeInput Inherit Inherit (procSpec "less" []) - _ <- conveyor $ produceNumbers >-> wrapRight >-> toTr + _ <- conveyor $ produceNumbers >-> toTr _ <- conveyor $ fromTr >-> toSh _ <- conveyor $ fromShOut >-> toLess runSafeT - $ P.fold BS8.append BS8.empty id - (fromShErr >-> (forwardRight >> return ())) + $ P.fold BS8.append BS8.empty id (fromShErr >> return ()) where script = "while read line; do echo $line; echo $line 1>&2; done" @@ -100,7 +108,7 @@ -- | Like 'alphaNumbers' but just sends a limited number -- of numbers to @cat@. A useful test to make sure that pipelines -- shut down automatically. -limitedAlphaNumbers :: IO (Maybe ExitCode, ExitCode) +limitedAlphaNumbers :: IO ExitCode limitedAlphaNumbers = do ((toTr, fromTr), _) <- pipeInputOutput Inherit (procSpec "tr" ["[0-9]", "[a-z]"]) @@ -108,9 +116,8 @@ _ <- async . safeEffect $ produceNumbers - >-> wrapRight - >-> (P.take 300 >>= immortal) - >-> toTr + >-> P.take 300 + >-> (toTr >> return ()) safeEffect $ fromTr >-> toCat @@ -125,12 +132,10 @@ (procSpec "tr" ["[0-9]", "[a-z]"]) _ <- conveyor $ produceNumbers - >-> wrapRight - >-> (P.take 300 >>= immortal) - >-> toTr - let trByteStrings = (fromTr >-> forwardRight) >> return () + >-> P.take 300 + >-> (toTr >> return ()) runSafeT - $ P.fold BS8.append BS8.empty id trByteStrings + $ P.fold BS8.append BS8.empty id (fromTr >> return ()) -- | So far, all examples have ignored the issue of exception safety. -- Here's an example that properly uses 'bracket' to make sure that @@ -150,11 +155,10 @@ $ \(toSh, fromShOut, fromShErr) -> withProcess (pipeInput Inherit Inherit (procSpec "less" [])) $ \toLess -> - withConveyor (produceNumbers >-> wrapRight >-> toTr) $ + withConveyor (produceNumbers >-> toTr) $ withConveyor (fromTr >-> toSh) $ withConveyor (fromShOut >-> toLess) $ runSafeT - $ P.fold BS8.append BS8.empty id - (fromShErr >-> (forwardRight >> return ())) + $ P.fold BS8.append BS8.empty id (fromShErr >> return ()) where script = "while read line; do echo $line; echo $line 1>&2; done" diff --git a/pipes-cliff.cabal b/pipes-cliff.cabal --- a/pipes-cliff.cabal +++ b/pipes-cliff.cabal @@ -3,11 +3,11 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: genCabal.hs --- Generated on: 2015-03-29 13:40:34.092315 EDT +-- Generated on: 2015-03-29 17:35:28.800812 EDT -- Cartel library version: 0.14.2.6 name: pipes-cliff -version: 0.8.0.2 +version: 0.10.0.0 cabal-version: >= 1.18 license: BSD3 license-file: LICENSE