module Development.Shake.Command(
command, command_, cmd,
Stdout(..), Stderr(..), Exit(..),
CmdResult, CmdOption(..),
addPath, addEnv,
) where
import Control.Arrow
import Control.Concurrent
import Control.DeepSeq
import Control.Exception as C
import Control.Monad
import Control.Monad.IO.Class
import Data.Char
import Data.Either
import Data.List
import Foreign.C.Error
import System.Environment
import System.Exit
import System.IO
import System.Process
import Development.Shake.Core
import Development.Shake.FilePath
import Development.Shake.Types
import General.Base
import GHC.IO.Exception (IOErrorType(..), IOException(..))
data CmdOption
= Cwd FilePath
| Env [(String,String)]
| Stdin String
| Shell
| BinaryPipes
| Traced String
| WithStderr Bool
| EchoStdout Bool
| EchoStderr Bool
deriving (Eq,Ord,Show)
addPath :: MonadIO m => [String] -> [String] -> m CmdOption
addPath pre post = do
args <- liftIO getEnvironment
let (path,other) = partition ((== "PATH") . (if isWindows then map toUpper else id) . fst) args
return $ Env $
[("PATH",intercalate [searchPathSeparator] $ pre ++ post) | null post] ++
[(a,intercalate [searchPathSeparator] $ pre ++ [b | b /= ""] ++ post) | (a,b) <- path] ++
other
addEnv :: MonadIO m => [(String, String)] -> m CmdOption
addEnv extra = do
args <- liftIO getEnvironment
return $ Env $ extra ++ filter (\(a,b) -> a `notElem` map fst extra) args
data Result
= ResultStdout String
| ResultStderr String
| ResultCode ExitCode
deriving Eq
commandExplicit :: String -> [CmdOption] -> [Result] -> String -> [String] -> Action [Result]
commandExplicit funcName opts results exe args = skipper $ verboser $ tracer $ commandExplicitIO funcName opts results exe args
where
skipper act = do
o <- getShakeOptions
if null results && not (shakeRunCommands o) then return [] else act
verboser act = do
v <- getVerbosity
putLoud $ saneCommandForUser exe args
(if v >= Loud then quietly else id) act
tracer = case reverse [x | Traced x <- opts] of
"":_ -> liftIO
msg:_ -> traced msg
[] -> traced (takeFileName exe)
commandExplicitIO :: String -> [CmdOption] -> [Result] -> String -> [String] -> IO [Result]
commandExplicitIO funcName opts results exe args =
mask $ \restore -> do
ans <- try $ createProcess cp
(inh, outh, 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 inh; close outh; close errh
terminateProcess pid; waitForProcess pid) $ restore $ do
when (BinaryPipes `elem` opts) $ do
let bin = maybe (return ()) (`hSetBinaryMode` True)
bin inh; bin outh; bin errh
(out,waitOut,waitOutEcho) <- case 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)
(err,waitErr,waitErrEcho) <- case 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)
let writeInput = do
case 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
waitOut
waitErr
waitOutEcho
waitErrEcho
close outh
close errh
ex <- waitForProcess pid
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]
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
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)
saneCommandForUser :: FilePath -> [String] -> String
saneCommandForUser cmd args = unwords $ map f $ cmd:args
where
f x = if take (length y 2) (drop 1 y) == x then x else y
where y = showCommandForUser x []
newtype Stdout = Stdout {fromStdout :: String}
newtype Stderr = Stderr {fromStderr :: String}
newtype Exit = Exit {fromExit :: ExitCode}
class CmdResult a where
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
cmdResultWith f = second (f .) cmdResult
instance (CmdResult x1, CmdResult x2, CmdResult x3) => CmdResult (x1,x2,x3) where
cmdResult = cmdResultWith $ \(a,(b,c)) -> (a,b,c)
command :: CmdResult r => [CmdOption] -> String -> [String] -> Action r
command opts x xs = fmap b $ commandExplicit "command" opts a x xs
where (a,b) = cmdResult
command_ :: [CmdOption] -> String -> [String] -> Action ()
command_ opts x xs = commandExplicit "command_" opts [] x xs >> return ()
type a :-> t = a
cmd :: CmdArguments args => args :-> Action 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 (Action r) where
cmdArguments x = case partitionEithers x 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"
instance CmdResult r => CmdArguments (IO r) where
cmdArguments x = case partitionEithers x of
(opts, x:xs) -> let (a,b) = cmdResult in fmap b $ commandExplicitIO "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