diff --git a/HSH.cabal b/HSH.cabal --- a/HSH.cabal +++ b/HSH.cabal @@ -1,10 +1,11 @@ Name: HSH -Version: 1.2.6 +Version: 2.0.0 License: LGPL Maintainer: John Goerzen Author: John Goerzen Stability: Beta -Copyright: Copyright (c) 2006-2008 John Goerzen +Copyright: Copyright (c) 2006-2009 John Goerzen +Category: system license-file: COPYRIGHT extra-source-files: COPYING homepage: http://software.complete.org/hsh @@ -13,18 +14,39 @@ Haskell programs. With HSH, it is possible to easily run shell commands, capture their output or provide their input, and pipe them to and from other shell commands and arbitrary Haskell functions at will. -Exposed-Modules: HSH, HSH.Command, HSH.ShellEquivs -Extensions: ExistentialQuantification, OverlappingInstances, - UndecidableInstances, FlexibleContexts -Build-Depends: base, unix, mtl, regex-compat, MissingH>=1.0.0, - hslogger, filepath, regex-base, regex-posix, directory, bytestring -GHC-Options: -O2 -threaded -Wall -Category: System + Category: System + +Cabal-Version: >=1.2.3 Build-type: Simple -Executable: runtests -Buildable: False -Main-Is: runtests.hs -HS-Source-Dirs: testsrc -Extensions: ExistentialQuantification, OverlappingInstances, - UndecidableInstances, FlexibleContexts +flag buildtests + description: Build the executable to run unit tests + default: False + +library + Exposed-Modules: HSH, HSH.Command, HSH.ShellEquivs, HSH.Channel + Extensions: ExistentialQuantification, OverlappingInstances, + UndecidableInstances, FlexibleContexts, CPP + Build-Depends: base >= 4 && < 5, utf8-string, process, mtl, regex-compat, MissingH>=1.0.0, + hslogger, filepath, regex-base, regex-posix, directory, + bytestring + if !os(windows) + Build-Depends: unix + GHC-Options: -O2 -threaded -Wall + +Executable runtests + if flag(buildtests) + Buildable: True + Build-Depends: base >= 4 && < 5, utf8-string, process, mtl, regex-compat, + MissingH>=1.0.0, + hslogger, filepath, regex-base, regex-posix, directory, + bytestring, HUnit, testpack + if !os(windows) + Build-Depends: unix + else + Buildable: False + Main-Is: runtests.hs + HS-Source-Dirs: testsrc, . + Extensions: ExistentialQuantification, OverlappingInstances, + UndecidableInstances, FlexibleContexts, CPP + GHC-Options: -O2 -threaded diff --git a/HSH.hs b/HSH.hs --- a/HSH.hs +++ b/HSH.hs @@ -85,9 +85,8 @@ * A Haskell function. This function will accept input representing its standard input and generate output to go to stdout. Function types that are supported natively include @(String -> String)@, - @(String -> IO String)@, @([String] -> [String])@, - @([String] -> IO [String])@. Those that accept a @[String]@ type will - have each string in the list representing a single line. + @(String -> IO String)@, plus many more involving ByteStrings and functions + that take no input. See 'HSH.Command.ShellCommand' for more. Pipes can be constructed by using the -|- operator, as illustrated above. It is quite possible to pipe data between Haskell functions and diff --git a/HSH/Channel.hs b/HSH/Channel.hs new file mode 100644 --- /dev/null +++ b/HSH/Channel.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -XFlexibleInstances -XTypeSynonymInstances #-} + +{- Channel basics for HSH +Copyright (C) 2004-2008 John Goerzen +Please see the COPYRIGHT file +-} + +{- | + Module : HSH.Channel + Copyright : Copyright (C) 2006-2009 John Goerzen + License : GNU LGPL, version 2.1 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Copyright (c) 2006-2009 John Goerzen, jgoerzen\@complete.org +-} + +module HSH.Channel (Channel(..), + chanAsString, + chanAsBSL, + chanAsBS, + chanToHandle, + Channelizable(..) + ) where + +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.UTF8 as UTF8 +import System.IO +import Control.Concurrent + +{- | The main type for communicating between commands. All are expected to +be lazy. -} +data Channel = ChanString String + | ChanBSL BSL.ByteString + | ChanHandle Handle + +chanAsString :: Channel -> IO String +chanAsString (ChanString s) = return s +chanAsString (ChanBSL s) = return . bsl2str $ s +chanAsString (ChanHandle h) = hGetContents h + +chanAsBSL :: Channel -> IO BSL.ByteString +chanAsBSL (ChanString s) = return . str2bsl $ s +chanAsBSL (ChanBSL s) = return s +chanAsBSL (ChanHandle h) = BSL.hGetContents h + +chanAsBS :: Channel -> IO BS.ByteString +chanAsBS c = do r <- chanAsBSL c + let contents = BSL.toChunks r + return . BS.concat $ contents + +{- | Writes the Channel to the given Handle. -} +chanToHandle :: Channel -> Handle -> IO () +chanToHandle (ChanString s) h = hPutStr h s +chanToHandle (ChanBSL s) h = BSL.hPut h s +chanToHandle (ChanHandle srchdl) desthdl = forkIO copier >> return () + where copier = do c <- BSL.hGetContents srchdl + BSL.hPut desthdl c + +class Channelizable a where + toChannel :: a -> Channel +instance Channelizable String where + toChannel = ChanString +instance Channelizable BSL.ByteString where + toChannel = ChanBSL +instance Channelizable Handle where + toChannel = ChanHandle +instance Channelizable BS.ByteString where + toChannel bs = ChanBSL . BSL.fromChunks $ [bs] + + + +str2bsl :: String -> BSL.ByteString +str2bsl = UTF8.fromString + +bsl2str :: BSL.ByteString -> String +bsl2str = UTF8.toString + diff --git a/HSH/Command.hs b/HSH/Command.hs --- a/HSH/Command.hs +++ b/HSH/Command.hs @@ -7,17 +7,18 @@ {- | Module : HSH.Command - Copyright : Copyright (C) 2006-2008 John Goerzen + Copyright : Copyright (C) 2006-2009 John Goerzen License : GNU LGPL, version 2.1 or above Maintainer : John Goerzen Stability : provisional Portability: portable -Copyright (c) 2006-2007 John Goerzen, jgoerzen\@complete.org +Copyright (c) 2006-2009 John Goerzen, jgoerzen\@complete.org -} -module HSH.Command (ShellCommand(..), +module HSH.Command (Environment, + ShellCommand(..), PipeCommand(..), (-|-), RunResult, @@ -25,75 +26,140 @@ runIO, runSL, InvokeResult, + checkResults, tryEC, catchEC, + setenv, + unsetenv ) where -- import System.IO.HVIO -- import System.IO.Utils +import Prelude hiding (catch) import System.IO import System.Exit -import System.Posix.Types -import System.Posix.IO -import System.Posix.Process import System.Log.Logger -import System.IO.Error +import System.IO.Error hiding (catch) import Data.Maybe.Utils import Data.Maybe import Data.List.Utils(uniq) -import Control.Exception(evaluate) -import System.Posix.Env +import Control.Exception(evaluate, SomeException, catch) import Text.Regex.Posix import Control.Monad(when) import Data.String.Utils(rstrip) +import Control.Concurrent +import System.Process +import System.Environment(getEnvironment) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.UTF8 as UTF8 +import HSH.Channel d, dr :: String -> IO () d = debugM "HSH.Command" dr = debugM "HSH.Command.Run" +em = errorM "HSH.Command" {- | Result type for shell commands. The String is the text description of the command, not its output. -} -type InvokeResult = (String, IO ProcessStatus) +type InvokeResult = (String, IO ExitCode) +{- | Type for the environment. -} +type Environment = Maybe [(String, String)] + {- | A shell command is something we can invoke, pipe to, pipe from, or pipe in both directions. All commands that can be run as shell commands must define these methods. Minimum implementation is 'fdInvoke'. + +Some pre-defined instances include: + + * A simple bare string, which is passed to the shell for execution. The shell + will then typically expand wildcards, parse parameters, etc. + + * A @(String, [String])@ tuple. The first item in the tuple gives + the name of a program to run, and the second gives its arguments. + The shell is never involved. This is ideal for passing filenames, + since there is no security risk involving special shell characters. + + * A @Handle -> Handle -> IO ()@ function, which reads from the first + handle and write to the second. + + * Various functions. These functions will accept input representing + its standard input and output will go to standard output. + +Some pre-defined instance functions include: + + * @(String -> String)@, @(String -> IO String)@, plus the same definitions + for ByteStrings. + + * @([String] -> [String])@, @([String] -> IO [String])@, where each @String@ + in the list represents a single line + + * @(() -> String)@, @(() -> IO String)@, for commands that explicitly + read no input. Useful with closures. Useful when you want to avoid + reading stdin because something else already is. These have the unit as + part of the function because otherwise we would have conflicts with things + such as bare Strings, which represent a command name. + -} class (Show a) => ShellCommand a where {- | Invoke a command. -} fdInvoke :: a -- ^ The command - -> Fd -- ^ fd to pass to it as stdin - -> Fd -- ^ fd to pass to it as stdout - -> [Fd] -- ^ Fds to close in the child. Will not harm Fds this child needs for stdin and stdout. - -> (IO ()) -- ^ Action to run post-fork in child (or in main process if it doesn't fork) - -> IO [InvokeResult] -- ^ Returns an action that, when evaluated, waits for the process to finish and returns an exit code. + -> Environment -- ^ The environment + -> Channel -- ^ Where to read input from + -> IO (Channel, [InvokeResult]) -- ^ Returns an action that, when evaluated, waits for the process to finish and returns an exit code. +instance Show (Handle -> Handle -> IO ()) where + show _ = "(Handle -> Handle -> IO ())" +instance Show (Channel -> IO Channel) where + show _ = "(Channel -> IO Channel)" instance Show (String -> String) where show _ = "(String -> String)" +instance Show (() -> String) where + show _ = "(() -> String)" instance Show (String -> IO String) where show _ = "(String -> IO String)" +instance Show (() -> IO String) where + show _ = "(() -> IO String)" instance Show (BSL.ByteString -> BSL.ByteString) where show _ = "(Data.ByteString.Lazy.ByteString -> Data.ByteString.Lazy.ByteString)" +instance Show (() -> BSL.ByteString) where + show _ = "(() -> Data.ByteString.Lazy.ByteString)" instance Show (BSL.ByteString -> IO BSL.ByteString) where show _ = "(Data.ByteString.Lazy.ByteString -> IO Data.ByteString.Lazy.ByteString)" +instance Show (() -> IO BSL.ByteString) where + show _ = "(() -> IO BSL.ByteString)" instance Show (BS.ByteString -> BS.ByteString) where show _ = "(Data.ByteString.ByteString -> Data.ByteString.ByteString)" +instance Show (() -> BS.ByteString) where + show _ = "(() -> Data.ByteString.ByteString)" instance Show (BS.ByteString -> IO BS.ByteString) where show _ = "(Data.ByteString.ByteString -> IO Data.ByteString.ByteString)" +instance Show (() -> IO BS.ByteString) where + show _ = "(() -> IO Data.ByteString.ByteString)" instance ShellCommand (String -> IO String) where - fdInvoke = genericStringlikeIO hGetContents hPutStr + fdInvoke = genericStringlikeIO chanAsString +{- | A user function that takes no input, and generates output. We will deal +with it using hPutStr to send the output on. -} +instance ShellCommand (() -> IO String) where + fdInvoke = genericStringlikeO + instance ShellCommand (BSL.ByteString -> IO BSL.ByteString) where - fdInvoke = genericStringlikeIO BSL.hGetContents BSL.hPut + fdInvoke = genericStringlikeIO chanAsBSL +instance ShellCommand (() -> IO BSL.ByteString) where + fdInvoke = genericStringlikeO + instance ShellCommand (BS.ByteString -> IO BS.ByteString) where - fdInvoke = genericStringlikeIO BS.hGetContents BS.hPut + fdInvoke = genericStringlikeIO chanAsBS +instance ShellCommand (() -> IO BS.ByteString) where + fdInvoke = genericStringlikeO + {- | An instance of 'ShellCommand' for a pure Haskell function mapping String to String. Implement in terms of (String -> IO String) for simplicity. -} @@ -103,63 +169,77 @@ where iofunc :: String -> IO String iofunc = return . func +instance ShellCommand (() -> String) where + fdInvoke func = + fdInvoke iofunc + where iofunc :: () -> IO String + iofunc = return . func + instance ShellCommand (BSL.ByteString -> BSL.ByteString) where fdInvoke func = fdInvoke iofunc where iofunc :: BSL.ByteString -> IO BSL.ByteString iofunc = return . func +instance ShellCommand (() -> BSL.ByteString) where + fdInvoke func = + fdInvoke iofunc + where iofunc :: () -> IO BSL.ByteString + iofunc = return . func + instance ShellCommand (BS.ByteString -> BS.ByteString) where fdInvoke func = fdInvoke iofunc where iofunc :: BS.ByteString -> IO BS.ByteString iofunc = return . func -genericStringlikeIO :: (Show (a -> IO a)) => - (Handle -> IO a) - -> (Handle -> a -> IO ()) - -> (a -> IO a) - -> Fd - -> Fd - -> [Fd] - -> (IO ()) - -> IO [InvokeResult] -genericStringlikeIO getcontentsfunc hputstrfunc func fstdin fstdout childclosefds childfunc = - do -- d $ "SIOSF: Before fork" - p <- try (forkProcess childstuff) - pid <- case p of - Right x -> return x - Left x -> fail $ "Error in fork for func: " ++ show x - -- d $ "SIOSFP: New func pid " ++ show pid - return $ seq pid pid - return [(show func, - getProcessStatus True False pid >>= - (return . forceMaybe))] - where childstuff = do closefds childclosefds [fstdin, fstdout] - d $ "SIOSFC Input is on " ++ show fstdin - hr <- fdToHandle fstdin - d $ "SIOSFC Output is on " ++ show fstdout - hw <- fdToHandle fstdout - hSetBuffering hw LineBuffering - d $ "SIOSFC Running child func" - childfunc - d $ "SIOSFC Running func in child" - contents <- getcontentsfunc hr - d $ "SIOSFC Contents read" - result <- func contents - d $ "SIOSFC Func applied" - hputstrfunc hw result - d $ "SIOSFC Func done, closing handles." - hClose hr - hClose hw - d $ "SIOSFC Child exiting." - -- It hung here without the exitImmediately - --exitImmediately ExitSuccess +instance ShellCommand (() -> BS.ByteString) where + fdInvoke func = + fdInvoke iofunc + where iofunc :: () -> IO BS.ByteString + iofunc = return . func +instance ShellCommand (Channel -> IO Channel) where + fdInvoke func _ cstdin = + runInHandler (show func) (func cstdin) + +{- +instance ShellCommand (Handle -> Handle -> IO ()) where + fdInvoke func cstdin cstdout = + runInHandler (show func) (func hstdin hstdout) +-} + +genericStringlikeIO :: (Show (a -> IO a), Channelizable a) => + (Channel -> IO a) + -> (a -> IO a) + -> Environment + -> Channel + -> IO (Channel, [InvokeResult]) +genericStringlikeIO dechanfunc userfunc _ cstdin = + do contents <- dechanfunc cstdin + runInHandler (show userfunc) (realfunc contents) + where realfunc contents = do r <- userfunc contents + return (toChannel r) + +genericStringlikeO :: (Show (() -> IO a), Channelizable a) => + (() -> IO a) + -> Environment + -> Channel + -> IO (Channel, [InvokeResult]) +genericStringlikeO userfunc _ _ = + runInHandler (show userfunc) realfunc + where realfunc :: IO Channel + realfunc = do r <- userfunc () + return (toChannel r) + instance Show ([String] -> [String]) where show _ = "([String] -> [String])" +instance Show (() -> [String]) where + show _ = "(() -> [String])" instance Show ([String] -> IO [String]) where show _ = "([String] -> IO [String])" +instance Show (() -> IO [String]) where + show _ = "(() -> IO [String])" {- | An instance of 'ShellCommand' for a pure Haskell function mapping [String] to [String]. @@ -172,94 +252,87 @@ instance ShellCommand ([String] -> [String]) where fdInvoke func = fdInvoke (unlines . func . lines) +instance ShellCommand (() -> [String]) where + fdInvoke func = fdInvoke (unlines . func) + {- | The same for an IO function -} instance ShellCommand ([String] -> IO [String]) where fdInvoke func = fdInvoke iofunc where iofunc input = do r <- func (lines input) return (unlines r) +instance ShellCommand (() -> IO [String]) where + fdInvoke func = fdInvoke iofunc + where iofunc :: (() -> IO String) + iofunc () = do r <- func () + return (unlines r) + {- | An instance of 'ShellCommand' for an external command. The first String is the command to run, and the list of Strings represents the arguments to the program, if any. -} instance ShellCommand (String, [String]) where - fdInvoke pc@(cmd, args) fstdin fstdout childclosefds childfunc = - do d $ "S Before fork for " ++ show pc - p <- try (forkProcess childstuff) - pid <- case p of - Right x -> return x - Left x -> fail $ "Error in fork: " ++ show x - d $ "SP New pid " ++ show pid ++ " for " ++ show pc - return $ seq pid pid - return [(show (cmd, args), - getProcessStatus True False pid >>= - (return . forceMaybe))] - - where - childstuff = do d $ "SC preparing to redir" - d $ "SC input is on " ++ show fstdin - d $ "SC output is on " ++ show fstdout - redir fstdin stdInput - redir fstdout stdOutput - closefds childclosefds [fstdin, fstdout, 0, 1] - childfunc - dr ("RUN: " ++ cmd ++ " " ++ (show args)) - executeFile cmd True args Nothing + fdInvoke (fp, args) = genericCommand (RawCommand fp args) {- | An instance of 'ShellCommand' for an external command. The String is split using words to the command to run, and the arguments, if any. -} instance ShellCommand String where - fdInvoke cmdline ifd ofd closefd forkfunc = - do esh <- getEnv "SHELL" - let sh = case esh of - Nothing -> "/bin/sh" - Just x -> x - fdInvoke (sh, ["-c", cmdline]) ifd ofd closefd forkfunc + fdInvoke cmd = genericCommand (ShellCommand cmd) -redir :: Fd -> Fd -> IO () -redir fromfd tofd - | fromfd == tofd = do d $ "ignoring identical redir " ++ show fromfd - return () - | otherwise = do d $ "running dupTo " ++ show (fromfd, tofd) - dupTo fromfd tofd - closeFd fromfd +{- | How to we handle and external command. -} +genericCommand :: CmdSpec + -> Environment + -> Channel + -> IO (Channel, [InvokeResult]) -closefds :: [Fd] -- ^ List of Fds to possibly close - -> [Fd] -- ^ List of Fds to not touch, ever - -> IO () -closefds inpclosefds noclosefds = - do d $ "closefds " ++ show uclosefds ++ " " ++ show noclosefds - mapM_ closeit . filter (\x -> not (x `elem` noclosefds)) $ uclosefds - where closeit fd = do d $ "Closing fd " ++ show fd - closeFd fd - uclosefds = uniq inpclosefds +-- Handling external command when stdin channel is a Handle +genericCommand c environ (ChanHandle ih) = + let cp = CreateProcess {cmdspec = c, + cwd = Nothing, + env = environ, + std_in = UseHandle ih, + std_out = CreatePipe, + std_err = Inherit, + close_fds = True} + in do (_, oh', _, ph) <- createProcess cp + let oh = fromJust oh' + return (ChanHandle oh, [(printCmdSpec c, waitForProcess ph)]) +genericCommand cspec environ ichan = + let cp = CreateProcess {cmdspec = cspec, + cwd = Nothing, + env = environ, + std_in = CreatePipe, + std_out = CreatePipe, + std_err = Inherit, + close_fds = True} + in do (ih', oh', _, ph) <- createProcess cp + let ih = fromJust ih' + let oh = fromJust oh' + chanToHandle ichan ih + return (ChanHandle oh, [(printCmdSpec cspec, waitForProcess ph)]) +printCmdSpec :: CmdSpec -> String +printCmdSpec (ShellCommand s) = s +printCmdSpec (RawCommand fp args) = show (fp, args) + +------------------------------------------------------------ +-- Pipes +------------------------------------------------------------ + data (ShellCommand a, ShellCommand b) => PipeCommand a b = PipeCommand a b deriving Show {- | An instance of 'ShellCommand' represeting a pipeline. -} instance (ShellCommand a, ShellCommand b) => ShellCommand (PipeCommand a b) where - fdInvoke pc@(PipeCommand cmd1 cmd2) fstdin fstdout childclosefds forkfunc = - do d $ "*** Handling pipe: " ++ show pc - (reader, writer) <- createPipe - let allfdstoclose = reader : writer : fstdin : fstdout : childclosefds - d $ "pipd fdInvoke: New pipe endpoints: " ++ show (reader, writer) - res1 <- fdInvoke cmd1 fstdin writer allfdstoclose forkfunc - res2 <- fdInvoke cmd2 reader fstdout allfdstoclose forkfunc - d $ "pipe fdInvoke: Parent closing " ++ show [reader, writer] - mapM_ closeFd [reader, writer] - - d $ "*** Done handling pipe " ++ show pc - return $ res1 ++ res2 + fdInvoke (PipeCommand cmd1 cmd2) env ichan = + do (chan1, res1) <- fdInvoke cmd1 env ichan + (chan2, res2) <- fdInvoke cmd2 env chan1 + return (chan2, res1 ++ res2) {- | Pipe the output of the first command into the input of the second. -} (-|-) :: (ShellCommand a, ShellCommand b) => a -> b -> PipeCommand a b (-|-) = PipeCommand -{- | Function to use when there is nothing for the child to do -} -nullChildFunc :: IO () -nullChildFunc = return () - {- | Different ways to get data from 'run'. * IO () runs, throws an exception on error, and sends stdout to stdout @@ -270,16 +343,23 @@ * IO [String] is same as IO String, but returns the results as lines. Note: this output is not lazy. - * IO ProcessStatus runs and returns a ProcessStatus with the exit + * IO ExitCode runs and returns an ExitCode with the exit information. stdout is sent to stdout. Exceptions are not thrown. - * IO (String, ProcessStatus) is like IO ProcessStatus, but also + * IO (String, ExitCode) is like IO ExitCode, but also includes a description of the last command in the pipe to have - an error (or the last command, if there was no error) + an error (or the last command, if there was no error). - * IO ByteString and IO (ByteString, ProcessStatus) are similar to their - String counterparts. + * IO ByteString and are similar to their String counterparts. + * IO (String, IO (String, ExitCode)) returns a String read lazily + and an IO action that, when evaluated, finishes up the process and + results in its exit status. This command returns immediately. + + * IO (IO (String, ExitCode)) sends stdout to stdout but returns + immediately. It forks off the child but does not wait for it to finish. + You can use 'checkResults' to wait for the finish. + * IO Int returns the exit code from a program directly. If a signal caused the command to be reaped, returns 128 + SIGNUM. @@ -297,21 +377,20 @@ instance RunResult (IO ()) where run cmd = run cmd >>= checkResults -instance RunResult (IO (String, ProcessStatus)) where +instance RunResult (IO (String, ExitCode)) where run cmd = - do r <- fdInvoke cmd stdInput stdOutput [] nullChildFunc + do (ochan, r) <- fdInvoke cmd Nothing (ChanHandle stdin) + chanToHandle ochan stdout processResults r -instance RunResult (IO ProcessStatus) where - run cmd = ((run cmd)::IO (String, ProcessStatus)) >>= return . snd +instance RunResult (IO ExitCode) where + run cmd = ((run cmd)::IO (String, ExitCode)) >>= return . snd instance RunResult (IO Int) where run cmd = do rc <- run cmd case rc of - Exited (ExitSuccess) -> return 0 - Exited (ExitFailure x) -> return x - Terminated x -> return (128 + (fromIntegral x)) - Stopped x -> return (128 + (fromIntegral x)) + ExitSuccess -> return 0 + ExitFailure x -> return x instance RunResult (IO Bool) where run cmd = do rc <- run cmd @@ -322,73 +401,87 @@ return (lines r) instance RunResult (IO String) where - run cmd = genericStringlikeResult hGetContents (\c -> evaluate (length c)) + run cmd = genericStringlikeResult chanAsString (\c -> evaluate (length c)) cmd instance RunResult (IO BSL.ByteString) where - run cmd = genericStringlikeResult BSL.hGetContents + run cmd = genericStringlikeResult chanAsBSL (\c -> evaluate (BSL.length c)) cmd instance RunResult (IO BS.ByteString) where - run cmd = genericStringlikeResult BS.hGetContents + run cmd = genericStringlikeResult chanAsBS (\c -> evaluate (BS.length c)) cmd +instance RunResult (IO (String, IO (String, ExitCode))) where + run cmd = intermediateStringlikeResult chanAsString cmd + +instance RunResult (IO (BSL.ByteString, IO (String, ExitCode))) where + run cmd = intermediateStringlikeResult chanAsBSL cmd + +instance RunResult (IO (BS.ByteString, IO (String, ExitCode))) where + run cmd = intermediateStringlikeResult chanAsBS cmd + +instance RunResult (IO (IO (String, ExitCode))) where + run cmd = do (ochan, r) <- fdInvoke cmd Nothing (ChanHandle stdin) + chanToHandle ochan stdout + return (processResults r) + +intermediateStringlikeResult :: ShellCommand b => + (Channel -> IO a) + -> b + -> IO (a, IO (String, ExitCode)) +intermediateStringlikeResult chanfunc cmd = + do (ochan, r) <- fdInvoke cmd Nothing (ChanHandle stdin) + c <- chanfunc ochan + return (c, processResults r) + genericStringlikeResult :: ShellCommand b => - (Handle -> IO a) + (Channel -> IO a) -> (a -> IO c) -> b -> IO a -genericStringlikeResult hgetcontentsfunc evalfunc cmd = - do (pread, pwrite) <- createPipe - -- d $ "runS: new pipe endpoints: " ++ show [pread, pwrite] - -- d "runS 1" - r <- fdInvoke cmd stdInput pwrite [pread, pwrite] nullChildFunc - -- d $ "runS 2 closing " ++ show pwrite - closeFd pwrite - -- d "runS 3" - hread <- fdToHandle pread - -- d "runS 4" - c <- hgetcontentsfunc hread - -- d "runS 5" +genericStringlikeResult chanfunc evalfunc cmd = + do (c, r) <- intermediateStringlikeResult chanfunc cmd evalfunc c --evaluate (length c) -- d "runS 6" - hClose hread -- d "runS 7" - processResults r >>= checkResults + r >>= checkResults -- d "runS 8" return c {- | Evaluates the result codes and returns an overall status -} -processResults :: [InvokeResult] -> IO (String, ProcessStatus) +processResults :: [InvokeResult] -> IO (String, ExitCode) processResults r = do rc <- mapM procresult r case catMaybes rc of - [] -> return (fst (last r), Exited (ExitSuccess)) + [] -> return (fst (last r), ExitSuccess) x -> return (last x) - where procresult :: InvokeResult -> IO (Maybe (String, ProcessStatus)) + where procresult :: InvokeResult -> IO (Maybe (String, ExitCode)) procresult (cmd, action) = do rc <- action return $ case rc of - Exited (ExitSuccess) -> Nothing + ExitSuccess -> Nothing x -> Just (cmd, x) {- | Evaluates result codes and raises an error for any bad ones it finds. -} -checkResults :: (String, ProcessStatus) -> IO () +checkResults :: (String, ExitCode) -> IO () checkResults (cmd, ps) = case ps of - Exited (ExitSuccess) -> return () - Exited (ExitFailure x) -> + ExitSuccess -> return () + ExitFailure x -> fail $ cmd ++ ": exited with code " ++ show x +{- FIXME: generate these again Terminated sig -> fail $ cmd ++ ": terminated by signal " ++ show sig Stopped sig -> fail $ cmd ++ ": stopped by signal " ++ show sig +-} {- | Handle an exception derived from a program exiting abnormally -} -tryEC :: IO a -> IO (Either ProcessStatus a) +tryEC :: IO a -> IO (Either ExitCode a) tryEC action = do r <- try action case r of @@ -396,21 +489,21 @@ if isUserError ioe then case (ioeGetErrorString ioe =~~ pat) of Nothing -> ioError ioe -- not ours; re-raise it - Just e -> return . Left . proc $ e + Just e -> return . Left . procit $ e else ioError ioe -- not ours; re-raise it Right result -> return (Right result) where pat = ": exited with code [0-9]+$|: terminated by signal ([0-9]+)$|: stopped by signal [0-9]+" - proc :: String -> ProcessStatus - proc e - | e =~ "^: exited" = Exited (ExitFailure (str2ec e)) - | e =~ "^: terminated by signal" = Terminated (str2ec e) - | e =~ "^: stopped by signal" = Stopped (str2ec e) + procit :: String -> ExitCode + procit e + | e =~ "^: exited" = ExitFailure (str2ec e) +-- | e =~ "^: terminated by signal" = Terminated (str2ec e) +-- | e =~ "^: stopped by signal" = Stopped (str2ec e) | otherwise = error "Internal error in tryEC" str2ec e = read (e =~ "[0-9]+$") {- | Catch an exception derived from a program exiting abnormally -} -catchEC :: IO a -> (ProcessStatus -> IO a) -> IO a +catchEC :: IO a -> (ExitCode -> IO a) -> IO a catchEC action handler = do r <- tryEC action case r of @@ -442,3 +535,104 @@ do r <- run cmd when (r == []) $ fail $ "runSL: no output received from " ++ show cmd return (rstrip . head $ r) + + +{- | Convenience function to wrap a child thread. Kicks off the thread, handles +running the code, traps execptions, the works. + +Note that if func is lazy, such as a getContents sort of thing, +the exception may go uncaught here. + +NOTE: expects func to be lazy! + -} +runInHandler :: String -- ^ Description of this function + -> (IO Channel) -- ^ The action to run in the thread + -> IO (Channel, [InvokeResult]) +runInHandler descrip func = + catch (realfunc) (exchandler) + where realfunc = do r <- func + return (r, [(descrip, return ExitSuccess)]) + exchandler :: SomeException -> IO (Channel, [InvokeResult]) + exchandler e = do em $ "runInHandler/" ++ descrip ++ ": " ++ show e + return (ChanString "", [(descrip, return (ExitFailure 1))]) + + +------------------------------------------------------------ +-- Environment +------------------------------------------------------------ +{- | An environment variable filter function. + +This is a low-level interface; see 'setenv' and 'unsetenv' for more convenient +interfaces. -} +type EnvironFilter = [(String, String)] -> [(String, String)] + +instance Show EnvironFilter where + show _ = "EnvironFilter" + + +{- | A command that carries environment variable information with it. + +This is a low-level interface; see 'setenv' and 'unsetenv' for more +convenient interfaces. -} +data (ShellCommand a) => EnvironCommand a = EnvironCommand EnvironFilter a + deriving Show + +instance (ShellCommand a) => ShellCommand (EnvironCommand a) where + fdInvoke (EnvironCommand efilter cmd) Nothing ichan = + do -- No incoming environment; initialize from system default. + e <- getEnvironment + fdInvoke cmd (Just (efilter e)) ichan + fdInvoke (EnvironCommand efilter cmd) (Just ienv) ichan = + fdInvoke cmd (Just (efilter ienv)) ichan + +{- | Sets an environment variable, replacing an existing one if it exists. + +Here's a sample ghci session to illustrate. First, let's see the defaults for +some variables: + +> Prelude HSH> runIO $ "echo $TERM, $LANG" +> xterm, en_US.UTF-8 + +Now, let's set one: + +> Prelude HSH> runIO $ setenv [("TERM", "foo")] $ "echo $TERM, $LANG" +> foo, en_US.UTF-8 + +Or two: + +> Prelude HSH> runIO $ setenv [("TERM", "foo")] $ setenv [("LANG", "de_DE.UTF-8")] $ "echo $TERM, $LANG" +> foo, de_DE.UTF-8 + +We could also do it easier, like this: + +> Prelude HSH> runIO $ setenv [("TERM", "foo"), ("LANG", "de_DE.UTF-8")] $ "echo $TERM, $LANG" +> foo, de_DE.UTF-8 + +It can be combined with unsetenv: + +> Prelude HSH> runIO $ setenv [("TERM", "foo")] $ unsetenv ["LANG"] $ "echo $TERM, $LANG" +> foo, + +And used with pipes: + +> Prelude HSH> runIO $ setenv [("TERM", "foo")] $ "echo $TERM, $LANG" -|- "tr a-z A-Z" +> FOO, EN_US.UTF-8 + +See also 'unsetenv'. +-} +setenv :: (ShellCommand cmd) => [(String, String)] -> cmd -> EnvironCommand cmd +setenv items cmd = + EnvironCommand efilter cmd + where efilter ienv = foldr efilter' ienv items + efilter' (key, val) ienv = + (key, val) : (filter (\(k, _) -> k /= key) ienv) + +{- | Removes an environment variable if it exists; does nothing otherwise. + +See also 'setenv', which has a more extensive example. +-} +unsetenv :: (ShellCommand cmd) => [String] -> cmd -> EnvironCommand cmd +unsetenv keys cmd = + EnvironCommand efilter cmd + where efilter ienv = foldr efilter' ienv keys + efilter' key = filter (\(k, _) -> k /= key) diff --git a/HSH/ShellEquivs.hs b/HSH/ShellEquivs.hs --- a/HSH/ShellEquivs.hs +++ b/HSH/ShellEquivs.hs @@ -1,18 +1,18 @@ {- Shell Equivalents -Copyright (C) 2004-2008 John Goerzen +Copyright (C) 2004-2009 John Goerzen Please see the COPYRIGHT file -} {- | Module : HSH.ShellEquivs - Copyright : Copyright (C) 2008 John Goerzen + Copyright : Copyright (C) 2009 John Goerzen License : GNU LGPL, version 2.1 or above Maintainer : John Goerzen Stability : provisional Portability: portable -Copyright (c) 2006-2008 John Goerzen, jgoerzen\@complete.org +Copyright (c) 2006-2009 John Goerzen, jgoerzen\@complete.org This module provides shell-like commands. Most, but not all, are designed to be used directly as part of a HSH pipeline. All may be used outside @@ -20,21 +20,30 @@ -} +#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) +#define __HSH_POSIX__ +#else +#define __HSH_WINDOWS__ +#endif + module HSH.ShellEquivs( abspath, appendTo, basename, bracketCD, catFrom, - catFromBS, + catBytes, + catBytesFrom, catTo, - catToBS, +#ifdef __HSH_POSIX__ + catToFIFO, +#endif cd, cut, cutR, dirname, + discard, echo, - echoBS, exit, glob, grep, @@ -47,19 +56,25 @@ mkdir, numberLines, pwd, +#ifdef __HSH_POSIX__ readlink, readlinkabs, +#endif rev, revW, + HSH.Command.setenv, space, unspace, tac, tee, - teeBS, +#ifdef __HSH_POSIX__ + teeFIFO, +#endif tr, trd, wcW, wcL, + HSH.Command.unsetenv, uniq, ) where @@ -70,14 +85,27 @@ import Control.Monad (foldM) import System.Directory hiding (createDirectory) -- import System.FilePath (splitPath) + +#ifdef __HSH_POSIX__ import System.Posix.Files (getFileStatus, isSymbolicLink, readSymbolicLink) import System.Posix.User (getEffectiveUserName, getUserEntryForName, homeDirectory) import System.Posix.Directory (createDirectory) import System.Posix.Types (FileMode()) +import System.Posix.IO +import System.Posix.Error +#endif + import System.Path (absNormPath, bracketCWD) import System.Exit +import System.IO +import System.Process +import qualified System.Directory as SD import qualified System.Path.Glob as Glob (glob) import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString as BS +import System.IO.Unsafe(unsafeInterleaveIO) +import HSH.Channel +import HSH.Command(setenv, unsetenv) {- | Return the absolute path of the arg. Raises an error if the computation is impossible. -} @@ -108,46 +136,111 @@ {- | Load the specified files and display them, one at a time. The special file @-@ means to display the input. If it is not given, -no input is read. +no input is processed (though a small amount may be read into a buffer). Unlike the shell cat, @-@ may be given twice. However, if it is, you will be forcing Haskell to buffer the input. Note: buffering behavior here is untested. -See also 'catFromBS'. -} -catFrom :: [FilePath] -> String -> IO String -catFrom = genericCatFrom readFile (++) "" - -{- | Lazy ByteString version of 'catFrom'. This may have performance -benefits. -} -catFromBS :: [FilePath] -> BSL.ByteString -> IO BSL.ByteString -catFromBS = genericCatFrom BSL.readFile BSL.append BSL.empty - -genericCatFrom :: (FilePath -> IO a) -> (a -> a -> a) -> a -> [FilePath] -> a -> IO a -genericCatFrom readfilefunc appendfunc empty fplist inp = - do r <- foldM foldfunc empty fplist - return r +See also 'catFromBS', 'catBytes' . -} +catFrom :: [FilePath] -> Channel -> IO Channel +catFrom fplist ichan = + do r <- foldM foldfunc BSL.empty fplist + return (toChannel r) where foldfunc accum fp = case fp of - "-" -> return (appendfunc accum inp) - fn -> do c <- readfilefunc fn - return (appendfunc accum c) + "-" -> do c <- chanAsBSL ichan + return (BSL.append accum c) + fn -> do c <- BSL.readFile fn + return (BSL.append accum c) +{- | Copy data in chunks from stdin to stdout, optionally with a fixed +maximum size. Uses strict ByteStrings internally. Uses hSetBuffering +to set the buffering of the input handle to blockbuffering in chunksize +increments as well, but restores original buffering before returning. +See also 'catFrom', 'catBytesFrom' -} +catBytes :: Int -- ^ Preferred chunk size; data will be read in chunks of this size + -> (Maybe Integer) -- ^ Maximum amount of data to transfer + -> Handle -- ^ Handle for input + -> Handle -- ^ Handle for output + -> IO () +catBytes chunksize count hr = catBytesFrom chunksize hr count hr + +{- | Generic version of 'catBytes'; reads data from specified Handle, and +ignores stdin. -} + +catBytesFrom :: Int -- ^ Preferred chunk size; data will be read in chunks of this size + -> Handle -- ^ Handle to read from + -> (Maybe Integer) -- ^ Maximum amount of data to transfer + -> Handle -- ^ Handle for input (ignored) + -> Handle -- ^ Handle for output + -> IO () +catBytesFrom chunksize hr count hignore hw = + do buf <- hGetBuffering hr + catBytesFrom' chunksize hr count hignore hw + hSetBuffering hr buf + +catBytesFrom' _ _ (Just 0) _ _ = return () +catBytesFrom' chunksize hr count hignore hw = + do hSetBuffering hr (BlockBuffering (Just readamount)) + case count of + Just x -> if x < 1 + then do fail $ "catBytesFrom: count < 0 not supported" + else return () + _ -> return () + r <- BS.hGet hr readamount + if BS.null r + then return () -- No more data to read + else do BS.hPutStr hw r + catBytesFrom' chunksize hr (newCount (BS.length r)) hignore hw + where readamount = + case count of + Just x -> fromIntegral $ min x (fromIntegral chunksize) + Nothing -> (fromIntegral chunksize) + newCount newlen = case count of + Nothing -> Nothing + Just x -> Just (x - (fromIntegral newlen)) + {- | Takes input, writes it to the specified file, and does not pass it on. - The return value is the empty string. See also 'catToBS', 'tee'. -} -catTo :: FilePath -> String -> IO String -catTo fp inp = - do writeFile fp inp - return "" + The return value is the empty string. See also 'catToBS', + 'catToFIFO' -} +catTo :: FilePath -> Channel -> IO Channel +catTo fp ichan = + do ofile <- openFile fp WriteMode + chanToHandle ichan ofile + hClose ofile + return (ChanString "") -{- | Like 'catTo', but operates in a lazy ByteString. This could be a -performance benefit. -} -catToBS :: FilePath -> BSL.ByteString -> IO BSL.ByteString -catToBS fp inp = - do BSL.writeFile fp inp - return (BSL.empty) +#ifdef __HSH_POSIX__ +{- | Like 'catTo', but opens the destination in ReadWriteMode instead of +ReadOnlyMode. Due to an oddity of the Haskell IO system, this is required +when writing to a named pipe (FIFO) even if you will never read from it. + +This call will BLOCK all threads on open until a reader connects. + +This is provided in addition to 'catTo' because you may want to cat to +something that you do not have permission to read from. + +This function is only available on POSIX platforms. + +See also 'catTo' -} +catToFIFO :: FilePath -> Channel -> IO Channel +catToFIFO fp ichan = + do h <- fifoOpen fp + chanToHandle ichan h + hClose h + return (ChanString "") + +fifoOpen :: FilePath -> IO Handle +fifoOpen fp = + do fd <- throwErrnoPathIf (< 0) "HSH fifoOpen" fp $ + openFd fp WriteOnly Nothing defaultFileFlags + fdToHandle fd + +#endif + {- | Like 'catTo', but appends to the file. -} appendTo :: FilePath -> String -> IO String appendTo fp inp = @@ -172,6 +265,15 @@ cut :: Integer -> Char -> String -> String cut pos = cutR [pos] +{- | Read all input and produce no output. Discards input completely. -} +discard :: Handle -> Handle -> IO () +discard inh outh = + do eof <- hIsEOF inh + if eof + then return () + else do BS.hGet inh 4096 + discard inh outh + {- | Split a list by a given character and select ranges of the resultant lists. > cutR [2..4] ' ' "foo bar baz quux foobar" -> "baz quux foobar" @@ -188,13 +290,11 @@ The input to this function is never read. -See also 'echoBS'. -} -echo :: String -> String -> String -echo inp _ = inp +You can pass this thing a String, a ByteString, or even a Handle. -{- | ByteString.Lazy version of 'echo'. -} -echoBS :: BSL.ByteString -> BSL.ByteString -> BSL.ByteString -echoBS inp _ = inp +See also 'echoBS'. -} +echo :: Channelizable a => a -> Channel -> IO Channel +echo inp _ = return . toChannel $ inp {- | Search for the regexp in the lines. Return those that match. -} egrep :: String -> [String] -> [String] @@ -235,8 +335,9 @@ Non-tilde expansion is done by the MissingH module System.Path.Glob. -} glob :: FilePath -> IO [FilePath] glob inp@('~':remainder) = - catch expanduser (\_ -> Glob.glob inp) + catch expanduser (\_ -> Glob.glob rest) where (username, rest) = span (/= '/') remainder +#ifdef __HSH_POSIX__ expanduser = do lookupuser <- if username /= "" @@ -244,6 +345,9 @@ else getEffectiveUserName ue <- getUserEntryForName lookupuser Glob.glob (homeDirectory ue ++ rest) +#else + expanduser = fail "non-posix; will be caught above" +#endif glob x = Glob.glob x {- | Search for the string in the lines. Return those that match. @@ -262,11 +366,18 @@ joinLines :: [String] -> [String] joinLines = return . concat +#ifdef __HSH_POSIX__ {- | Creates the given directory. A value of 0o755 for mode would be typical. -An alias for System.Posix.Directory.createDirectory. -} +An alias for System.Posix.Directory.createDirectory. + +The second argument will be ignored on non-POSIX systems. -} mkdir :: FilePath -> FileMode -> IO () mkdir = createDirectory +#else +mkdir :: FilePath -> a -> IO () +mkdir fp _ = SD.createDirectory fp +#endif {- | Number each line of a file -} numberLines :: [String] -> [String] @@ -276,9 +387,12 @@ pwd :: IO FilePath pwd = getCurrentDirectory +#ifdef __HSH_POSIX__ {- | Return the destination that the given symlink points to. -An alias for System.Posix.Files.readSymbolicLink -} +An alias for System.Posix.Files.readSymbolicLink + +This function is only available on POSIX platforms. -} readlink :: FilePath -> IO FilePath readlink fp = do issym <- (getFileStatus fp >>= return . isSymbolicLink) @@ -286,7 +400,9 @@ then readSymbolicLink fp else return fp -{- | As 'readlink', but turns the result into an absolute path. -} +{- | As 'readlink', but turns the result into an absolute path. + +This function is only available on POSIX platforms. -} readlinkabs :: FilePath -> IO FilePath readlinkabs inp = do issym <- (getFileStatus inp >>= return . isSymbolicLink) @@ -297,6 +413,7 @@ show (dirname inp) Just x -> return x else abspath inp +#endif {- | Reverse characters on each line (rev) -} rev, revW :: [String] -> [String] @@ -316,18 +433,36 @@ tac = reverse {- | Takes input, writes it to all the specified files, and passes it on. -This function buffers the input. +This function does /NOT' buffer input. -See also 'teeBS', 'catFrom'. -} -tee :: [FilePath] -> String -> IO String -tee [] inp = return inp -tee (x:xs) inp = writeFile x inp >> tee xs inp +See also 'catFrom'. -} +tee :: [FilePath] -> BSL.ByteString -> IO BSL.ByteString +tee fplist inp = teeBSGeneric (\fp -> openFile fp WriteMode) fplist inp -{- | Lazy ByteString version of 'tee'. -} -teeBS :: [FilePath] -> BSL.ByteString -> IO BSL.ByteString -teeBS [] inp = return inp -teeBS (x:xs) inp = BSL.writeFile x inp >> teeBS xs inp +#ifdef __HSH_POSIX__ +{- | FIFO-safe version of 'teeBS'. +This call will BLOCK all threads on open until a reader connects. + +This function is only available on POSIX platforms. -} +teeFIFO :: [FilePath] -> BSL.ByteString -> IO BSL.ByteString +teeFIFO fplist inp = teeBSGeneric fifoOpen fplist inp +#endif + +teeBSGeneric :: (FilePath -> IO Handle) -> [FilePath] -> BSL.ByteString -> IO BSL.ByteString +teeBSGeneric openfunc fplist inp = + do handles <- mapM openfunc fplist + resultChunks <- hProcChunks handles (BSL.toChunks inp) + return (BSL.fromChunks resultChunks) + where hProcChunks :: [Handle] -> [BS.ByteString] -> IO [BS.ByteString] + hProcChunks handles chunks = unsafeInterleaveIO $ + case chunks of + [] -> do mapM_ hClose handles + return [BS.empty] + (x:xs) -> do mapM_ (\h -> BS.hPutStr h x) handles + remainder <- hProcChunks handles xs + return (x : remainder) + {- | Translate a character x to y, like: >tr 'e' 'f' diff --git a/testsrc/runtests.hs b/testsrc/runtests.hs new file mode 100644 --- /dev/null +++ b/testsrc/runtests.hs @@ -0,0 +1,43 @@ +{- +Copyright (C) 2004-2007 John Goerzen +Please see the COPYRIGHT file +-} + +module Main where + +import Test.HUnit +import Tests +import TestUtils +import System.IO +import Text.Printf + +-- main = do runTestTT tests +main = do hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + (c, _) <- performTest reportStart reportError reportFailure () tests + printf "\n TESTS COMPLETE\n" + printf "Cases: %d, Tried: %d, Errors: %d, Failures: %d\n" + (cases c) (tried c) (errors c) (failures c) + +reportStart :: ReportStart () +reportStart st () = + do printf "[%-4d/%-4d] START %s\n" (tried . counts $ st) + (cases . counts $ st) + (showPath . path $ st) + hFlush stdout + return () + +reportError :: ReportProblem () +reportError = problem "ERROR " + +reportFailure :: ReportProblem () +reportFailure = problem "FAILURE" + +problem :: String -> ReportProblem () +problem ptype ptext st () = + do printf "[%-4d/%-4d] %s\n %s\n" (tried . counts $ st) + (cases . counts $ st) + (showPath . path $ st) ptext + hFlush stdout + return () +