module BuildBox.Command.System
( module System.Exit
, system
, ssystem
, qsystem
, qssystem
, ssystemOut
, qssystemOut
, systemTee
, ssystemTee
, systemTeeIO)
where
import BuildBox.Command.System.Internals
import BuildBox.Build
import Control.Concurrent
import System.Process hiding (system)
import System.Exit
import System.IO
import Control.Monad
debug :: Bool
debug = False
trace :: String -> IO ()
trace s = when debug $ putStrLn s
system :: String -> Build ExitCode
system cmd
= do (code, _, _) <- systemTee True cmd ""
return code
ssystem :: String -> Build ()
ssystem cmd
= do (code, strOut, strErr) <- systemTee True cmd ""
when (code /= ExitSuccess)
$ throw $ ErrorSystemCmdFailed cmd code strOut strErr
qsystem :: String -> Build ExitCode
qsystem cmd
= do (code, _, _) <- systemTee False cmd ""
return code
qssystem :: String -> Build ()
qssystem cmd
= do (code, strOut, strErr) <- systemTee False cmd ""
when (code /= ExitSuccess)
$ throw $ ErrorSystemCmdFailed cmd code strOut strErr
ssystemOut :: String -> Build String
ssystemOut cmd
= do (code, strOut, strErr) <- systemTee True cmd ""
when (code /= ExitSuccess || (not $ null strErr))
$ throw $ ErrorSystemCmdFailed cmd code strOut strErr
return strOut
qssystemOut :: String -> Build String
qssystemOut cmd
= do (code, strOut, strErr) <- systemTee False cmd ""
when (code /= ExitSuccess || (not $ null strErr))
$ throw $ ErrorSystemCmdFailed cmd code strOut strErr
return strOut
systemTee
:: Bool
-> String
-> String
-> Build (ExitCode, String, String)
systemTee tee cmd strIn
= do logSystem cmd
io $ systemTeeIO tee cmd strIn
ssystemTee :: Bool -> String -> String -> Build ()
ssystemTee tee cmd strIn
= do logSystem cmd
(code, strOut, strErr) <- systemTee tee cmd strIn
when (code /= ExitSuccess)
$ throw $ ErrorSystemCmdFailed cmd code strOut strErr
systemTeeIO
:: Bool
-> String
-> String
-> IO (ExitCode, String, String)
systemTeeIO tee cmd strIn
= do trace $ "systemTeeIO " ++ show tee ++ ": " ++ cmd
trace $ "systemTeeIO: Creating process"
(Just hInWrite, Just hOutRead, Just hErrRead, phProc)
<- createProcess
$ CreateProcess
{ cmdspec = ShellCommand cmd
, cwd = Nothing
, env = Nothing
, std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
, close_fds = False }
hPutStr hInWrite strIn
chanOut <- newChan
chanErr <- newChan
semOut <- newQSem 0
semErr <- newQSem 0
chanOutAcc <- dupChan chanOut
chanErrAcc <- dupChan chanErr
_tidOut <- forkIO $ streamIn hOutRead chanOut
_tidErr <- forkIO $ streamIn hErrRead chanErr
_tidStream <- forkIO $ streamOuts
[ (chanOut, if tee then Just stdout else Nothing, semOut)
, (chanErr, if tee then Just stderr else Nothing, semErr) ]
code <- waitForProcess phProc
trace $ "systemTeeIO: Process done, code = " ++ show code
trace $ "systemTeeIO: Waiting for sems"
mapM_ waitQSem [semOut, semErr]
trace $ "systemTeeIO: Getting output"
strOut <- liftM (concat . slurpUntilNothing) $ getChanContents chanOutAcc
strErr <- liftM (concat . slurpUntilNothing) $ getChanContents chanErrAcc
trace $ "systemTeeIO stdout: " ++ strOut
trace $ "systemTeeIO stderr: " ++ strErr
trace $ "systemTeeIO: All done"
code `seq` strOut `seq` strErr `seq`
return (code, strOut, strErr)
slurpUntilNothing :: [Maybe a] -> [a]
slurpUntilNothing xx
= case xx of
[] -> []
Nothing : _ -> []
Just x : xs -> x : slurpUntilNothing xs