module Development.Shake.Command(
command, command_, cmd, CmdArguments,
Stdout(..), Stderr(..), Exit(..),
CmdResult, CmdOption(..),
addPath, addEnv,
) where
import Data.Tuple.Extra
import Control.Concurrent
import Control.DeepSeq
import Control.Exception.Extra as C
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Either
import Data.List.Extra
import Data.Maybe
import Foreign.C.Error
import System.Directory
import System.Environment.Extra
import System.Exit
import System.IO.Extra
import System.Process
import System.Info.Extra
import System.IO.Unsafe(unsafeInterleaveIO)
import Development.Shake.Core
import Development.Shake.FilePath
import Development.Shake.Types
import Development.Shake.Rules.File
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 upper 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
let cwd = listToMaybe $ reverse [x | Cwd x <- copts]
putLoud $ maybe "" (\x -> "cd " ++ x ++ "; ") cwd ++ 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 = upper curdir ++ "\\"
files <- getDirectoryContents dir
let f typ = do
files <- forM [x | x <- files, takeExtension x == ".tlog", takeExtension (dropExtension $ dropExtension x) == '.':typ] $ \file -> do
xs <- readFileEncoding utf16 $ 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 . upper) 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 = do
cp <- resolvePath cp
mask $ \restore -> do
ans <- try_ $ createProcess cp
(inh, outh, errh, pid) <- case ans of
Right a -> return a
Left err -> failure $ show err
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
failure $
"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))
return $ flip map results $ \x -> case x of
ResultStdout _ -> ResultStdout out
ResultStderr _ -> ResultStderr err
ResultCode _ -> ResultCode ex
where
failure extra = do
cwd <- case cwd cp of
Nothing -> return ""
Just v -> do
v <- canonicalizePath v `catch_` const (return v)
return $ "Current directory: " ++ v ++ "\n"
fail $
"Development.Shake." ++ funcName ++ ", system command failed\n" ++
"Command: " ++ saneCommandForUser exe args ++ "\n" ++
cwd ++ extra
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
resolvePath :: CreateProcess -> IO CreateProcess
resolvePath cp
| Just e <- env cp
, Just (_, path) <- find ((==) "PATH" . (if isWindows then upper else id) . fst) e
, RawCommand prog args <- cmdspec cp
= do
let progExe = if prog == prog -<.> exe then prog else prog <.> exe
pathOld <- unsafeInterleaveIO $ fmap (fromMaybe "") $ lookupEnv "PATH"
old <- unsafeInterleaveIO $ findExecutable prog
new <- unsafeInterleaveIO $ findExecutableWith (splitSearchPath path) progExe
old2 <- unsafeInterleaveIO $ findExecutableWith (splitSearchPath pathOld) progExe
switch <- return $ case () of
_ | path == pathOld -> False
| Nothing <- new -> False
| Nothing <- old -> True
| Just old <- old, Just new <- new, equalFilePath old new -> False
| Just old <- old, Just old2 <- old2, equalFilePath old old2 -> True
| otherwise -> False
return $ case new of
Just new | switch -> cp{cmdspec = RawCommand new args}
_ -> cp
resolvePath cp = do
return cp
findExecutableWith :: [FilePath] -> String -> IO (Maybe FilePath)
findExecutableWith path x = flip firstJustM (map (</> x) path) $ \s ->
ifM (doesFileExist s) (return $ Just s) (return Nothing)
forkWait :: IO a -> IO (IO a)
forkWait a = do
res <- newEmptyMVar
_ <- mask $ \restore -> forkIO $ try_ (restore a) >>= putMVar res
return (takeMVar res >>= either throwIO 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 = void $ commandExplicit "command_" opts [] x xs
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 (Maybe String) where arg = map Right . maybe [] words
instance Arg CmdOption where arg = return . Left
instance Arg [CmdOption] where arg = map Left
instance Arg (Maybe CmdOption) where arg = map Left . maybeToList