command (empty) → 0.1.0
raw patch · 3 files changed
+339/−0 lines, 3 filesdep +basedep +deepseqdep +processsetup-changed
Dependencies added: base, deepseq, process
Files
- Setup.hs +2/−0
- command.cabal +40/−0
- src/System/Command.hs +297/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ command.cabal view
@@ -0,0 +1,40 @@+name: command+version: 0.1.0+license: MIT+copyright: Neil Mitchell 2011-2013+author: Neil Mitchell <ndmitchell@gmail.com>+maintainer: Niklas Hambüchen <mail@nh2.me>+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
+ src/System/Command.hs view
@@ -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