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 Data.Maybe
import Foreign.C.Error
import System.Directory
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 Development.Shake.Rules.File
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 path] ++
[(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 copts results exe args = do
opts <- getShakeOptions
verb <- getVerbosity
let skipper act = if null results && not (shakeRunCommands opts) then return [] else act
let verboser act = do
putLoud $ saneCommandForUser exe args
(if verb >= Loud then quietly else id) act
let tracer = case reverse [x | Traced x <- copts] of
"":_ -> liftIO
msg:_ -> traced msg
[] -> traced (takeFileName exe)
let tracker act = case shakeLint opts of
Just LintTracker -> do
dir <- liftIO $ getTemporaryDirectory
(file, handle) <- liftIO $ openTempFile dir "shake.lint"
liftIO $ hClose handle
dir <- return $ file <.> "dir"
liftIO $ createDirectory dir
let cleanup = removeDirectoryRecursive dir >> removeFile file
flip actionFinally cleanup $ do
res <- act "tracker" $ "/if":dir:"/c":exe:args
(read,write) <- liftIO $ trackerFiles dir
trackRead read
trackWrite write
return res
_ -> act exe args
skipper $ tracker $ \exe args -> verboser $ tracer $ commandExplicitIO funcName copts results exe args
trackerFiles :: FilePath -> IO ([FilePath], [FilePath])
trackerFiles dir = do
curdir <- getCurrentDirectory
let pre = map toUpper curdir ++ "\\"
files <- getDirectoryContents dir
let f typ = do
files <- forM [x | x <- files, takeExtension x == ".tlog", takeExtension (dropExtension $ dropExtension x) == '.':typ] $ \file -> do
xs <- readFileUCS2 $ dir </> file
return $ filter (not . isPrefixOf "." . takeFileName) . mapMaybe (stripPrefix pre) $ lines xs
fmap nub $ mapMaybeM correctCase $ nub $ concat files
liftM2 (,) (f "read") (f "write")
correctCase :: FilePath -> IO (Maybe FilePath)
correctCase x = f "" x
where
f pre "" = return $ Just pre
f pre x = do
let (a,b) = (takeDirectory1 x, dropDirectory1 x)
dir <- getDirectoryContents pre
case find ((==) a . map toUpper) dir of
Nothing -> return Nothing
Just v -> f (pre +/+ v) b
a +/+ b = if null a then b else a ++ "/" ++ b
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