{-# 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...moduleBuildBox.Command.System(moduleSystem.Exit-- * Wrappers,system,systemq,ssystem,ssystemq,sesystem,sesystemq,systemTee,systemTeeLog,ssystemTee,systemTeeIO-- * The real function,systemTeeLogIO)whereimportBuildBox.Command.System.InternalsimportBuildBox.BuildimportControl.ConcurrentimportControl.Concurrent.STM.TChanimportControl.MonadimportControl.Monad.STMimportSystem.ExitimportSystem.IOimportData.ByteString.Char8(ByteString)importBuildBox.Data.Log(Log)importSystem.Processhiding(system)importqualifiedBuildBox.Data.LogasLogdebug::Booldebug=Falsetrace::String->IO()traces=whendebug$putStrLns-- Wrappers ----------------------------------------------------------------------------------------- | Run a system command, -- returning its exit code and what it wrote to @stdout@ and @stderr@.system::String->Build(ExitCode,String,String)systemcmd=do(code,logOut,logErr)<-systemTeeLogTruecmdLog.emptyreturn(code,Log.toStringlogOut,Log.toStringlogErr)-- | Quietly run a system command,-- returning its exit code and what it wrote to @stdout@ and @stderr@.systemq::String->Build(ExitCode,String,String)systemqcmd=do(code,logOut,logErr)<-systemTeeLogFalsecmdLog.emptyreturn(code,Log.toStringlogOut,Log.toStringlogErr)-- | 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)ssystemcmd=do(code,logOut,logErr)<-systemTeeLogTruecmdLog.emptywhen(code/=ExitSuccess)$throw$ErrorSystemCmdFailedcmdcodelogOutlogErrreturn(Log.toStringlogOut,Log.toStringlogErr)-- | 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)ssystemqcmd=do(code,logOut,logErr)<-systemTeeLogFalsecmdLog.emptywhen(code/=ExitSuccess)$throw$ErrorSystemCmdFailedcmdcodelogOutlogErrreturn(Log.toStringlogOut,Log.toStringlogErr)-- | 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->BuildStringsesystemcmd=do(code,logOut,logErr)<-systemTeeLogTruecmdLog.emptywhen(code/=ExitSuccess||(not$Log.nulllogErr))$throw$ErrorSystemCmdFailedcmdcodelogOutlogErrreturn$Log.toStringlogOut-- | 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->BuildStringsesystemqcmd=do(code,logOut,logErr)<-systemTeeLogFalsecmdLog.emptywhen(code/=ExitSuccess||(not$Log.nulllogErr))$throw$ErrorSystemCmdFailedcmdcodelogOutlogErrreturn$Log.toStringlogOut-- Tee versions ------------------------------------------------------------------------------------- | Like `systemTeeIO`, but in the `Build` monad.systemTee::Bool->String->String->Build(ExitCode,String,String)systemTeeteecmdstrIn=dologSystemcmdio$systemTeeIOteecmdstrIn-- | Like `systemTeeLogIO`, but in the `Build` monad.systemTeeLog::Bool->String->Log->Build(ExitCode,Log,Log)systemTeeLogteecmdlogIn=dologSystemcmdio$systemTeeLogIOteecmdlogIn-- | Like `systemTeeIO`, but in the `Build` monad and throw an error if it returns `ExitFailure`.ssystemTee::Bool->String->String->Build()ssystemTeeteecmdstrIn=do(code,logOut,logErr)<-systemTeeLogteecmd(Log.fromStringstrIn)when(code/=ExitSuccess)$throw$ErrorSystemCmdFailedcmdcodelogOutlogErr-- | Like `systemTeeLogIO`, but with strings.systemTeeIO::Bool->String->String->IO(ExitCode,String,String)systemTeeIOteecmdstrIn=do(code,logOut,logErr)<-systemTeeLogIOteecmd$Log.fromStringstrInreturn(code,Log.toStringlogOut,Log.toStringlogErr)-- | 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)systemTeeLogIOteecmdlogIn=dotrace$"systemTeeIO "++showtee++": "++cmd-- Create some new pipes for the process to write its stdout and stderr to.trace$"systemTeeIO: Creating process"(JusthInWrite,JusthOutRead,JusthErrRead,phProc)<-createProcess$CreateProcess{cmdspec=ShellCommandcmd,cwd=Nothing,env=Nothing,std_in=CreatePipe,std_out=CreatePipe,std_err=CreatePipe,close_fds=False,create_group=False}-- Push input into in handle. Close the handle afterwards to ensure the-- process gets sent the EOF character.hPutStrhInWrite$Log.toStringlogInhClosehInWrite-- 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<-newTChanIOchanErr<-newTChanIOsemOut<-newQSem0semErr<-newQSem0-- Make duplicates of the above, which will store everything-- written to them. This gives us the copy to return from the fn.chanOutAcc<-atomically$dupTChanchanOutchanErrAcc<-atomically$dupTChanchanErr-- Fork threads to read from the process handles and write to our channels._tidOut<-forkIO$streamInhOutReadchanOut_tidErr<-forkIO$streamInhErrReadchanErr-- 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,ifteethenJuststdoutelseNothing,semOut),(chanErr,ifteethenJuststderrelseNothing,semErr)]-- Wait for the main process to complete.code<-waitForProcessphProctrace$"systemTeeIO: Process done, code = "++showcodetrace$"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<-slurpChanchanOutAccLog.emptylogErr<-slurpChanchanErrAccLog.emptytrace$"systemTeeIO stdout: "++Log.toStringlogOuttrace$"systemTeeIO stderr: "++Log.toStringlogErrtrace$"systemTeeIO: All done"hClosehOutReadhClosehErrReadcode`seq`logOut`seq`logErr`seq`return(code,logOut,logErr)slurpChan::TChan(MaybeByteString)->Log->IOLogslurpChan!chan!ll=domStr<-atomically$readTChanchancasemStrofNothing->returnllJuststr->slurpChanchan(llLog.|>str)