diff --git a/shell-conduit.cabal b/shell-conduit.cabal --- a/shell-conduit.cabal +++ b/shell-conduit.cabal @@ -1,5 +1,5 @@ name: shell-conduit -version: 0.0 +version: 0.1 synopsis: Write shell scripts with Conduit description: Write shell scripts with Conduit. See "Data.Conduit.Shell" for documentation. license: BSD3 diff --git a/src/Data/Conduit/Shell.hs b/src/Data/Conduit/Shell.hs --- a/src/Data/Conduit/Shell.hs +++ b/src/Data/Conduit/Shell.hs @@ -86,11 +86,6 @@ module Data.Conduit.Shell (-- * Running scripts run - -- * Example executables - -- $examples - ,Data.Conduit.Shell.ls - ,Data.Conduit.Shell.cat - ,Data.Conduit.Shell.grep -- * Running custom processes ,shell ,proc @@ -112,56 +107,10 @@ import Data.Conduit import Data.Conduit.Filesystem import qualified Data.Conduit.Shell.PATH -import Data.Conduit.Shell.PATH hiding (ls,grep,cat) +import Data.Conduit.Shell.PATH import Data.Conduit.Shell.Process import Data.Conduit.Shell.Types import Data.Conduit.Shell.Variadic - --- $examples --- --- These are three documented executables provided as examples (chosen --- because they are bound to exist for all POSIX users), --- re-exported. To see the complete list, look at the module --- "Data.Conduit.Shell.PATH". That whole module is re-exported from --- this module. --- --- The type in each is @ProcessType r => r@, because they are --- variadic. You can specify an arbitrary number of arguments: --- --- --- >>> run ls --- dist --- .. --- --- >>> run (ls ".") --- foo.txt --- bar.txt --- >>> run (ls "/") --- bin --- boot --- cdrom --- ... --- --- >>> run (ls "/" "-al") --- total 180 --- drwxr-xr-x 24 root root 4096 Aug 4 2013 . --- drwxr-xr-x 24 root root 4096 Aug 4 2013 .. --- drwxr-xr-x 2 root root 4096 Sep 12 08:35 bin --- drwxr-xr-x 4 root root 4096 May 28 2013 boot --- drwxr-xr-x 2 root root 4096 Apr 27 2013 cdrom --- ... - --- | List directory contents. -ls :: ProcessType r => r -ls = Data.Conduit.Shell.PATH.ls - --- | Print lines matching a pattern. -grep :: ProcessType r => r -grep = Data.Conduit.Shell.PATH.grep - --- | Concatenate files and print on the standard output. -cat :: ProcessType r => r -cat = Data.Conduit.Shell.PATH.cat -- $exports -- diff --git a/src/Data/Conduit/Shell/Process.hs b/src/Data/Conduit/Shell/Process.hs --- a/src/Data/Conduit/Shell/Process.hs +++ b/src/Data/Conduit/Shell/Process.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -- | Reading from the process. @@ -23,18 +24,15 @@ import Control.Applicative import qualified Control.Exception as E -import Control.Monad import Control.Monad.Trans -import Control.Monad.Trans.Loop import Control.Monad.Trans.Resource -import Data.ByteString +import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.Conduit import Data.Conduit.List (sourceList) import qualified Data.Conduit.List as CL import Data.Conduit.Process import Data.Either -import Data.Maybe import System.Exit (ExitCode(..)) import System.IO import qualified System.Process @@ -108,63 +106,85 @@ discardChunks = awaitForever (const (return ())) -- | Conduit of process. -conduitProcess - :: (MonadResource m) - => CreateProcess - -> Conduit Chunk m Chunk -conduitProcess cp = bracketP createp closep $ \(Just cin, Just cout, _, ph) -> do - end <- repeatLoopT $ do - -- if process's outputs are available, then yields them. - repeatLoopT $ do - b <- liftIO $ hReady' cout - when (not b) exit - out <- liftIO $ S.hGetSome cout bufSize - void $ lift . lift $ yield (Right out) - - -- if process exited, then exit - end <- liftIO $ getProcessExitCode ph - when (isJust end) $ exitWith end - - inp <- lift await - case inp of - -- if upper stream ended, then exit - Nothing -> exitWith Nothing - Just c -> - case c of - -- pass along errors to next process - Left{} -> lift (leftover c) - -- write stdin into this process - Right s -> - liftIO (do S.hPut cin s - hFlush cin) +conduitProcess :: (MonadResource m) + => CreateProcess -> Conduit Chunk m Chunk +conduitProcess cp = + bracketP createp closep startProxy + where createp = + createProcess + cp {std_in = CreatePipe + ,std_out = CreatePipe + ,std_err = CreatePipe} + closep (Just cin,Just cout,Just cerr,ph) = + do hClose cin + hClose cout + hClose cerr + _ <- waitForProcess' ph + return () - -- uppstream or process is done. - -- process rest outputs. - liftIO $ hClose cin - repeatLoopT $ do - out <- liftIO $ S.hGetSome cout bufSize - when (S.null out) exit - lift $ yield (Right out) +-- | Start proxying from conduit to process back to conduit. +startProxy :: (MonadIO m,MonadThrow m) + => (Maybe Handle,Maybe Handle,Maybe Handle,ProcessHandle) + -> ConduitM Chunk Chunk m () +startProxy (Just cin,Just cout,Just cerr,ph) = interleave + where interleave = + do end <- proxyInterleaved + liftIO (hClose cin) + remainder cout Right + remainder cerr Left + ec <- liftIO (maybe (waitForProcess' ph) return end) + case ec of + ExitSuccess -> return () + ExitFailure i -> + monadThrow (ShellExitFailure i) + proxyInterleaved = + do proxy cout Right + proxy cerr Left + ended <- liftIO (getProcessExitCode ph) + case ended of + Just{} -> return ended + Nothing -> + do minp <- await + case minp of + Nothing -> return Nothing + Just chunk -> + do case chunk of + Left{} -> yield chunk + Right bytes -> + liftIO (do S.hPut cin bytes + hFlush cin) + proxyInterleaved - ec <- liftIO $ maybe (waitForProcess' ph) return end - case ec of - ExitSuccess -> return () - ExitFailure i -> lift (monadThrow (ShellExitFailure i)) +-- | Proxy live results from the given handle and yield them. +proxy :: MonadIO m + => Handle -> (ByteString -> o) -> ConduitM i o m () +proxy h cons = + do ready <- liftIO (hReady' h) + if not ready + then return () + else do bytes <- liftIO (S.hGetSome h bufSize) + yield (cons bytes) + proxy h cons - where - createp = createProcess cp - { std_in = CreatePipe - , std_out = CreatePipe - } +-- | Proxy final results from the handle and yield them. +remainder :: MonadIO m + => Handle -> (ByteString -> o) -> ConduitM i o m () +remainder h cons = + do bytes <- liftIO (S.hGetSome h bufSize) + if S.null bytes + then return () + else do yield (cons bytes) + remainder h cons - closep (Just cin, Just cout, _, ph) = do - hClose cin - hClose cout - _ <- waitForProcess' ph - return () - closep _ = error "Data.Conduit.Process.closep: Unhandled case" +-- | Is the handle ready? Catches any exceptions. +hReady' :: Handle -> IO Bool +hReady' h = + E.catch (hReady h) + (\(E.SomeException _) -> return False) - hReady' h = - hReady h `E.catch` \(E.SomeException _) -> return False - waitForProcess' ph = - waitForProcess ph `E.catch` \(E.SomeException _) -> return ExitSuccess +-- | A safer 'waitForProcess'. +waitForProcess' :: ProcessHandle -> IO ExitCode +waitForProcess' ph = + E.catch (waitForProcess ph) + (\(E.SomeException _) -> + return ExitSuccess)