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/command.cabal b/command.cabal new file mode 100644 --- /dev/null +++ b/command.cabal @@ -0,0 +1,40 @@ +name: command +version: 0.1.0 +license: MIT +copyright: Neil Mitchell 2011-2013 +author: Neil Mitchell +maintainer: Niklas Hambüchen +category: System +build-type: Simple +stability: experimental +tested-With: GHC==7.6.3 +cabal-version: >= 1.8 +homepage: https://github.com/nh2/command +bug-Reports: https://github.com/nh2/command/issues +synopsis: Conveniently run shell commands +description: + This is a standalone version of the powerful and intuitive command line + functions present in the Shake build system. + . + They are intended as an easy-to-remember, easy-to-use alternative + to the System.Process functions. + . + All credit goes to the Shake author! + I hope he'll take it over as a standalone project. + . + CHANGELOG + . + Version 0.1.0 + . + * Initial version, copied from Shake. + +source-repository head + type: git + location: git://github.com/nh2/command.git + + +library + exposed-modules: System.Command + build-depends: base < 5, deepseq, process + hs-source-dirs: src + ghc-options: -Wall diff --git a/src/System/Command.hs b/src/System/Command.hs new file mode 100644 --- /dev/null +++ b/src/System/Command.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators #-} + +module System.Command +( command, command_, cmd +, Stdout(..), Stderr(..), Exit(..) +, CmdResult, CmdOption(..) +) where + +import Control.Arrow +import Control.Concurrent +import Control.DeepSeq +import Control.Exception as C +import Control.Monad +import Data.Either +import Foreign.C.Error +import System.Exit +import System.IO +import System.Process + +import GHC.IO.Exception (IOErrorType(..), IOException(..)) + + +--------------------------------------------------------------------- +-- ACTUAL EXECUTION + +-- | Options passed to 'command' or 'cmd' to control how processes are executed. +data CmdOption + = Cwd FilePath -- ^ Change the current directory in the spawned process. By default uses this processes current directory. + | Env [(String,String)] -- ^ Change the environment variables in the spawned process. By default uses this processes environment. + | Stdin String -- ^ Given as the @stdin@ of the spawned process. By default no @stdin@ is given. + | Shell -- ^ Pass the command to the shell without escaping - any arguments will be joined with spaces. By default arguments are escaped properly. + | BinaryPipes -- ^ Treat the @stdin@\/@stdout@\/@stderr@ messages as binary. By default streams use text encoding. + | Traced String -- ^ Name to use with 'traced', or @\"\"@ for no tracing. By default traces using the name of the executable. + | WithStderr Bool -- ^ Should I include the @stderr@ in the exception if the command fails? Defaults to 'True'. + | EchoStdout Bool -- ^ Should I echo the @stdout@? Defaults to 'True' unless a 'Stdout' result is required. + | EchoStderr Bool -- ^ Should I echo the @stderr@? Defaults to 'True' unless a 'Stderr' result is required. + deriving (Eq,Ord,Show) + +data Result + = ResultStdout String + | ResultStderr String + | ResultCode ExitCode + deriving Eq + + +commandExplicit :: String -> [CmdOption] -> [Result] -> String -> [String] -> IO [Result] +commandExplicit funcName opts results exe args = +-- BEGIN COPIED +-- Originally from readProcessWithExitCode with as few changes as possible + mask $ \restore -> do + ans <- try $ createProcess cp + (m'inh, m'outh, m'errh, pid) <- case ans of + Right a -> return a + Left err -> do + let msg = "Development.Shake." ++ funcName ++ ", system command failed\n" ++ + "Command: " ++ saneCommandForUser exe args ++ "\n" ++ + show (err :: SomeException) + error msg + + let close = maybe (return ()) hClose + flip onException + (do close m'inh; close m'outh; close m'errh + terminateProcess pid; waitForProcess pid) $ restore $ do + + -- set pipes to binary if appropriate + when (BinaryPipes `elem` opts) $ do + let bin = maybe (return ()) (`hSetBinaryMode` True) + bin m'inh; bin m'outh; bin m'errh + + -- fork off a thread to start consuming stdout + (out,waitOut,waitOutEcho) <- case m'outh of + Nothing -> return ("", return (), return ()) + Just outh -> do + out <- hGetContents outh + waitOut <- forkWait $ C.evaluate $ rnf out + waitOutEcho <- if stdoutEcho + then forkWait (hPutStr stdout out) + else return (return ()) + return (out,waitOut,waitOutEcho) + + -- fork off a thread to start consuming stderr + (err,waitErr,waitErrEcho) <- case m'errh of + Nothing -> return ("", return (), return ()) + Just errh -> do + err <- hGetContents errh + waitErr <- forkWait $ C.evaluate $ rnf err + waitErrEcho <- if stderrEcho + then forkWait (hPutStr stderr err) + else return (return ()) + return (err,waitErr,waitErrEcho) + + -- now write and flush any input + let writeInput = do + case m'inh of + Nothing -> return () + Just inh -> do + hPutStr inh input + hFlush inh + hClose inh + + C.catch writeInput $ \e -> case e of + IOError { ioe_type = ResourceVanished + , ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> throwIO e + + -- wait on the output + waitOut + waitErr + + waitOutEcho + waitErrEcho + + close m'outh + close m'errh + + -- wait on the process + ex <- waitForProcess pid +-- END COPIED + + when (ResultCode ExitSuccess `notElem` results && ex /= ExitSuccess) $ do + let msg = "Development.Shake." ++ funcName ++ ", system command failed\n" ++ + "Command: " ++ saneCommandForUser exe args ++ "\n" ++ + "Exit code: " ++ show (case ex of ExitFailure i -> i; _ -> 0) ++ "\n" ++ + (if not stderrThrow then "Stderr not captured because ErrorsWithoutStderr was used" + else if null err then "Stderr was empty" + else "Stderr:\n" ++ unlines (dropWhile null $ lines err)) + error msg + + return $ flip map results $ \x -> case x of + ResultStdout _ -> ResultStdout out + ResultStderr _ -> ResultStderr err + ResultCode _ -> ResultCode ex + where + input = last $ "" : [x | Stdin x <- opts] + + -- what should I do with these handles + binary = BinaryPipes `elem` opts + stdoutEcho = last $ (ResultStdout "" `notElem` results) : [b | EchoStdout b <- opts] + stdoutCapture = ResultStdout "" `elem` results + stderrEcho = last $ (ResultStderr "" `notElem` results) : [b | EchoStderr b <- opts] + stderrThrow = last $ True : [b | WithStderr b <- opts] + stderrCapture = ResultStderr "" `elem` results || (stderrThrow && ResultCode ExitSuccess `notElem` results) + + cp0 = (if Shell `elem` opts then shell $ unwords $ exe:args else proc exe args) + {std_out = if binary || stdoutCapture || not stdoutEcho then CreatePipe else Inherit + ,std_err = if binary || stderrCapture || not stderrEcho then CreatePipe else Inherit + ,std_in = if null input then Inherit else CreatePipe + } + cp = foldl applyOpt cp0{std_out = CreatePipe, std_err = CreatePipe} opts + applyOpt :: CreateProcess -> CmdOption -> CreateProcess + applyOpt o (Cwd x) = o{cwd = if x == "" then Nothing else Just x} + applyOpt o (Env x) = o{env = Just x} + applyOpt o _ = o + + +-- Copied from System.Process +forkWait :: IO a -> IO (IO a) +forkWait a = do + res <- newEmptyMVar + _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res + return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return) + + +-- Like System.Process, but tweaked to show less escaping, +-- Relies on relatively detailed internals of showCommandForUser. +saneCommandForUser :: FilePath -> [String] -> String +saneCommandForUser c args = unwords $ map f $ c:args + where + f x = if take (length y - 2) (drop 1 y) == x then x else y + where y = showCommandForUser x [] + + +--------------------------------------------------------------------- +-- FIXED ARGUMENT WRAPPER + +-- | Collect the @stdout@ of the process. +-- If you are collecting the @stdout@, it will not be echoed to the terminal, unless you include 'EchoStdout'. +newtype Stdout = Stdout {fromStdout :: String} + +-- | Collect the @stderr@ of the process. +-- If you are collecting the @stderr@, it will not be echoed to the terminal, unless you include 'EchoStderr'. +newtype Stderr = Stderr {fromStderr :: String} + +-- | Collect the 'ExitCode' of the process. +-- If you do not collect the exit code, any 'ExitFailure' will cause an exception. +newtype Exit = Exit {fromExit :: ExitCode} + +-- | A class for specifying what results you want to collect from a process. +-- Values are formed of 'Stdout', 'Stderr', 'Exit' and tuples of those. +class CmdResult a where + -- Return a list of results (with the right type but dummy data) + -- and a function to transform a populated set of results into a value + cmdResult :: ([Result], [Result] -> a) + +instance CmdResult Exit where + cmdResult = ([ResultCode $ ExitSuccess], \[ResultCode x] -> Exit x) + +instance CmdResult ExitCode where + cmdResult = ([ResultCode $ ExitSuccess], \[ResultCode x] -> x) + +instance CmdResult Stdout where + cmdResult = ([ResultStdout ""], \[ResultStdout x] -> Stdout x) + +instance CmdResult Stderr where + cmdResult = ([ResultStderr ""], \[ResultStderr x] -> Stderr x) + +instance CmdResult () where + cmdResult = ([], \[] -> ()) + +instance (CmdResult x1, CmdResult x2) => CmdResult (x1,x2) where + cmdResult = (a1++a2, \rs -> let (r1,r2) = splitAt (length a1) rs in (b1 r1, b2 r2)) + where (a1,b1) = cmdResult + (a2,b2) = cmdResult + +instance (CmdResult x1, CmdResult x2, CmdResult x3) => CmdResult (x1,x2,x3) where + cmdResult = cmdResultWith $ \(a,(b,c)) -> (a,b,c) + where + cmdResultWith f = second (f .) cmdResult + + +-- | Execute a system command. Before running 'command' make sure you 'Development.Shake.need' any files +-- that are required by the command. +-- +-- This function takes a list of options (often just @[]@, see 'CmdOption' for the available +-- options), the name of the executable (either a full name, or a program on the @$PATH@) and +-- a list of arguments. The result is often @()@, but can be a tuple containg any of 'Stdout', +-- 'Stderr' and 'Exit'. Some examples: +-- +-- @ +-- 'command_' [] \"gcc\" [\"-c\",\"myfile.c\"] -- compile a file, throwing an exception on failure +-- 'Exit' c <- 'command' [] \"gcc\" [\"-c\",myfile] -- run a command, recording the exit code +-- ('Exit' c, 'Stderr' err) <- 'command' [] \"gcc\" [\"-c\",\"myfile.c\"] -- run a command, recording the exit code and error output +-- 'Stdout' out <- 'command' [] \"gcc\" [\"-MM\",\"myfile.c\"] -- run a command, recording the output +-- 'command_' ['Cwd' \"generated\"] \"gcc\" [\"-c\",myfile] -- run a command in a directory +-- @ +-- +-- Unless you retrieve the 'ExitCode' using 'Exit', any 'ExitFailure' will throw an error, including +-- the 'Stderr' in the exception message. If you capture the 'Stdout' or 'Stderr', that stream will not be echoed to the console, +-- unless you use the option 'EchoStdout' or 'EchoStderr'. +-- +-- If you use 'command' inside a @do@ block and do not use the result, you may get a compile-time error about being +-- unable to deduce 'CmdResult'. To avoid this error, use 'command_'. +command :: CmdResult r => [CmdOption] -> String -> [String] -> IO r +command opts x xs = fmap b $ commandExplicit "command" opts a x xs + where (a,b) = cmdResult + +-- | A version of 'command' where you do not require any results, used to avoid errors about being unable +-- to deduce 'CmdResult'. +command_ :: [CmdOption] -> String -> [String] -> IO () +command_ opts x xs = commandExplicit "command_" opts [] x xs >> return () + + +--------------------------------------------------------------------- +-- VARIABLE ARGUMENT WRAPPER + +type a :-> t = a + + +-- | A variable arity version of 'command'. +-- +-- * @String@ arguments are treated as whitespace separated arguments. +-- +-- * @[String]@ arguments are treated as literal arguments. +-- +-- * 'CmdOption' arguments are used as options. +-- +-- To take the examples from 'command': +-- +-- @ +-- () <- 'cmd' \"gcc -c myfile.c\" -- compile a file, throwing an exception on failure +-- 'Exit' c <- 'cmd' \"gcc -c\" [myfile] -- run a command, recording the exit code +-- ('Exit' c, 'Stderr' err) <- 'cmd' \"gcc -c myfile.c\" -- run a command, recording the exit code and error output +-- 'Stdout' out <- 'cmd' \"gcc -MM myfile.c\" -- run a command, recording the output +-- 'cmd' ('Cwd' \"generated\") \"gcc -c\" [myfile] :: 'IO' () -- run a command in a directory +-- @ +-- +-- When passing file arguments we use @[myfile]@ so that if the @myfile@ variable contains spaces they are properly escaped. +-- +-- If you use 'cmd' inside a @do@ block and do not use the result, you may get a compile-time error about being +-- unable to deduce 'CmdResult'. To avoid this error, bind the result to @()@, or include a type signature. +cmd :: CmdArguments args => args :-> IO r +cmd = cmdArguments [] + +class CmdArguments t where cmdArguments :: [Either CmdOption String] -> t +instance (Arg a, CmdArguments r) => CmdArguments (a -> r) where + cmdArguments xs x = cmdArguments $ xs ++ arg x +instance CmdResult r => CmdArguments (IO r) where + cmdArguments exs = case partitionEithers exs of + (opts, x:xs) -> let (a,b) = cmdResult in fmap b $ commandExplicit "cmd" opts a x xs + _ -> error "Error, no executable or arguments given to Development.Shake.cmd" + +class Arg a where arg :: a -> [Either CmdOption String] +instance Arg String where arg = map Right . words +instance Arg [String] where arg = map Right +instance Arg CmdOption where arg = return . Left +instance Arg [CmdOption] where arg = map Left