shell-conduit 0.0 → 0.1
raw patch · 3 files changed
+81/−112 lines, 3 files
Files
- shell-conduit.cabal +1/−1
- src/Data/Conduit/Shell.hs +1/−52
- src/Data/Conduit/Shell/Process.hs +79/−59
shell-conduit.cabal view
@@ -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
src/Data/Conduit/Shell.hs view
@@ -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 --
src/Data/Conduit/Shell/Process.hs view
@@ -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)