diff --git a/BuildBox/Build/BuildError.hs b/BuildBox/Build/BuildError.hs --- a/BuildBox/Build/BuildError.hs +++ b/BuildBox/Build/BuildError.hs @@ -10,6 +10,7 @@ import System.Exit import BuildBox.Data.Log (Log) import qualified BuildBox.Data.Log as Log +import Prelude hiding ((<>)) -- BuildError ------------------------------------------------------------------------------------- @@ -24,12 +25,12 @@ , buildErrorCode :: ExitCode , buildErrorStdout :: Log , buildErrorStderr :: Log } - + -- | Some miscellanous IO action failed. | ErrorIOError IOError -- | Some property `check` was supposed to return the given boolean value, but it didn't. - | forall prop. Show prop => ErrorCheckFailed Bool prop + | forall prop. Show prop => ErrorCheckFailed Bool prop -- | A build command needs the following file to continue. -- This can be used for writing make-like bots. @@ -37,9 +38,9 @@ deriving Typeable instance Exception BuildError - + instance Pretty BuildError where ppr err = case err of @@ -47,11 +48,11 @@ -> text "Other error: " <> text str ErrorSystemCmdFailed{} - -> vcat + -> vcat $ [ text "System command failure." , text " command: " <> (text $ buildErrorCmd err) , text " exit code: " <> (text $ show $ buildErrorCode err) - , blank ] + , blank ] ++ (if (not $ Log.null $ buildErrorStdout err) then [ text "-- stdout (last 10 lines) ------------------------------------------------------" @@ -67,7 +68,7 @@ || (not $ Log.null $ buildErrorStderr err)) then [ text "--------------------------------------------------------------------------------" ] else []) - + ErrorIOError ioerr -> text "IO error: " <> (text $ show ioerr) diff --git a/BuildBox/Command/Environment.hs b/BuildBox/Command/Environment.hs --- a/BuildBox/Command/Environment.hs +++ b/BuildBox/Command/Environment.hs @@ -4,7 +4,7 @@ ( -- * Build Environment Environment(..) , getEnvironmentWith - + -- * Build platform , Platform(..) , getHostPlatform @@ -13,7 +13,7 @@ , getHostProcessor , getHostOS , getHostRelease - + -- * Software versions , getVersionGHC , getVersionGCC) @@ -22,11 +22,12 @@ import BuildBox.Command.System import BuildBox.Command.File import BuildBox.Pretty +import Prelude hiding ((<>)) -- Environment ------------------------------------------------------------------------------------ -- | The environment consists of the `Platform`, and some tool versions. -data Environment +data Environment = Environment { environmentPlatform :: Platform , environmentVersions :: [(String, String)] } @@ -37,32 +38,32 @@ ppr env = hang (ppr "Environment") 2 $ vcat [ ppr $ environmentPlatform env - , hang (ppr "Versions") 2 - $ vcat - $ map (\(name, ver) -> ppr name <+> ppr ver) + , hang (ppr "Versions") 2 + $ vcat + $ map (\(name, ver) -> ppr name <+> ppr ver) $ environmentVersions env ] -- | Get the current environment, including versions of these tools. -getEnvironmentWith +getEnvironmentWith :: [(String, Build String)] -- ^ List of tool names and commands to get their versions. -> Build Environment - -getEnvironmentWith nameGets + +getEnvironmentWith nameGets = do platform <- getHostPlatform versions <- mapM (\(name, get) -> do ver <- get return (name, ver)) $ nameGets - + return $ Environment - { environmentPlatform = platform + { environmentPlatform = platform , environmentVersions = versions } - + -- Platform --------------------------------------------------------------------------------------- -- | Generic information about the platform we're running on. data Platform @@ -73,8 +74,8 @@ , platformHostOS :: String , platformHostRelease :: String } deriving (Show, Read) - - + + instance Pretty Platform where ppr plat = hang (ppr "Platform") 2 $ vcat @@ -86,21 +87,21 @@ -- | Get information about the host platform. getHostPlatform :: Build Platform -getHostPlatform +getHostPlatform = do name <- getHostName arch <- getHostArch processor <- getHostProcessor os <- getHostOS release <- getHostRelease - + return $ Platform { platformHostName = name , platformHostArch = arch , platformHostProcessor = processor , platformHostOS = os , platformHostRelease = release } - + -- Platform Tests --------------------------------------------------------------------------------- -- | Get the name of this host, using @uname@. getHostName :: Build String @@ -149,8 +150,8 @@ = do check $ HasExecutable path str <- sesystemq $ path ++ " --version" return $ init str - --- | Get the version of this GCC, or throw an error if it can't be found. + +-- | Get the version of this GCC, or throw an error if it can't be found. getVersionGCC :: FilePath -> Build String getVersionGCC path = do check $ HasExecutable path diff --git a/BuildBox/Command/Mail.hs b/BuildBox/Command/Mail.hs --- a/BuildBox/Command/Mail.hs +++ b/BuildBox/Command/Mail.hs @@ -1,5 +1,5 @@ --- | Sending email. +-- | Sending email. -- If you're on a system with a working @sendmail@ then use that. -- Otherwise, the stand-alone @msmtp@ server is easy to set up. -- Get @msmtp@ here: @@ -18,6 +18,7 @@ import Data.Time.LocalTime import Data.Time.Format import Data.Time.Calendar +import Prelude hiding ((<>)) -- | An email message that we can send. @@ -56,7 +57,7 @@ -- Fill in the date and message id based on the current time. -- Valid dates and message ids are needed to prevent the mail -- being bounced by anti-spam systems. -createMailWithCurrentTime +createMailWithCurrentTime :: String -- ^ ''from'' field. Should be an email address. -> String -- ^ ''to'' field. Should be an email address. -> String -- ^ Subject line. @@ -76,7 +77,7 @@ let secTime = utctDayTime utime let messageId = "<" ++ show dayNum ++ "." ++ (init $ show secTime) ++ "@" ++ hostName ++ ">" - + return $ Mail { mailFrom = from , mailTo = to @@ -106,19 +107,19 @@ sendMailWithMailer :: Mail -> Mailer -> Build () sendMailWithMailer mail mailer = case mailer of - MailerSendmail{} + MailerSendmail{} -> ssystemTee False (mailerPath mailer ++ " -t ") -- read recipients from the mail (render $ renderMail mail) - MailerMSMTP{} + MailerMSMTP{} -> ssystemTee False - (mailerPath mailer + (mailerPath mailer ++ " -t " -- read recipients from the mail ++ (maybe "" (\port -> " --port=" ++ show port) $ mailerPort mailer)) (render $ renderMail mail) - + diff --git a/BuildBox/Command/System.hs b/BuildBox/Command/System.hs --- a/BuildBox/Command/System.hs +++ b/BuildBox/Command/System.hs @@ -1,13 +1,13 @@ {-# LANGUAGE PatternGuards, BangPatterns #-} --- | Running system commands. On some platforms this may cause the command to be executed directly, so +-- | 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 +-- 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 BuildBox.Command.System ( module System.Exit -- * Wrappers @@ -47,7 +47,7 @@ -- Wrappers --------------------------------------------------------------------------------------- --- | Run a system command, +-- | Run a system command, -- returning its exit code and what it wrote to @stdout@ and @stderr@. system :: String -> Build (ExitCode, String, String) system cmd @@ -64,7 +64,7 @@ --- | Run a successful system command, +-- | 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) @@ -91,7 +91,7 @@ -- | Run a successful system command, returning what it wrote to its @stdout@. --- If anything was written to @stderr@ then treat that as failure. +-- 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 @@ -103,7 +103,7 @@ 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 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 @@ -159,7 +159,7 @@ -- 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 $ CreateProcess { cmdspec = ShellCommand cmd , cwd = Nothing @@ -167,22 +167,23 @@ , std_in = CreatePipe , std_out = CreatePipe , std_err = CreatePipe - , close_fds = False + , close_fds = False , create_group = False , delegate_ctlc = False , detach_console = False , create_new_console = False , new_session = False , child_group = Nothing - , child_user = Nothing } + , child_user = Nothing + , use_process_jobs = True } -- 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. + -- processes stdout and stderr and write them to these channels. -- When they hit EOF they signal this via the semaphores. chanOut <- newTChanIO chanErr <- newTChanIO @@ -227,7 +228,7 @@ trace $ "systemTeeIO: All done" hClose hOutRead hClose hErrRead - code `seq` logOut `seq` logErr `seq` + code `seq` logOut `seq` logErr `seq` return (code, logOut, logErr) slurpChan :: TChan (Maybe ByteString) -> Log -> IO Log diff --git a/BuildBox/Pretty.hs b/BuildBox/Pretty.hs --- a/BuildBox/Pretty.hs +++ b/BuildBox/Pretty.hs @@ -15,7 +15,9 @@ import Text.Printf import Data.Time import Control.Monad +import Prelude hiding ((<>)) + -- Things that can be pretty printed class Pretty a where ppr :: a -> Doc @@ -23,21 +25,21 @@ -- Basic instances instance Pretty Doc where ppr = id - + instance Pretty Float where ppr = text . show instance Pretty Int where ppr = int - + instance Pretty Integer where ppr = text . show instance Pretty UTCTime where ppr = text . show - + instance Pretty a => Pretty [a] where - ppr xx + ppr xx = lbrack <> (hcat $ punctuate (text ", ") (map ppr xx)) <> rbrack instance Pretty String where @@ -48,7 +50,7 @@ padRc :: Int -> Char -> Doc -> Doc padRc n c str = (text $ replicate (n - length (render str)) c) <> str - + -- | Right justify a string with spaces. padR :: Int -> Doc -> Doc diff --git a/buildbox.cabal b/buildbox.cabal --- a/buildbox.cabal +++ b/buildbox.cabal @@ -1,5 +1,5 @@ Name: buildbox -Version: 2.1.9.3 +Version: 2.1.9.4 License: BSD3 License-file: LICENSE Author: Ben Lippmeier @@ -21,7 +21,7 @@ Library Build-Depends: - base >= 4.4 && < 4.10, + base >= 4.4 && < 4.12, containers >= 0.4 && < 0.6, time >= 1.2 && < 1.9, directory >= 1.1 && < 1.4, @@ -29,8 +29,8 @@ mtl >= 2.2 && < 2.3, old-locale >= 1.0 && < 1.1, process >= 1.2 && < 1.7, - temporary >= 1.2 && < 1.3, - exceptions >= 0.8 && < 0.9, + temporary >= 1.2 && < 1.4, + exceptions >= 0.8 && < 0.11, pretty >= 1.1 && < 1.2, stm >= 2.4 && < 2.5, text >= 1.2 && < 1.3