{-# LANGUAGE PatternGuards, BangPatterns #-} -- | Running system commands. On some platforms this may cause the command to be executed directly, so -- shell tricks won't work. The `Build` monad can be made to log commands executed with all versions -- of `system` by setting `buildConfigLogSystem` in the `BuildConfig` passed to `runBuildPrintWithConfig`. -- -- We define a lot of wrappers because executing system commands is the bread-and-butter of -- buildbots, and we usually need all the versions... module BuildBox.Command.System ( module System.Exit -- * Wrappers , system , systemq , ssystem , ssystemq , sesystem , sesystemq , systemTee , systemTeeLog , ssystemTee , systemTeeIO -- * The real function , systemTeeLogIO) where import BuildBox.Command.System.Internals import BuildBox.Build import Control.Concurrent import Control.Concurrent.STM.TChan import Control.Monad import Control.Monad.STM import System.Exit import System.IO import Data.ByteString (ByteString) import BuildBox.Data.Log (Log) import System.Process hiding (system) import qualified BuildBox.Data.Log as Log import qualified Data.Text.Encoding as Text debug :: Bool debug = False trace :: String -> IO () trace s = when debug $ putStrLn s -- Wrappers --------------------------------------------------------------------------------------- -- | Run a system command, -- returning its exit code and what it wrote to @stdout@ and @stderr@. system :: String -> Build (ExitCode, String, String) system cmd = do (code, logOut, logErr) <- systemTeeLog True cmd Log.empty return (code, Log.toString logOut, Log.toString logErr) -- | Quietly run a system command, -- returning its exit code and what it wrote to @stdout@ and @stderr@. systemq :: String -> Build (ExitCode, String, String) systemq cmd = do (code, logOut, logErr) <- systemTeeLog False cmd Log.empty return (code, Log.toString logOut, Log.toString logErr) -- | Run a successful system command, -- returning what it wrote to @stdout@ and @stderr@. -- If the exit code is `ExitFailure` then throw an error in the `Build` monad. ssystem :: String -> Build (String, String) ssystem cmd = do (code, logOut, logErr) <- systemTeeLog True cmd Log.empty when (code /= ExitSuccess) $ throw $ ErrorSystemCmdFailed cmd code logOut logErr return (Log.toString logOut, Log.toString logErr) -- | Quietly run a successful system command, -- returning what it wrote to @stdout@ and @stderr@. -- If the exit code is `ExitFailure` then throw an error in the `Build` monad. ssystemq :: String -> Build (String, String) ssystemq cmd = do (code, logOut, logErr) <- systemTeeLog False cmd Log.empty when (code /= ExitSuccess) $ throw $ ErrorSystemCmdFailed cmd code logOut logErr return (Log.toString logOut, Log.toString logErr) -- | Run a successful system command, returning what it wrote to its @stdout@. -- If anything was written to @stderr@ then treat that as failure. -- If it fails due to writing to @stderr@ or returning `ExitFailure` -- then throw an error in the `Build` monad. sesystem :: String -> Build String sesystem cmd = do (code, logOut, logErr) <- systemTeeLog True cmd Log.empty when (code /= ExitSuccess || (not $ Log.null logErr)) $ throw $ ErrorSystemCmdFailed cmd code logOut logErr return $ Log.toString logOut -- | Quietly run a successful system command, returning what it wrote to its @stdout@. -- If anything was written to @stderr@ then treat that as failure. -- If it fails due to writing to @stderr@ or returning `ExitFailure` -- then throw an error in the `Build` monad. sesystemq :: String -> Build String sesystemq cmd = do (code, logOut, logErr) <- systemTeeLog False cmd Log.empty when (code /= ExitSuccess || (not $ Log.null logErr)) $ throw $ ErrorSystemCmdFailed cmd code logOut logErr return $ Log.toString logOut -- Tee versions ----------------------------------------------------------------------------------- -- | Like `systemTeeIO`, but in the `Build` monad. systemTee :: Bool -> String -> String -> Build (ExitCode, String, String) systemTee tee cmd strIn = do logSystem cmd io $ systemTeeIO tee cmd strIn -- | Like `systemTeeLogIO`, but in the `Build` monad. systemTeeLog :: Bool -> String -> Log -> Build (ExitCode, Log, Log) systemTeeLog tee cmd logIn = do logSystem cmd io $ systemTeeLogIO tee cmd logIn -- | Like `systemTeeIO`, but in the `Build` monad and throw an error if it returns `ExitFailure`. ssystemTee :: Bool -> String -> String -> Build () ssystemTee tee cmd strIn = do (code, logOut, logErr) <- systemTeeLog tee cmd (Log.fromString strIn) when (code /= ExitSuccess) $ throw $ ErrorSystemCmdFailed cmd code logOut logErr -- | Like `systemTeeLogIO`, but with strings. systemTeeIO :: Bool -> String -> String -> IO (ExitCode, String, String) systemTeeIO tee cmd strIn = do (code, logOut, logErr) <- systemTeeLogIO tee cmd $ Log.fromString strIn return (code, Log.toString logOut, Log.toString logErr) -- | Run a system command, returning its `ExitCode` and what was written to @stdout@ and @stderr@. systemTeeLogIO :: Bool -- ^ Whether @stdout@ and @stderr@ should be forwarded to the parent process. -> String -- ^ Command to run. -> Log -- ^ What to pass to the command's @stdin@. -> IO (ExitCode, Log, Log) systemTeeLogIO tee cmd logIn = do trace $ "systemTeeIO " ++ show tee ++ ": " ++ cmd -- Create some new pipes for the process to write its stdout and stderr to. 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 , create_group = False , delegate_ctlc = False } -- Push input into in handle. Close the handle afterwards to ensure the -- process gets sent the EOF character. hPutStr hInWrite $ Log.toString logIn hClose hInWrite -- To implement the tee-like behavior we'll fork some threads that read lines from the -- processes stdout and stderr and write them to these channels. -- When they hit EOF they signal this via the semaphores. chanOut <- newTChanIO chanErr <- newTChanIO semOut <- newQSem 0 semErr <- newQSem 0 -- Make duplicates of the above, which will store everything -- written to them. This gives us the copy to return from the fn. chanOutAcc <- atomically $ dupTChan chanOut chanErrAcc <- atomically $ dupTChan chanErr -- Fork threads to read from the process handles and write to our channels. _tidOut <- forkIO $ streamIn hOutRead chanOut _tidErr <- forkIO $ streamIn hErrRead chanErr -- If tee-like behavior is turned on, we forward what the process writes to -- its stdout and stderr to the parent. _tidStream <- forkIO $ streamOuts [ (chanOut, if tee then Just stdout else Nothing, semOut) , (chanErr, if tee then Just stderr else Nothing, semErr) ] -- Wait for the main process to complete. code <- waitForProcess phProc trace $ "systemTeeIO: Process done, code = " ++ show code trace $ "systemTeeIO: Waiting for sems" -- Wait for the tee processes to finish. -- We need to do this to avoid corrupted output on the console due to our forwarding -- threads writing at the same time as successing Build commands. mapM_ waitQSem [semOut, semErr] trace $ "systemTeeIO: Getting output" -- Get what was written to its stdout and stderr. -- getChanContents is a lazy read, so don't pull from the channel after -- seeing a Nothing else we'll block forever. logOut <- slurpChan chanOutAcc Log.empty logErr <- slurpChan chanErrAcc Log.empty trace $ "systemTeeIO stdout: " ++ Log.toString logOut trace $ "systemTeeIO stderr: " ++ Log.toString logErr trace $ "systemTeeIO: All done" hClose hOutRead hClose hErrRead code `seq` logOut `seq` logErr `seq` return (code, logOut, logErr) slurpChan :: TChan (Maybe ByteString) -> Log -> IO Log slurpChan !chan !ll = do mBS <- atomically $ readTChan chan case mBS of Nothing -> return ll Just bs -> slurpChan chan (ll Log.|> Text.decodeUtf8 bs)