diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2014, shell-conduit +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of shell-conduit nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/shell-conduit.cabal b/shell-conduit.cabal new file mode 100644 --- /dev/null +++ b/shell-conduit.cabal @@ -0,0 +1,38 @@ +name: shell-conduit +version: 0.0 +synopsis: Write shell scripts with Conduit +description: Write shell scripts with Conduit. See "Data.Conduit.Shell" for documentation. +license: BSD3 +license-file: LICENSE +author: Chris Done +maintainer: chrisdone@gmail.com +copyright: 2014 Chris Done +category: Conduit, Scripting +build-type: Simple +cabal-version: >=1.8 + +library + hs-source-dirs: src/ + ghc-options: -Wall -O2 + exposed-modules: Data.Conduit.Shell + Data.Conduit.Shell.PATH + Data.Conduit.Shell.TH + Data.Conduit.Shell.Process + Data.Conduit.Shell.Types + Data.Conduit.Shell.Variadic + build-depends: base >= 4 && <5 + , bytestring + , conduit + , conduit-extra + , control-monad-loop + , directory + , filepath + , monad-control + , monads-tf + , process + , resourcet + , split + , template-haskell + , transformers + , transformers-base + , text diff --git a/src/Data/Conduit/Shell.hs b/src/Data/Conduit/Shell.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Shell.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- | Shell scripting with Conduit +-- +-- This module consists only of re-exports, including a few thousand +-- top-level names based on @PATH@. If you don't want that, you can +-- cherry-pick specific modules to import from the library. +-- +-- See "Data.Conduit.Shell.PATH" for all binaries. But you should be +-- able to use whatever executables are in your @PATH@ when the library +-- is compiled. +-- +-- == Examples +-- +-- The monad instance of Conduit will simply pass along all stdout +-- results: +-- +-- >>> run (do echo "Hello"; sed "s/l/a/"; echo "OK!") +-- Hello +-- OK! +-- +-- Piping with Conduit's normal pipe will predictably pipe things +-- together, as in Bash: +-- +-- >>> run (do shell "echo Hello" $= sed "s/l/a/"; echo "OK!") +-- Healo +-- OK! +-- +-- Streaming pipes (aka lazy pipes) is also possible: +-- +-- >>> run (do tail' "foo.txt" "-f" $= grep "--line-buffered" "Hello") +-- Hello, world! +-- Oh, hello! +-- +-- (Remember that @grep@ needs @--line-buffered@ if it is to output +-- things line-by-line). +-- +-- == How it works +-- +-- All executable names in the @PATH@ at compile-time are brought into +-- scope as runnable process conduits e.g. @ls@ or @grep@. +-- +-- Stdin/out and stderr are handled as an 'Either' type: 'Chunk' +-- +-- 'Left' is stderr, 'Right' is @stdin@/@stdout@. +-- +-- All processes are bound as variadic process calling functions, like this: +-- +-- @ +-- rmdir :: ProcessType r => r +-- ls :: ProcessType r => r +-- @ +-- +-- But ultimately the types end up being: +-- +-- @ +-- rmdir "foo" :: Conduit Chunk m Chunk +-- ls :: Conduit Chunk m Chunk +-- ls "." :: Conduit Chunk m Chunk +-- @ +-- +-- Etc. +-- +-- Run all shell scripts with 'run': +-- +-- @ +-- run :: (MonadIO m, MonadBaseControl IO m) +-- => Conduit Chunk (ShellT m) Chunk -> m () +-- @ +-- +-- == String types +-- +-- If using @OverloadedStrings@ so that you can use 'Text' for arguments, +-- then also enable @ExtendedDefaultRules@, otherwise you'll get +-- ambiguous type errors. +-- +-- @ +-- {-# LANGUAGE ExtendedDefaultRules #-} +-- @ +-- +-- But this isn't necessary if you don't need to use 'Text' yet. Strings +-- literals will be interpreted as 'String'. Though you can pass a value +-- of type 'Text' or any instance of 'CmdArg' without needing conversions. +-- + +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 + -- * I/O chunks + ,withRights + ,redirect + ,quiet + ,writeChunks + ,discardChunks + -- * Re-exports + -- $exports + ,module Data.Conduit.Shell.PATH + ,module Data.Conduit.Shell.Types + ,module Data.Conduit.Shell.Variadic + ,module Data.Conduit.Filesystem + ,module Data.Conduit) + where + +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.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 +-- +-- The following modules are exported for scripting +-- convenience. "Data.Conduit" and "Data.Conduit.Filesystem" are +-- re-exported from other libraries because they are typical uses. If +-- you want a stream of the contents of a directory, recursively, +-- 'sourceDirectoryDeep' is handy. A program like @find@ is strict, +-- whereas a Conduit can stop processing whenever you wish. +-- +-- You might want to import the regular Conduit modules qualified, too: +-- +-- @ +-- import qualified Data.Conduit.List as CL +-- @ +-- +-- Which contains handy functions for working on streams in a +-- list-like way. See the rest of the handy modules for Conduit in +-- conduit-extra: +-- +-- Also of interest is csv-conduit: +-- And html-conduit: +-- And http-conduit: +-- +-- Finally, see the Conduit category on Hackage for other useful libraries: +-- +-- All of these general purpose Conduits can be used in shell +-- scripting. diff --git a/src/Data/Conduit/Shell/PATH.hs b/src/Data/Conduit/Shell/PATH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Shell/PATH.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +-- | All binaries in PATH. + +module Data.Conduit.Shell.PATH where + +import Data.Conduit.Shell.TH + +$(generateBinaries) diff --git a/src/Data/Conduit/Shell/Process.hs b/src/Data/Conduit/Shell/Process.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Shell/Process.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Reading from the process. + +module Data.Conduit.Shell.Process + (-- * Running scripts + run + -- * Running processes + ,Data.Conduit.Shell.Process.shell + ,Data.Conduit.Shell.Process.proc + -- * I/O chunks + ,withRights + ,redirect + ,quiet + ,writeChunks + ,discardChunks + -- * Low-level internals + ,conduitProcess + ) + where + +import Data.Conduit.Shell.Types + +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 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 + +-- | Run a shell command. +shell :: (MonadResource m) => String -> Conduit Chunk m Chunk +shell = conduitProcess . System.Process.shell + +-- | Run a shell command. +proc :: (MonadResource m) => String -> [String] -> Conduit Chunk m Chunk +proc px args = conduitProcess (System.Process.proc px args) + +-- | Size of buffer used to read from process. +bufSize :: Int +bufSize = 64 * 1024 + +-- | Do something with just the rights. +withRights :: (Monad m) + => Conduit ByteString m ByteString -> Conduit Chunk m Chunk +withRights f = + getZipConduit + (ZipConduit f' *> + ZipConduit g') + where f' = + CL.mapMaybe (either (const Nothing) Just) =$= + f =$= + CL.map Right + g' = CL.filter isLeft + +-- | Redirect the given chunk type to the other type. +redirect :: Monad m + => ChunkType -> Conduit Chunk m Chunk +redirect ty = + CL.map (\c' -> + case c' of + Left x' -> + case ty of + Stderr -> Right x' + Stdout -> c' + Right x' -> + case ty of + Stderr -> c' + Stdout -> Left x') + +-- | Discard any output from the command: make it quiet. +quiet :: (Monad m,MonadIO m) => Conduit Chunk m Chunk -> Conduit Chunk m Chunk +quiet m = m $= discardChunks + +-- | Run a shell scripting conduit. +run :: (MonadIO m,MonadBaseControl IO m) + => Conduit Chunk (ShellT m) Chunk -> m () +run p = + runResourceT + (runShellT (sourceList [] $= + p $$ + writeChunks)) + +-- | Write chunks to stdout and stderr. +writeChunks :: (MonadIO m) + => Consumer Chunk m () +writeChunks = + awaitForever + (\c -> + case c of + Left e -> liftIO (S.hPut stderr e) + Right o -> liftIO (S.hPut stdout o)) + +-- | Discard all chunks. +discardChunks :: (MonadIO m) + => Consumer Chunk m () +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) + + -- 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) + + ec <- liftIO $ maybe (waitForProcess' ph) return end + case ec of + ExitSuccess -> return () + ExitFailure i -> lift (monadThrow (ShellExitFailure i)) + + where + createp = createProcess cp + { std_in = CreatePipe + , std_out = CreatePipe + } + + closep (Just cin, Just cout, _, ph) = do + hClose cin + hClose cout + _ <- waitForProcess' ph + return () + closep _ = error "Data.Conduit.Process.closep: Unhandled case" + + hReady' h = + hReady h `E.catch` \(E.SomeException _) -> return False + waitForProcess' ph = + waitForProcess ph `E.catch` \(E.SomeException _) -> return ExitSuccess diff --git a/src/Data/Conduit/Shell/TH.hs b/src/Data/Conduit/Shell/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Shell/TH.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | Generate top-level names for binaries. + +module Data.Conduit.Shell.TH + (generateBinaries) + where + +import Data.Conduit.Shell.Variadic + +import Control.Arrow +import Control.Monad +import Data.Char +import Data.Function +import Data.List +import Data.List.Split +import Language.Haskell.TH +import System.Directory +import System.Environment +import System.FilePath + +-- | Generate top-level names for all binaries in PATH. +generateBinaries :: Q [Dec] +generateBinaries = + do bins <- runIO getAllBinaries + return (map (\(name,bin) -> + FunD (mkName name) + [Clause [] + (NormalB (AppE (VarE 'variadicProcess) + (LitE (StringL bin)))) + []]) + (nubBy (on (==) fst) + (filter (not . null . fst) + (map (normalize &&& id) bins)))) + where normalize = remap . uncapitalize . go + where go (c:cs) + | c == '-' || c == '_' = + case go cs of + (z:zs) -> toUpper z : zs + [] -> [] + | not (elem (toLower c) allowed) = go cs + | otherwise = c : go cs + go [] = [] + uncapitalize (c:cs) + | isDigit c = '_' : c : cs + | otherwise = toLower c : cs + uncapitalize [] = [] + allowed = + ['a' .. 'z'] ++ + ['0' .. '9'] + +-- | Remap conflicting names. +remap :: [Char] -> [Char] +remap name = + case name of + "head" -> "head'" + "seq" -> "seq'" + "zip" -> "zip'" + "print" -> "print'" + "id" -> "id'" + "unzip" -> "unzip'" + "join" -> "join'" + "init" -> "init'" + "last" -> "last'" + "tail" -> "tail'" + "find" -> "find'" + "sort" -> "sort'" + "sum" -> "sum'" + "compare" -> "compare'" + "truncate" -> "truncate'" + "lex" -> "lex'" + "env" -> "env'" + e -> e + +-- | Get a list of all binaries in PATH. +getAllBinaries :: IO [FilePath] +getAllBinaries = + do path <- getEnv "PATH" + fmap concat + (forM (splitOn ":" path) + (\dir -> + do exists <- doesDirectoryExist dir + if exists + then do contents <- getDirectoryContents dir + filterM (\file -> + do exists' <- doesFileExist (dir file) + if exists' + then do perms <- getPermissions (dir file) + return (executable perms) + else return False) + contents + else return [])) diff --git a/src/Data/Conduit/Shell/Types.hs b/src/Data/Conduit/Shell/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Shell/Types.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | All types. + +module Data.Conduit.Shell.Types where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.Base +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Control +import Control.Monad.Trans.Resource +import Data.ByteString (ByteString) +import Data.Conduit +import Data.Typeable + +-- | A chunk, either stdout/stdin or stderr. Used for both input and +-- output. +type Chunk = Either ByteString ByteString + +-- | Either stdout or stderr. +data ChunkType + = Stderr -- ^ Stderr. + | Stdout -- ^ Stdin or stdout. + deriving (Eq,Enum,Bounded) + +-- | Shell transformer. +newtype ShellT m a = + ShellT {runShellT :: ResourceT m a} + deriving (Applicative,Monad,Functor,MonadThrow,MonadIO,MonadTrans) + +deriving instance (MonadResourceBase m) => MonadBase IO (ShellT m) +deriving instance (MonadResourceBase m) => MonadResource (ShellT m) + +-- | Dumb instance. +instance (MonadThrow m,MonadIO m,MonadBaseControl IO m) => MonadBaseControl IO (ShellT m) where + newtype StM (ShellT m) a = StMShell{unStMGeoServer :: + StM (ResourceT m) a} + liftBaseWith f = + ShellT (liftBaseWith + (\run -> + f (liftM StMShell . + run . + runShellT))) + restoreM = ShellT . restoreM . unStMGeoServer + +-- | Intentionally only handles 'ShellException'. Use normal exception +-- handling to handle usual exceptions. +instance (MonadBaseControl IO (ShellT m),Applicative m,MonadThrow m) => Alternative (ConduitM i o (ShellT m)) where + empty = monadThrow ShellEmpty + x <|> y = + do r <- tryC x + case r of + Left (_ :: ShellException) -> y + Right rr -> return rr + +-- | An exception resulting from a shell command. +data ShellException + = ShellEmpty -- ^ For 'mempty'. + | ShellExitFailure !Int -- ^ Process exited with failure. + deriving (Typeable,Show) +instance Exception ShellException diff --git a/src/Data/Conduit/Shell/Variadic.hs b/src/Data/Conduit/Shell/Variadic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Shell/Variadic.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Variadic process calling. + +module Data.Conduit.Shell.Variadic + (ProcessType(..) + ,variadicProcess + ,CmdArg(..)) + where + +import Control.Monad.Trans.Resource +import qualified Data.ByteString as SB +import qualified Data.ByteString.Lazy as LB +import Data.Conduit +import Data.Conduit.Shell.Process +import Data.Conduit.Shell.Types +import qualified Data.Text as ST +import qualified Data.Text.Encoding as ST +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT + +-- | A variadic process maker. +variadicProcess :: (ProcessType r) + => String -> r +variadicProcess name = spr name [] + +-- | Make the final conduit. +makeProcessLauncher :: (MonadResource m) + => String -> [ST.Text] -> Conduit Chunk m Chunk +makeProcessLauncher name args = proc name (map ST.unpack args) + +-- | Process return type. +class ProcessType t where + spr :: String -> [ST.Text] -> t + +-- | The real type should be: +-- +-- @ConduitM Chunk Chunk m ()@ +-- +-- But with this more liberal instance head we catch all cases in the +-- instance resolver, and then apply the equality restrictions later. +-- +instance (MonadResource m, c ~ Chunk, c' ~ Chunk, r ~ ()) => ProcessType (ConduitM c c' m r) where + spr name args = makeProcessLauncher name (reverse args) + +-- | Accept strings as arguments. +instance (ProcessType r,CmdArg a) => ProcessType (a -> r) where + spr name args = \a -> spr name (toTextArg a : args) + +-- | Command line argument. +class CmdArg a where + toTextArg :: a -> ST.Text + +instance CmdArg ST.Text where + toTextArg = id + +instance CmdArg LT.Text where + toTextArg = LT.toStrict + +instance CmdArg SB.ByteString where + toTextArg = ST.decodeUtf8 + +instance CmdArg LB.ByteString where + toTextArg = LT.toStrict . LT.decodeUtf8 + +instance CmdArg String where + toTextArg = ST.pack