module Development.Shake.Command(
command, command_, cmd, unit, CmdArguments,
Stdout(..), Stderr(..), Stdouterr(..), Exit(..), CmdTime(..), CmdLine(..),
CmdResult, CmdString, CmdOption(..),
addPath, addEnv,
) where
import Data.Tuple.Extra
import Control.Applicative
import Control.Exception.Extra
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Either
import Data.List.Extra
import Data.Maybe
import System.Directory
import System.Environment.Extra
import System.Exit
import System.IO.Extra
import System.Process
import System.Info.Extra
import System.Time.Extra
import System.IO.Unsafe(unsafeInterleaveIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import General.Process
import Prelude
import Development.Shake.Core
import Development.Shake.FilePath
import Development.Shake.Types
import Development.Shake.Rules.File
data CmdOption
= Cwd FilePath
| Env [(String,String)]
| Stdin String
| Shell
| BinaryPipes
| Traced String
| Timeout Double
| WithStdout Bool
| WithStderr Bool
| EchoStdout Bool
| EchoStderr Bool
| FileStdout FilePath
| FileStderr FilePath
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 Str = Str String | BS BS.ByteString | LBS LBS.ByteString | Unit deriving Eq
data Result
= ResultStdout Str
| ResultStderr Str
| ResultStdouterr Str
| ResultCode ExitCode
| ResultTime Double
| ResultLine String
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 nubOrd $ mapMaybeM correctCase $ nubOrd $ 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
let (grabStdout, grabStderr) = both or $ unzip $ for results $ \r -> case r of
ResultStdout{} -> (True, False)
ResultStderr{} -> (False, True)
ResultStdouterr{} -> (True, True)
_ -> (False, False)
let optCwd = let x = last $ "" : [x | Cwd x <- opts] in if x == "" then Nothing else Just x
let optEnv = let x = [x | Env x <- opts] in if null x then Nothing else Just $ concat x
let optStdin = concat [x | Stdin x <- opts]
let optShell = Shell `elem` opts
let optBinary = BinaryPipes `elem` opts
let optTimeout = listToMaybe $ reverse [x | Timeout x <- opts]
let optWithStdout = last $ False : [x | WithStdout x <- opts]
let optWithStderr = last $ True : [x | WithStderr x <- opts]
let optFileStdout = [x | FileStdout x <- opts]
let optFileStderr = [x | FileStderr x <- opts]
let optEchoStdout = last $ (not grabStdout && null optFileStdout) : [x | EchoStdout x <- opts]
let optEchoStderr = last $ (not grabStderr && null optFileStderr) : [x | EchoStderr x <- opts]
let cmdline = saneCommandForUser exe args
let bufLBS f = do (a,b) <- buf $ LBS LBS.empty; return (a, (\(LBS x) -> f x) <$> b)
buf Str{} | optBinary = bufLBS (Str . LBS.unpack)
buf Str{} = do x <- newBuffer; return ([DestString x], Str . concat <$> readBuffer x)
buf LBS{} = do x <- newBuffer; return ([DestBytes x], LBS . LBS.fromChunks <$> readBuffer x)
buf BS {} = bufLBS (BS . BS.concat . LBS.toChunks)
buf Unit = return ([], return Unit)
(dStdout, dStderr, resultBuild) :: ([[Destination]], [[Destination]], [Double -> ExitCode -> IO Result]) <-
fmap unzip3 $ forM results $ \r -> case r of
ResultCode _ -> return ([], [], \dur ex -> return $ ResultCode ex)
ResultTime _ -> return ([], [], \dur ex -> return $ ResultTime dur)
ResultLine _ -> return ([], [], \dur ex -> return $ ResultLine cmdline)
ResultStdout s -> do (a,b) <- buf s; return (a , [], \_ _ -> fmap ResultStdout b)
ResultStderr s -> do (a,b) <- buf s; return ([], a , \_ _ -> fmap ResultStderr b)
ResultStdouterr s -> do (a,b) <- buf s; return (a , a , \_ _ -> fmap ResultStdouterr b)
exceptionBuffer <- newBuffer
po <- resolvePath $ ProcessOpts
{poCommand = if optShell then ShellCommand $ unwords $ exe:args else RawCommand exe args
,poCwd = optCwd, poEnv = optEnv, poTimeout = optTimeout
,poStdin = if optBinary then Right $ LBS.pack optStdin else Left optStdin
,poStdout = [DestEcho | optEchoStdout] ++ map DestFile optFileStdout ++ [DestString exceptionBuffer | optWithStdout] ++ concat dStdout
,poStderr = [DestEcho | optEchoStderr] ++ map DestFile optFileStderr ++ [DestString exceptionBuffer | optWithStderr] ++ concat dStderr
}
res <- try_ $ duration $ process po
let failure extra = do
cwd <- case optCwd 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: " ++ cmdline ++ "\n" ++
cwd ++ extra
case res of
Left err -> failure $ show err
Right (dur,ex) | ex /= ExitSuccess && ResultCode ExitSuccess `notElem` results -> do
exceptionBuffer <- readBuffer exceptionBuffer
let captured = ["Stderr" | optWithStderr] ++ ["Stdout" | optWithStdout]
failure $
"Exit code: " ++ show (case ex of ExitFailure i -> i; _ -> 0) ++ "\n" ++
if null captured then "Stderr not captured because WithStderr False was used\n"
else if null exceptionBuffer then intercalate " and " captured ++ " " ++ (if length captured == 1 then "was" else "were") ++ " empty"
else intercalate " and " captured ++ ":\n" ++ unlines (dropWhile null $ lines $ concat exceptionBuffer)
Right (dur,ex) -> mapM (\f -> f dur ex) resultBuild
resolvePath :: ProcessOpts -> IO ProcessOpts
resolvePath po
| Just e <- poEnv po
, Just (_, path) <- find ((==) "PATH" . (if isWindows then upper else id) . fst) e
, RawCommand prog args <- poCommand po
= 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 -> po{poCommand = RawCommand new args}
_ -> po
resolvePath po = return po
findExecutableWith :: [FilePath] -> String -> IO (Maybe FilePath)
findExecutableWith path x = flip firstJustM (map (</> x) path) $ \s ->
ifM (doesFileExist s) (return $ Just s) (return Nothing)
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 a = Stdout {fromStdout :: a}
newtype Stderr a = Stderr {fromStderr :: a}
newtype Stdouterr a = Stdouterr {fromStdouterr :: a}
newtype Exit = Exit {fromExit :: ExitCode}
newtype CmdTime = CmdTime {fromCmdTime :: Double}
newtype CmdLine = CmdLine {fromCmdLine :: String}
class CmdString a where cmdString :: (Str, Str -> a)
instance CmdString () where cmdString = (Unit, \Unit -> ())
instance CmdString String where cmdString = (Str "", \(Str x) -> x)
instance CmdString BS.ByteString where cmdString = (BS BS.empty, \(BS x) -> x)
instance CmdString LBS.ByteString where cmdString = (LBS LBS.empty, \(LBS x) -> x)
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 CmdLine where
cmdResult = ([ResultLine ""], \[ResultLine x] -> CmdLine x)
instance CmdResult CmdTime where
cmdResult = ([ResultTime 0], \[ResultTime x] -> CmdTime x)
instance CmdString a => CmdResult (Stdout a) where
cmdResult = let (a,b) = cmdString in ([ResultStdout a], \[ResultStdout x] -> Stdout $ b x)
instance CmdString a => CmdResult (Stderr a) where
cmdResult = let (a,b) = cmdString in ([ResultStderr a], \[ResultStderr x] -> Stderr $ b x)
instance CmdString a => CmdResult (Stdouterr a) where
cmdResult = let (a,b) = cmdString in ([ResultStdouterr a], \[ResultStdouterr x] -> Stdouterr $ b 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)
instance (CmdResult x1, CmdResult x2, CmdResult x3, CmdResult x4) => CmdResult (x1,x2,x3,x4) where
cmdResult = cmdResultWith $ \(a,(b,c,d)) -> (a,b,c,d)
instance (CmdResult x1, CmdResult x2, CmdResult x3, CmdResult x4, CmdResult x5) => CmdResult (x1,x2,x3,x4,x5) where
cmdResult = cmdResultWith $ \(a,(b,c,d,e)) -> (a,b,c,d,e)
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 CmdOption where arg = return . Left
instance Arg [CmdOption] where arg = map Left
instance Arg a => Arg (Maybe a) where arg = maybe [] arg