module Development.Shake.Command(
command, command_, cmd, unit, CmdArguments,
Stdout(..), Stderr(..), Stdouterr(..), Exit(..), Process(..), 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.Extra
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)]
| AddEnv String String
| AddPath [String] [String]
| Stdin String
| StdinBS LBS.ByteString
| 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
| ResultProcess Pid
deriving Eq
data Pid = Pid0 | Pid ProcessHandle
instance Eq Pid where _ == _ = True
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 -> (if isWindows then winTracker else unixTracker) act
_ -> act [] exe args
winTracker act = do
(dir, cleanup) <- liftIO newTempDir
flip actionFinally cleanup $ do
res <- act [] "tracker" $ "/if":dir:"/c":exe:args
(rs, ws) <- liftIO $ trackerFiles dir
trackRead rs
trackWrite ws
return res
unixTracker act = do
(file, cleanup) <- liftIO newTempFile
flip actionFinally cleanup $ do
fsat <- liftIO $ getEnv "FSAT"
let vars = [AddEnv "DYLD_INSERT_LIBRARIES" fsat
,AddEnv "DYLD_FORCE_FLAT_NAMESPACE" "1"
,AddEnv "FSAT_OUT" file]
res <- act vars exe args
(rs, ws) <- liftIO $ fsatraceFiles file
whitelist <- liftIO unixWhitelist
let whitelisted x = any (\w -> (w ++ "/") `isPrefixOf` x) whitelist
trackRead $ filter (not . whitelisted) rs
trackWrite $ filter (not . whitelisted) ws
return res
skipper $ tracker $ \opts exe args -> verboser $ tracer $ commandExplicitIO funcName (opts++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
fsatraceFiles :: FilePath -> IO ([FilePath], [FilePath])
fsatraceFiles file = do
xs <- parseFSAT <$> readFileUTF8 file
let reader (FSATRead x) = Just x; reader _ = Nothing
writer (FSATWrite x) = Just x; writer (FSATMove x y) = Just x; writer _ = Nothing
frs <- liftIO $ filterM doesFileExist $ nubOrd $ map normalise $ mapMaybe reader xs
fws <- liftIO $ filterM doesFileExist $ nubOrd $ map normalise $ mapMaybe writer xs
return (frs, fws)
data FSAT = FSATWrite FilePath | FSATRead FilePath | FSATMove FilePath FilePath | FSATDelete FilePath
parseFSAT :: String -> [FSAT]
parseFSAT = mapMaybe (f . wordsBy (== ':')) . lines
where f ["w",x] = Just $ FSATWrite x
f ["r",x] = Just $ FSATRead x
f ["m",x,y] = Just $ FSATMove x y
f ["d",x] = Just $ FSATDelete x
f _ = Nothing
unixWhitelist :: IO [FilePath]
unixWhitelist = do
home <- getEnv "HOME"
return [home ++ "/.ghc"
,home ++ "/Library/Haskell"
,home ++ "/Applications"
,home ++ "/.cabal"
,"/Applications"
,"/var/folders"
,"/usr"
,"/Library"
,"/System"
]
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)
optEnv <- resolveEnv opts
let optCwd = let x = last $ "" : [x | Cwd x <- opts] in if x == "" then Nothing else Just x
let optStdin = flip mapMaybe opts $ \x -> case x of Stdin x -> Just $ Left x; StdinBS x -> Just $ Right x; _ -> Nothing
let optShell = Shell `elem` opts
let optBinary = BinaryPipes `elem` opts
let optAsync = ResultProcess Pid0 `elem` results
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 | not optAsync], Str . concat <$> readBuffer x)
buf LBS{} = do x <- newBuffer; return ([DestBytes x | not optAsync], LBS . LBS.fromChunks <$> readBuffer x)
buf BS {} = bufLBS (BS . BS.concat . LBS.toChunks)
buf Unit = return ([], return Unit)
(dStdout, dStderr, resultBuild) :: ([[Destination]], [[Destination]], [Double -> ProcessHandle -> ExitCode -> IO Result]) <-
fmap unzip3 $ forM results $ \r -> case r of
ResultCode _ -> return ([], [], \dur pid ex -> return $ ResultCode ex)
ResultTime _ -> return ([], [], \dur pid ex -> return $ ResultTime dur)
ResultLine _ -> return ([], [], \dur pid ex -> return $ ResultLine cmdline)
ResultProcess _ -> return ([], [], \dur pid ex -> return $ ResultProcess $ Pid pid)
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 || any isRight optStdin then Right $ LBS.concat $ map (either LBS.pack id) optStdin else Left $ concatMap fromLeft optStdin
,poStdout = [DestEcho | optEchoStdout] ++ map DestFile optFileStdout ++ [DestString exceptionBuffer | optWithStdout && not optAsync] ++ concat dStdout
,poStderr = [DestEcho | optEchoStderr] ++ map DestFile optFileStderr ++ [DestString exceptionBuffer | optWithStderr && not optAsync] ++ concat dStderr
,poAsync = optAsync
}
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,(pid,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,(pid,ex)) -> mapM (\f -> f dur pid ex) resultBuild
resolveEnv :: [CmdOption] -> IO (Maybe [(String, String)])
resolveEnv opts
| null env, null addEnv, null addPath = return Nothing
| otherwise = Just . unique . tweakPath . (++ addEnv) <$>
if null env then getEnvironment else return (concat env)
where
env = [x | Env x <- opts]
addEnv = [(x,y) | AddEnv x y <- opts]
addPath = [(x,y) | AddPath x y <- opts]
newPath mid = intercalate [searchPathSeparator] $
concat (reverse $ map fst addPath) ++ [mid | mid /= ""] ++ concatMap snd addPath
isPath x = (if isWindows then upper else id) x == "PATH"
tweakPath xs | not $ any (isPath . fst) xs = ("PATH", newPath "") : xs
| otherwise = map (\(a,b) -> (a, if isPath a then newPath b else b)) xs
unique = reverse . nubOrdOn (if isWindows then upper . fst else fst) . reverse
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 Process = Process {fromProcess :: ProcessHandle}
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 Process where
cmdResult = ([ResultProcess Pid0], \[ResultProcess (Pid x)] -> Process x)
instance CmdResult ProcessHandle where
cmdResult = ([ResultProcess Pid0], \[ResultProcess (Pid 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