packages feed

buildbox (empty) → 1.0.0.0

raw patch · 23 files changed

+1934/−0 lines, 23 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, mtl, old-locale, pretty, process, time, unix

Files

+ BuildBox.hs view
@@ -0,0 +1,25 @@++module BuildBox+	( module BuildBox.Build+	, module BuildBox.Benchmark+	, module BuildBox.Pretty+	, module BuildBox.Command.Sleep+	, module BuildBox.Command.System+	, module BuildBox.Command.Network+	, module BuildBox.Command.Mail+	, module BuildBox.Command.Environment+	, module BuildBox.Command.File+	, module BuildBox.Cron+	, module BuildBox.Time)+where+import BuildBox.Build+import BuildBox.Benchmark+import BuildBox.Pretty+import BuildBox.Command.Sleep+import BuildBox.Command.System+import BuildBox.Command.Network+import BuildBox.Command.Mail+import BuildBox.Command.Environment+import BuildBox.Command.File+import BuildBox.Cron+import BuildBox.Time
+ BuildBox/Benchmark.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE PatternGuards #-}++-- | Running benchmarks and collecting timings. +--+--  These functions expect the given `Build` commands to succeed,+--  throwing an error if they don't. If you're not sure whether your command will succeed then test it first.+module BuildBox.Benchmark+	( module BuildBox.Benchmark.TimeAspect+	, module BuildBox.Benchmark.Pretty+	, module BuildBox.Benchmark.Compare+	+	-- * Types+	, Benchmark(..)+	, Timing(..)+	, BenchRunResult(..)+	, BenchResult(..)+	+	-- * Benchmarking+	, runTimedCommand+	, runBenchmarkOnce+	, outRunBenchmarkOnce+	, outRunBenchmarkAgainst+	, outRunBenchmarkWith)+where+import BuildBox.Build	+import BuildBox.Pretty+import BuildBox.Benchmark.Base+import BuildBox.Benchmark.TimeAspect+import BuildBox.Benchmark.Pretty+import BuildBox.Benchmark.Compare+import Data.Time+import Data.List+import Control.Monad+++-- Running Commands -------------------------------------------------------------------------------+-- | Run a command, returning its elapsed time.+runTimedCommand +	:: Build a+	-> Build (NominalDiffTime, a) +		+runTimedCommand cmd+ = do	start	<- io $ getCurrentTime+	result	<- cmd+	finish	<- io $ getCurrentTime+	return (diffUTCTime finish start, result)+++-- | Run a benchmark once.+runBenchmarkOnce+	:: Benchmark +	-> Build BenchRunResult+	+runBenchmarkOnce bench+ = do	-- Run the setup command+	benchmarkSetup bench++	(diffTime, mKernelTimings)	+		<- runTimedCommand +		$  benchmarkCommand bench+	+	benchmarkCheck bench+	+	return	$ BenchRunResult+		{ benchRunResultElapsed		= fromRational $ toRational diffTime+		, benchRunResultKernel		= mKernelTimings }+++-- | Run a benchmark once, logging activity and timings to the console.+outRunBenchmarkOnce+	:: Benchmark+	-> Build BenchRunResult+	+outRunBenchmarkOnce bench+ = do	out $ "Running " ++ benchmarkName bench ++ "..."+	result	<- runBenchmarkOnce bench+	outLn "ok"+	outLn $ text "    elapsed        = " <> (pprFloatTime $ benchRunResultElapsed result)+		+	maybe (return ()) (\t -> outLn $ text "    kernel elapsed = " <> pprFloatTime t) +		$ takeTimeAspectOfBenchRunResult TimeAspectKernelElapsed result++	maybe (return ()) (\t -> outLn $ text "    kernel cpu     = " <> pprFloatTime t) +		$ takeTimeAspectOfBenchRunResult TimeAspectKernelCpu result++	maybe (return ()) (\t -> outLn $ text "    kernel system  = " <> pprFloatTime t)+		$ takeTimeAspectOfBenchRunResult TimeAspectKernelSys result+	+	outBlank+	+	return result+++-- | Run a benchmark several times, logging activity to the console.+--   Optionally print a comparison with a prior results.+outRunBenchmarkAgainst+	:: Int			-- ^ Number of iterations.+	-> Maybe BenchResult	-- ^ Optional previous result for comparison.+	-> Benchmark		-- ^ Benchmark to run.+	-> Build BenchResult+	+outRunBenchmarkAgainst iterations mPrior bench  + = do	out $ "Running " ++ benchmarkName bench ++ " " ++ show iterations ++ " times..."+	runResults	<- replicateM iterations (runBenchmarkOnce bench) +	outLn "ok"++	let result	= BenchResult+			{ benchResultName	= benchmarkName bench+			, benchResultRuns	= runResults }++	outLn pprBenchResultAspectHeader+	+	maybe (return ()) outLn	$ pprBenchResultAspect TimeAspectElapsed	mPrior result+	maybe (return ()) outLn	$ pprBenchResultAspect TimeAspectKernelElapsed	mPrior result+	maybe (return ()) outLn	$ pprBenchResultAspect TimeAspectKernelCpu	mPrior result+	maybe (return ()) outLn	$ pprBenchResultAspect TimeAspectKernelSys	mPrior result+		+	outBlank+	return	result+++-- | Run a benchmark serveral times, logging activity to the console.+--   Also lookup prior results for comparison from the given list.+--   If there is no matching entry then run the benchmark anyway, but don't print the comparison.+outRunBenchmarkWith+	:: Int			-- ^ Number of times to run each benchmark to get averages.+	-> [BenchResult]	-- ^ List of prior results.+	-> Benchmark		-- ^ The benchmark to run.+	-> Build BenchResult++outRunBenchmarkWith iterations priors bench+ = let	mPrior	= find (\b -> benchResultName b == benchmarkName bench) priors+   in	outRunBenchmarkAgainst iterations mPrior bench+	+
+ BuildBox/Benchmark/Base.hs view
@@ -0,0 +1,78 @@+{-# OPTIONS_HADDOCK hide #-}++module BuildBox.Benchmark.Base+	( Benchmark(..)+	, Timing(..)+	, BenchRunResult(..)+	, BenchResult(..))+where+import BuildBox.Build+import BuildBox.Pretty+import Control.Monad++-- | Describes a benchmark that we can run.+data Benchmark+	= Benchmark+	{ -- | A unique name for the benchmark.+	  benchmarkName		:: String++	  -- | Setup command to run before the main benchmark.+	, benchmarkSetup	:: Build ()++	  -- | The benchmark command to run. Only the time taken to run this part is measured.+	, benchmarkCommand	:: Build (Maybe Timing)++	  -- | Check \/ cleanup command to run after the main benchmark.+	, benchmarkCheck	:: Build ()+	}+++-- | Holds elapsed, cpu, and system timings (in seconds).+data Timing+	= Timing+	{ timingElapsed	:: Maybe Float+	, timingCpu	:: Maybe Float+	, timingSys	:: Maybe Float }+	deriving (Eq, Read, Show)+++-- | The result of running a benchmark once.+data BenchRunResult+	= BenchRunResult++	{ -- | The wall-clock time taken to run the benchmark (in seconds)+	  benchRunResultElapsed		:: Float++	  -- | Time that the benchmark itself reported was taken to run its kernel.+	, benchRunResultKernel		:: Maybe Timing }++	deriving (Show, Read)+++instance Pretty BenchRunResult where+ ppr result+	= hang (ppr "BenchRunResult") 2 $ vcat+	[ ppr "elapsed:        " <> (ppr $ benchRunResultElapsed result) +	, maybe empty (\r -> ppr "k.elapsed: " <> ppr r) +		$ join $ liftM timingElapsed $ benchRunResultKernel result++	, maybe empty (\r -> ppr "k.cpu:     " <> ppr r)+		$ join $ liftM timingCpu     $ benchRunResultKernel result++	, maybe empty (\r -> ppr "k.system:  " <> ppr r)+		$ join $ liftM timingSys     $ benchRunResultKernel result ]+	+	+-- | The result of running a benchmark several times.+--   We include the name of the original benchmark to it's easy to lookup the results.+data BenchResult+	= BenchResult+	{ benchResultName	:: String+	, benchResultRuns	:: [BenchRunResult] }+	deriving (Show, Read)++instance Pretty BenchResult where+ ppr result+	= hang (ppr "BenchResult") 2 $ vcat+	[ ppr $ benchResultName result+	, vcat $ map ppr $ benchResultRuns result ]
+ BuildBox/Benchmark/Compare.hs view
@@ -0,0 +1,50 @@++-- | Pretty printing comparisons of benchmark results.+module BuildBox.Benchmark.Compare+	( pprComparison+	, pprComparisons)+where+import BuildBox.Pretty+import BuildBox.Benchmark.Base+import BuildBox.Benchmark.Pretty+import BuildBox.Benchmark.TimeAspect+import Data.Maybe+import Data.List++-- | Pretty print a comparison of all the aspects of these two benchmark results.+--   The first result is the ``baseline'', while the second is the ``current'' one.+--   The numbers from the current results are printed, with a percentage relative to the baseline.+pprComparison :: BenchResult -> BenchResult -> Doc+pprComparison baseline current+ 	= vcat+	[ pprBenchResultAspectHeader+	, fromMaybe empty $ pprBenchResultAspect TimeAspectElapsed	 (Just baseline) current+	, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelElapsed (Just baseline) current+	, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelCpu	 (Just baseline) current+	, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelSys	 (Just baseline) current ]+++-- | Pretty print a comparison of all the aspects of these two benchmark results.+--   The first result is the ``baseline'' while the second is the ``current'' one.+--   All the numbers from the current results are printed, with a percentage relative to the+--   baseline if there is one. If there is no baseline for a particular result then we still+--   print the current one.+pprComparisons :: [BenchResult] -> [BenchResult] -> Doc+pprComparisons baselines currents+ = let	comparison current+	 = let	mBaseline = find (\b -> benchResultName b == benchResultName current)+			  $ baselines++	   in	vcat+		[ fromMaybe empty $ pprBenchResultAspect TimeAspectElapsed	 mBaseline current+		, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelElapsed mBaseline current+		, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelCpu	 mBaseline current+		, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelSys	 mBaseline current ]++   in	vcat+	[ nest 15 pprBenchResultAspectHeader+	, vcat	$ punctuate (text "\n")+		$ map (\c -> (text (benchResultName c) $$ (nest 15 $ comparison c)))+		$ currents ]++
+ BuildBox/Benchmark/Pretty.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE PatternGuards #-}++-- | Pretty printing benchmark results.+module BuildBox.Benchmark.Pretty+	( pprBenchResultAspectHeader+	, pprBenchResultAspect)+where+import BuildBox.Benchmark.Base+import BuildBox.Benchmark.TimeAspect+import BuildBox.Pretty++-- | Header to use when pretty printing benchmark results.+pprBenchResultAspectHeader :: Doc+pprBenchResultAspectHeader +	=  vcat+	[ text "    aspect       min   ref%   avg   ref%   max   ref%   spread% "+	, text "    ---------    ----------   ----------   ----------   ------- " ]+++-- | Pretty print an aspect of a benchmark result.+--   If the given aspect does not exist in the result then `Nothing`.+pprBenchResultAspect +	:: TimeAspect 			-- ^ Aspect of the result to print.+	-> Maybe BenchResult		-- ^ Optional prior result for comparison.+	-> BenchResult			-- ^ The result to print.+	-> Maybe Doc++pprBenchResultAspect aspect prior result+ 	| Just (tmin,  tavg,  tmax)	<- takeMinAvgMaxOfBenchResult aspect result+	, spread			<- tmax - tmin+	, spreadPercent			<- (floor $ (spread / tavg) * 100) :: Integer+	, Just result'			<- prior+	, Just (tmin', tavg', tmax')	<- takeMinAvgMaxOfBenchResult aspect result'+	= Just	$   text "    "+		<>  padL 10 (ppr aspect)+		<+> (padR 12 $ pprFloatRef tmin tmin')+		<+> (padR 12 $ pprFloatRef tavg tavg')+		<+> (padR 12 $ pprFloatRef tmax tmax')+		<+> (padR 8  $ ppr spreadPercent)++ 	| Just (tmin, tavg, tmax)	<- takeMinAvgMaxOfBenchResult aspect result+	, spread			<- tmax - tmin+	, spreadPercent			<- (floor $ (spread / tavg) * 100) :: Integer+	= Just	$   text "    "+		<>  padL 10 (ppr aspect)+		<+> (padR 12 $ (pprFloatTime tmin <> text "     "))+		<+> (padR 12 $ (pprFloatTime tavg <> text "     "))+		<+> (padR 12 $ (pprFloatTime tmax <> text "     "))+		<+> (padR 8 $ ppr spreadPercent)+	+	| otherwise+	= Nothing
+ BuildBox/Benchmark/TimeAspect.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE PatternGuards #-}++-- | Dealing with aspects of timing results.+module BuildBox.Benchmark.TimeAspect+	( TimeAspect(..)+	, takeTimeAspectOfBenchRunResult+	, takeAvgTimeOfBenchResult+	, takeMinTimeOfBenchResult+	, takeMaxTimeOfBenchResult+	, takeMinAvgMaxOfBenchResult)+where+import BuildBox.Benchmark.Base+import BuildBox.Pretty+import Control.Monad+++-- | Aspects of a benchmark runtime we can talk about.+data TimeAspect+	= TimeAspectElapsed+	| TimeAspectKernelElapsed+	| TimeAspectKernelCpu+	| TimeAspectKernelSys+	deriving (Show, Read, Enum)+++-- | Get the pretty name of a TimeAspect.+instance Pretty TimeAspect where+ ppr aspect+  = case aspect of+	TimeAspectElapsed		-> ppr "elapsed"+	TimeAspectKernelElapsed		-> ppr "k.elapsed"+	TimeAspectKernelCpu		-> ppr "k.cpu"+	TimeAspectKernelSys		-> ppr "k.system"+++-- | Get a particular aspect of a benchmark result.+takeTimeAspectOfBenchRunResult :: TimeAspect -> BenchRunResult -> Maybe Float+takeTimeAspectOfBenchRunResult aspect result+ = case aspect of+	TimeAspectElapsed	-> Just $ benchRunResultElapsed result+	TimeAspectKernelElapsed	-> join $ liftM timingElapsed $ benchRunResultKernel result+	TimeAspectKernelCpu	-> join $ liftM timingCpu     $ benchRunResultKernel result+	TimeAspectKernelSys	-> join $ liftM timingSys     $ benchRunResultKernel result+++-- | Get the average runtime from a benchmark result.+takeAvgTimeOfBenchResult :: TimeAspect -> BenchResult -> Maybe Float+takeAvgTimeOfBenchResult aspect result+ = let	mTimes	= sequence +		$ map (takeTimeAspectOfBenchRunResult aspect)+		$ benchResultRuns result+		+   in	liftM (\ts -> sum ts / (fromIntegral $ length ts)) mTimes+	++-- | Get the minimum runtime from a benchmark result.+takeMinTimeOfBenchResult :: TimeAspect -> BenchResult -> Maybe Float+takeMinTimeOfBenchResult aspect result+ = let	mTimes	= sequence+		$ map (takeTimeAspectOfBenchRunResult aspect)+		$ benchResultRuns result++   in	liftM (\ts -> minimum ts) mTimes+++-- | Get the maximum runtime from a benchmark result.+takeMaxTimeOfBenchResult :: TimeAspect -> BenchResult -> Maybe Float+takeMaxTimeOfBenchResult aspect result+ = let	mTimes	= sequence+		$ map (takeTimeAspectOfBenchRunResult aspect)+		$ benchResultRuns result++   in	liftM (\ts -> maximum ts) mTimes+++-- | Get the min, avg, and max runtimes from this benchmark result.+takeMinAvgMaxOfBenchResult :: TimeAspect -> BenchResult -> Maybe (Float, Float, Float)+takeMinAvgMaxOfBenchResult aspect result+	| Just tmin	<- takeMinTimeOfBenchResult aspect result+	, Just tavg	<- takeAvgTimeOfBenchResult aspect result+	, Just tmax	<- takeMaxTimeOfBenchResult aspect result+	= Just (tmin, tavg, tmax)+	+	| otherwise+	= Nothing+
+ BuildBox/Build.hs view
@@ -0,0 +1,26 @@++-- | Defines the main `Build` monad and common utils.+module BuildBox.Build +	( module BuildBox.Build.Testable+	, Build+	, BuildError(..)+	, BuildConfig(..)+	, buildConfigDefault+	, runBuild+	, runBuildPrint+	, runBuildPrintWithConfig+	, throw+	, io+	, logSystem+	, out+	, outLn+	, outBlank+	, outLine+	, outLINE+	, whenM)+where+import BuildBox.Build.Base+import BuildBox.Build.Testable++	+
+ BuildBox/Build/Base.hs view
@@ -0,0 +1,173 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE ExistentialQuantification #-}++module BuildBox.Build.Base where+import BuildBox.Pretty+import Control.Monad.Error+import Control.Monad.Reader+import System.IO+import System.IO.Error+import System.Exit++-- | The builder monad encapsulates and IO action that can fail with an error, +--   and also read some global configuration info.+type Build a 	= ErrorT BuildError (ReaderT BuildConfig IO) a++-- BuildError -------------------------------------------------------------------------------------+-- | The errors we recognise.+data BuildError+	-- | Some generic error+	= ErrorOther String++	-- | Some system command fell over, and it barfed out the given stdout and stderr.+	| ErrorSystemCmdFailed+		{ buildErrorCmd 	:: String+		, buildErrorCode	:: ExitCode+		, buildErrorStdout	:: String+		, buildErrorStderr	:: String }+		+	-- | Some other 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	++instance Error BuildError where+ strMsg s = ErrorOther s++instance Pretty BuildError where+ ppr err+  = case err of+	ErrorOther str+	 -> text "Other error: " <> text str++	ErrorSystemCmdFailed{}+	 -> vcat +		[ text "System command failure."+		, text "    command: " <> (text $ buildErrorCmd err)+		, text "  exit code: " <> (text $ show $ buildErrorCode err)+		, blank+		, if (not $ null $ buildErrorStdout err)+		   then vcat 	[ text "-- stdout (last 10 lines) ------------------------------------------------------"+				, vcat $ map text $ reverse $ take 10 $ reverse $ lines $ buildErrorStdout err]+		   else text ""+		, blank+		, if (not $ null $ buildErrorStderr err)+		   then vcat	[ text "-- stderr (last 10 lines) ------------------------------------------------------"+				, vcat $ map text $ reverse $ take 10 $ reverse $ lines $ buildErrorStderr err]+		   else text ""+		+		, 		  text "--------------------------------------------------------------------------------" ]+	+	ErrorIOError ioerr+	 -> text "IO error: " <> (text $ show ioerr)++	ErrorCheckFailed expected prop+	 -> text "Check failure: " <> (text $ show prop) <> (text " expected ") <> (text $ show expected)+++-- BuildConfig ------------------------------------------------------------------------------------+-- | Global builder configuration.+data BuildConfig+	= BuildConfig+	{ -- | Log all system commands executed to this file handle.+	  buildConfigLogSystem	:: Maybe Handle }++-- | The default build config.+buildConfigDefault :: BuildConfig+buildConfigDefault+	= BuildConfig+	{ buildConfigLogSystem	= Nothing }++-- | Log a system command to the handle in our `BuildConfig`, if any.+logSystem :: String -> Build ()+logSystem cmd+ = do	mHandle	<- asks buildConfigLogSystem+	case mHandle of+	 Nothing	-> return ()+	 Just handle	+	  -> do	io $ hPutStr   handle "buildbox system: "+		io $ hPutStrLn handle cmd+		return ()++-- Build ------------------------------------------------------------------------------------------+-- | Throw an error in the build monad.+throw :: BuildError -> Build a+throw	= throwError++-- | Run a build command.+runBuild :: Build a -> IO (Either BuildError a)+runBuild build+	= runReaderT (runErrorT build) buildConfigDefault+++-- | Run a build command, reporting whether it succeeded to the console.+--   If it succeeded then return Just the result, else Nothing.+runBuildPrint :: Build a -> IO (Maybe a)+runBuildPrint + 	= runBuildPrintWithConfig buildConfigDefault+++-- | Like `runBuildPrintWithConfig` but also takes a `BuildConfig`.+runBuildPrintWithConfig :: BuildConfig -> Build a -> IO (Maybe a)+runBuildPrintWithConfig config build+ = do	result	<- runReaderT (runErrorT build) config+	case result of+	 Left err+	  -> do	putStrLn "\nBuild failed"+		putStr   "  due to "+		putStrLn $ render $ ppr err+		return $ Nothing+		+	 Right x+	  -> do	putStrLn "Build succeeded."+		return $ Just x+++-- Utils ------------------------------------------------------------------------------------------+-- | Lift an IO action into the build monad.+--   If the action throws any exceptions they get caught and turned into+--   `ErrorIOError` exceptions in our `Build` monad.+io :: IO a -> Build a+io x+ = do	-- catch IOError exceptions+	result	<- liftIO $ try x+	+	case result of+	 Left err	-> throw $ ErrorIOError err+	 Right res	-> return res+++-- | Print some text to stdout.+out :: Pretty a => a -> Build ()+out str	+ = io + $ do	putStr   $ render $ ppr str+	hFlush stdout++-- | Print some text to stdout followed by a newline.+outLn :: Pretty a => a -> Build ()+outLn str	= io $ putStrLn $ render $ ppr str+++-- | Print a blank line to stdout+outBlank :: Build ()+outBlank	= out $ text "\n"+++-- | Print a @-----@ line to stdout +outLine :: Build ()+outLine 	= io $ putStr (replicate 80 '-' ++ "\n")+++-- | Print a @=====@ line to stdout+outLINE :: Build ()+outLINE		= io $ putStr (replicate 80 '=' ++ "\n")+++-- | Like `when`, but with teh monadz.+whenM :: Monad m => m Bool -> m () -> m ()+whenM cb cx+ = do	b	<- cb+	if b then cx else return ()+
+ BuildBox/Build/Testable.hs view
@@ -0,0 +1,58 @@++-- | Some property of the system we can test for.+--+--   They have `Show` instances so we can make nice error messages if a `check` fails.+module BuildBox.Build.Testable+	( Testable(..)+	, check+	, checkFalse+	, outCheckOk+	, outCheckFalseOk)+where+import BuildBox.Build.Base	+import Control.Monad.Error+++-- | Some testable property.+class Testable prop where+  test :: prop -> Build Bool++-- | Testable properties are checkable.+--   If the check returns false then throw an error.+check :: (Show prop, Testable prop) => prop -> Build ()+check prop+ = do	result	<- test prop+	if result+	 then return ()+	 else throwError $ ErrorCheckFailed True prop+++-- | Testable properties are checkable.+--   If the check returns true then throw an error.+checkFalse :: (Show prop, Testable prop) => prop -> Build ()+checkFalse prop+ = do	result	<- test prop+	if result+	 then throwError $ ErrorCheckFailed False prop+	 else return ()+	++-- | Check some property while printing what we're doing.+outCheckOk +	:: (Show prop, Testable prop) +	=> String -> prop -> Build ()++outCheckOk str prop+ = do	outLn str+	check prop+++-- | Check some property while printing what we're doing.+outCheckFalseOk +	:: (Show prop, Testable prop) +	=> String -> prop -> Build ()++outCheckFalseOk str prop+ = do	outLn str+	checkFalse prop+
+ BuildBox/Command/Environment.hs view
@@ -0,0 +1,160 @@++-- | Gathering information about the build environment.+module BuildBox.Command.Environment+	( -- * Build Environment+	  Environment(..)+	, getEnvironmentWith+	+	  -- * Build platform+	, Platform(..)+	, getHostPlatform+	, getHostName+	, getHostArch+	, getHostProcessor+	, getHostOS+	, getHostRelease+	+	  -- * Software versions+	, getVersionGHC+	, getVersionGCC)+where+import BuildBox.Build+import BuildBox.Command.System+import BuildBox.Command.File+import BuildBox.Pretty+++-- Environment ------------------------------------------------------------------------------------+-- | The environment consists of the `Platform`, and some tool versions.+data Environment +	= Environment+	{ environmentPlatform	:: Platform+	, environmentVersions	:: [(String, String)] }+	deriving (Show, Read)+++instance Pretty Environment where+ ppr env+	= hang (ppr "Environment") 2 $ vcat+	[ ppr 	$ environmentPlatform env+	, hang (ppr "Versions") 2 +		$ vcat +		$ map (\(name, ver) -> ppr name <+> ppr ver) +		$ environmentVersions env ]++++-- | Get the current environment, including versions of these tools.+getEnvironmentWith +	:: [(String, Build String)]	-- ^ List of tool names and commands to get their versions.+	-> Build Environment+	+getEnvironmentWith nameGets + = do	platform	<- getHostPlatform++	versions	<- mapM (\(name, get) -> do+					ver	<- get+					return	(name, ver))+			$  nameGets+			+	return	$ Environment+		{ environmentPlatform	= platform +		, environmentVersions	= versions }+	+++-- Platform ---------------------------------------------------------------------------------------+-- | Generic information about the platform we're running on.+data Platform+	= Platform+	{ platformHostName 	:: String+	, platformHostArch	:: String+	, platformHostProcessor	:: String+	, platformHostOS	:: String+	, platformHostRelease	:: String }+	deriving (Show, Read)+	+	+instance Pretty Platform where+ ppr plat+	= hang (ppr "Platform") 2 $ vcat+	[ ppr "host:      " <> (ppr $ platformHostName plat)+	, ppr "arch:      " <> (ppr $ platformHostArch plat)+	, ppr "processor: " <> (ppr $ platformHostProcessor plat)+	, ppr "system:    " <> (ppr $ platformHostOS plat) <+> (ppr $ platformHostRelease plat) ]+++-- | Get information about the host platform.+getHostPlatform :: Build Platform+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+getHostName+ = do	check $ HasExecutable "uname"+	name	<- qssystemOut "uname -n"+	return	$ init name+++-- | Get the host architecture, using @uname@.+getHostArch :: Build String+getHostArch+ = do	check $ HasExecutable "arch"+	name	<- qssystemOut "arch"+	return	$ init name+++-- | Get the host processor name, using @uname@.+getHostProcessor :: Build String+getHostProcessor+ = do	check $ HasExecutable "uname"+	name	<- qssystemOut "uname -p"+	return	$ init name+++-- | Get the host operating system, using @uname@.+getHostOS :: Build String+getHostOS+ = do	check $ HasExecutable "uname"+	os	<- qssystemOut "uname -s"+	return	$ init os+++-- | Get the host operating system release, using @uname@.+getHostRelease :: Build String+getHostRelease+ = do	check $ HasExecutable "uname"+	str	<- qssystemOut "uname -r"+	return	$ init str+++-- Software version tests -------------------------------------------------------------------------+-- | Get the version of this GHC, or throw an error if it can't be found.+getVersionGHC :: FilePath -> Build String+getVersionGHC path+ = do	check $ HasExecutable path+	str	<- qssystemOut $ path ++ " --version"+	return	$ init str+	+-- | 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+ 	str	<- qssystemOut $ path ++ " --version"+	return	$ head $ lines str++
+ BuildBox/Command/File.hs view
@@ -0,0 +1,114 @@++-- | Working with the file system.+module BuildBox.Command.File+	( PropFile(..)+	, inDir+	, inScratchDir+	, clobberDir+	, ensureDir+	, withTempFile)+where+import BuildBox.Build.Base+import BuildBox.Build.Testable+import BuildBox.Command.System+import System.Posix.Temp+import System.Directory+import System.IO++-- | Properties of the file system we can test for.+data PropFile++	-- | Some executable is in the current path.+	= HasExecutable	String++	-- | Some file exists.+	| HasFile	FilePath++	-- | Some directory exists.+	| HasDir  	FilePath++	-- | Some file is empty.+	| FileEmpty 	FilePath+	deriving Show+++instance Testable PropFile where+ test prop +  = case prop of+	HasExecutable name+	 -> do	code	<- qsystem $ "which " ++ name+		return	$ code == ExitSuccess++	HasFile path	+	 -> io $ doesFileExist path++	HasDir  path+	 -> io $ doesDirectoryExist path++	FileEmpty  path +	 -> do	contents	<- io $ readFile path+		return (null contents)+++-- | Run a command in a different working directory. Throws an error if the directory doesn't exist.+inDir :: FilePath -> Build a -> Build a+inDir name build+ = do	check $ HasDir name+	oldDir	<- io $ getCurrentDirectory++	io $ setCurrentDirectory name+	x	<- build+	io $ setCurrentDirectory oldDir++	return x++-- | Create a new directory with the given name, run a command within it,+--   then change out and recursively delete the directory. Throws an error if a directory+--   with the given name already exists.+inScratchDir :: FilePath -> Build a -> Build a+inScratchDir name build+ = do	+	-- Make sure a dir with this name doesn't already exist.+	checkFalse $ HasDir name++	ssystem $ "mkdir -p " ++ name+	x	<- inDir name build+	+	ssystem $ "rm -Rf " ++ name +	return x+++-- | Delete a dir recursively if it's there, otherwise do nothing.+--   Unlike `removeDirectoryRecursive`, this function does+--   not follow symlinks, it just deletes them.+clobberDir :: FilePath -> Build ()+clobberDir path+ = 	ssystem $ "rm -Rf " ++ path+++-- | Create a new directory if it isn't already there, or return successfully if it is.+ensureDir :: FilePath -> Build ()+ensureDir path+ = do	already	<- io $ doesDirectoryExist path+	if already+	 then return ()+	 else ssystem $ "mkdir -p " ++ path+++-- | Create a temp file, pass it to some command, then delete the file after the command finishes.+withTempFile :: (FilePath -> Build a) -> Build a+withTempFile build+ = do	(fileName, handle)	<- io $ mkstemp "/tmp/buildbox-XXXXXX"++	-- We just want the file name here, so close the handle to let the real+	-- build command write to it however it wants.+	io $ hClose handle+	+	-- run the real command+	result	<- build fileName+	+	-- cleanup +	io $ removeFile fileName+	+	return result+
+ BuildBox/Command/Mail.hs view
@@ -0,0 +1,109 @@++-- | Sending email. We've got baked in support for @msmtp@, which is easy to set up. Adding support for other mailers +--   should be easy. Get @msmtp@ here: <http://msmtp.sourceforge.net>+module BuildBox.Command.Mail+	( Mail(..)+	, Mailer(..)+	, createMailWithCurrentTime+	, renderMail+	, sendMailWithMailer)+where+import BuildBox.Build+import BuildBox.Pretty+import BuildBox.Command.Environment+import BuildBox.Command.System+import System.Locale	(defaultTimeLocale)+import Data.Time.Clock+import Data.Time.LocalTime+import Data.Time.Format+import Data.Time.Calendar+++-- | An email message that we can send.+data Mail+	= Mail+	{ mailFrom		:: String+	, mailTo		:: String+	, mailSubject		:: String+	, mailTime		:: UTCTime+	, mailTimeZone		:: TimeZone+	, mailMessageId		:: String+	, mailBody		:: String }+	deriving Show+++-- | An external mailer that can send messages.+--   	Also contains mail server info if needed.+--	We only support msmtp at the moment.+data Mailer+	= MailerMSMTP+	{ mailerPath		:: FilePath+	, mailerPort		:: Maybe Int }+	deriving Show+++-- | Create a mail with a given from, to, subject and body.+--   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 spambots.+createMailWithCurrentTime +	:: String 	-- ^ ''from'' field. Should be an email address.+	-> String	-- ^ ''to'' field. Should be an email address.+	-> String	-- ^ Subject line.+	-> String	-- ^ Message  body.+	-> Build Mail++createMailWithCurrentTime from to subject body+ = do+	-- We need to add the date otherwise our messages will get marked as spam.+	-- Use RFC 2822 format timestamp.+	utime		<- io $ getCurrentTime+	zone		<- io $ getCurrentTimeZone++	-- Generate a messageid based on the clock time.+	hostName	<- getHostName+	let dayNum	= toModifiedJulianDay $ utctDay utime+	let secTime	= utctDayTime utime+	let messageId	=  "<" ++ show dayNum ++ "." ++ show secTime+			++ "@" ++ hostName ++ ">"+		+	return	$ Mail+		{ mailFrom	= from+		, mailTo	= to+		, mailSubject	= subject+		, mailTime	= utime+		, mailTimeZone	= zone+		, mailMessageId	= messageId+		, mailBody	= body }+++-- | Render an email message as a string.+renderMail :: Mail -> Doc+renderMail mail+ = vcat+	[ ppr "From: "		<> ppr (mailFrom mail)+	, ppr "To: "		<> ppr (mailTo   mail)+	, ppr "Subject: "	<> ppr (mailSubject mail)+	, ppr "Date: "		<> (ppr $ formatTime defaultTimeLocale "%a, %e %b %Y %H:%M:%S %z"+					$ utcToZonedTime (mailTimeZone mail) (mailTime mail))++	, ppr "Message-Id: " 	<> ppr (mailMessageId mail)+	, ppr ""+	, ppr (mailBody mail) ]+++-- | Send a mail message.+sendMailWithMailer :: Mail -> Mailer -> Build ()+sendMailWithMailer mail mailer+ = case mailer of+	MailerMSMTP{}	-> sendMailWithMSMTP mail mailer++sendMailWithMSMTP :: Mail -> Mailer -> Build ()+sendMailWithMSMTP mail mailer@MailerMSMTP{}+ 	= ssystemTee False+		(mailerPath mailer +			++ " -t " -- read recipients from the mail+			++ (maybe "" (\port -> " --port=" ++ show port) $ mailerPort mailer))+		(render $ renderMail mail)++
+ BuildBox/Command/Network.hs view
@@ -0,0 +1,46 @@++-- | Working with the network.+module BuildBox.Command.Network+	(PropNetwork(..))+where+import BuildBox.Build+import BuildBox.Command.File+import BuildBox.Command.System++type HostName	= String+type URL	= String++data PropNetwork++	-- | The given host is reachable with @ping@.+	= HostReachable	HostName++	-- | Use @wget@ to check if a web-page is gettable.+	--   The page is deleted after downloading.+	| UrlGettable	URL++	deriving Show+	+instance Testable PropNetwork where+ test prop+  = case prop of++	-- Works on OSX 10.6.2+	-- -o               exit successfully after recieving one reply packet.+	HostReachable hostName+	 -> do	check	$ HasExecutable "ping"+		code	<- qsystem $ "ping -o " ++ hostName+		return $ code == ExitSuccess+		+	-- Works on OSX 10.6.2, wget 1.12+	--  -q              quiet+	--  --delete-after  delete page after downloading.+	UrlGettable url+	 -> do	check	$ HasExecutable "wget"+		code 	<- qsystem $ "wget -q --delete-after " ++ url+		return	$ code == ExitSuccess+		+++	+
+ BuildBox/Command/Sleep.hs view
@@ -0,0 +1,20 @@++-- | What do build 'bots dream about?+module BuildBox.Command.Sleep+	( sleep+	, msleep)+where+import BuildBox.Build+import Control.Concurrent+++-- | Sleep for a given number of seconds.+sleep :: Int -> Build ()+sleep secs	+	= io $ threadDelay $ secs * 1000000++	+-- | Sleep for a given number of milliseconds.+msleep :: Int -> Build ()+msleep msecs+	= io $ threadDelay $ msecs * 1000
+ BuildBox/Command/System.hs view
@@ -0,0 +1,207 @@+{-# 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+	, ssystem+	, qsystem+	, qssystem+	, ssystemOut+	, qssystemOut+	, systemTee+	, ssystemTee++	-- * The real function+	, 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+++-- Wrappers ---------------------------------------------------------------------------------------+-- | Run a system command, returning its exit code.+system :: String -> Build ExitCode+system cmd+ = do	(code, _, _)		<- systemTee True cmd ""+	return code+++-- | Run a successful system command.+--   If the exit code is `ExitFailure` then throw an error in the `Build` monad.+ssystem :: String -> Build ()+ssystem cmd+ = do	(code, strOut, strErr)	<- systemTee True cmd ""++	when (code /= ExitSuccess)+	 $ throw $ ErrorSystemCmdFailed cmd code strOut strErr+++-- | Quietly run a system command, returning its exit code.+qsystem :: String -> Build ExitCode+qsystem cmd+ = do	(code, _, _)		<- systemTee False cmd ""+	return code+++-- | Quietly run a successful system command.+--   If the exit code is `ExitFailure` then throw an error in the `Build` monad.+qssystem :: String -> Build ()+qssystem cmd+ = do	(code, strOut, strErr)	<- systemTee False cmd ""++	when (code /= ExitSuccess)+	 $ throw $ ErrorSystemCmdFailed cmd code strOut strErr+	++-- | 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.+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++-- | 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.+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++++-- 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 `systemTeeIO`, but in the `Build` monad and throw an error if it returns `ExitFailure`.+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++	++-- | Run a system command, returning its `ExitCode` and what was written to @stdout@ and @stderr@.+systemTeeIO +	:: Bool 	-- ^ Whether @stdout@ and @stderr@ should be forwarded to the parent process.+	-> String 	-- ^ Command to run.+	-> String	-- ^ What to pass to the command's @stdin@.+	-> IO (ExitCode, String, String)++systemTeeIO tee cmd strIn+ = 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 }++	-- Push input into in handle+	hPutStr hInWrite strIn+			+	-- 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		<- newChan+	chanErr		<- newChan+	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	<- dupChan chanOut+	chanErrAcc	<- dupChan 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.+	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+
+ BuildBox/Command/System/Internals.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE PatternGuards #-}+module BuildBox.Command.System.Internals+	( streamIn+	, streamOuts)+where+import System.IO+import Control.Concurrent	++-- | Continually read lines from a handle and write them to this channel.+--   When the handle hits EOF then write `Nothing` to the channel.+streamIn  :: Handle -> Chan (Maybe String) -> IO ()+streamIn hRead chan+ = do	eof	<- hIsEOF hRead+	if eof+	 then do+		writeChan chan Nothing+		return ()+		+	 else do+		str	<- hGetLine hRead+		writeChan chan (Just (str ++ "\n"))+		streamIn hRead chan+++-- | Continually read lines from some channels and write them to handles.+--   When all the channels return `Nothing` then we're done.+--   When we're done, signal this fact on the semaphore.+streamOuts :: [(Chan (Maybe String), (Maybe Handle), QSem)] -> IO ()+streamOuts chans + = streamOuts' False [] chans++ where	-- we're done.+	streamOuts' _ []   []	+		= return ()++	-- play it again, sam.+	streamOuts' True prev []	+	 = 	streamOuts' False [] prev++	streamOuts' False prev []+	 = do	yield+		streamOuts' False [] prev++	-- try to read from the current chan.+	streamOuts' active prev (x@(chan, mHandle, qsem) : rest)+	 = isEmptyChan chan >>= \empty -> +	   if empty +	    then streamOuts' active (prev ++ [x]) rest+	    else do+		mStr	<- readChan chan+		case mStr of+		 Nothing	+		  -> do	signalQSem qsem+			streamOuts' active prev rest++		 Just str +		  | Just h	<- mHandle+		  -> do	hPutStr h str+			streamOuts' True (prev ++ [x]) rest++		  | otherwise+		  -> 	streamOuts' True (prev ++ [x]) rest
+ BuildBox/Cron.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}+{-# OPTIONS -fno-warn-orphans #-}++-- | A simple ''cron'' loop. Used for running commands according to a given schedule.+module BuildBox.Cron+	( module BuildBox.Cron.Schedule+	, cronLoop )+where+import BuildBox.Build+import BuildBox.Cron.Schedule+import BuildBox.Command.Sleep+import Data.Time++-- | Given a schedule of commands, run them when their time is due.+--   Only one command is run at a time. If several commands could be started at a specific+--   moment, then we take the one with the earliest potential start time. If any command throws+--   an error in the `Build` monad then the whole loop does.+--+cronLoop :: Schedule (Build ())-> Build ()+cronLoop schedule+ = do	startTime	<- io $ getCurrentTime++	case earliestEventToStartAt startTime $ eventsOfSchedule schedule of+	 Nothing +	  -> do	sleep 1+		cronLoop schedule+		+	 Just event +	  -> do	let Just build	= lookupCommandOfSchedule (eventName event) schedule+		build+		endTime		<- io $ getCurrentTime++		let event'	= event+				{ eventLastStarted	= Just startTime+				, eventLastEnded	= Just endTime }++		let schedule'	= adjustEventOfSchedule event' schedule+		cronLoop schedule'+				+		+		+
+ BuildBox/Cron/Schedule.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}+{-# OPTIONS -fno-warn-orphans #-}++-- | A schedule of commands that should be run at a certain time.+module BuildBox.Cron.Schedule+	( +	-- * Time Periods+	  second, minute, hour, day++	-- * When+	, When		(..)+	, WhenModifier	(..)++	-- * Events+	, EventName+	, Event		(..)+	, earliestEventToStartAt+	, eventCouldStartAt++	-- * Schedules+	, Schedule	(..)+	, makeSchedule+	, lookupEventOfSchedule+	, lookupCommandOfSchedule+	, adjustEventOfSchedule+	, eventsOfSchedule)+where+import Data.Time+import Data.List+import Data.Function+import Data.Maybe+import Control.Monad+import Data.Map			(Map)+import qualified Data.Map	as Map+++instance Read NominalDiffTime where+ readsPrec n str+  = let	[(secs :: Double, rest)] = readsPrec n str+    in	case rest of+		's' : rest'	-> [(fromRational $ toRational secs, rest')]+		_		-> []++second, minute, hour, day :: NominalDiffTime+second	= 1+minute  = 60+hour	= 60 * minute+day	= 24 * hour+++-- When -------------------------------------------------------------------------------------------+-- | When to invoke some event.+data When+	-- | Just keep doing it.+	= Always++	-- | Don't do it, ever.+	| Never++	-- | Do it some time after we last started it.+	| Every NominalDiffTime+	+	-- | Do it some time after it last finished.+	| After NominalDiffTime+	+	-- | Do it each day at this time. The ''days'' are UTC days, not local ones.+	| Daily TimeOfDay+	deriving (Read, Show, Eq)+++-- | Modifier to when.+data WhenModifier+	-- | If the event hasn't been invoked before then do it immediately+	--   when we start the cron process.+	= Immediate++	-- | Wait until after this time before doing it first.+	| WaitUntil UTCTime+	deriving (Read, Show, Eq)+++-- Event ------------------------------------------------------------------------------------------+type EventName	= String++-- | Records when an event should start, and when it last ran.+data Event+	= Event+	{ -- | A unique name for this event.+	  --   Used when writing the schedule to a file.+	  eventName		:: EventName++	  -- | When to run the command.+	, eventWhen		:: When++	  -- | Modifier to the previous.+	, eventWhenModifier	:: Maybe WhenModifier++	  -- | When the event was last started, if any.+	, eventLastStarted	:: Maybe UTCTime+		+	  -- | When the event last finished, if any.+	, eventLastEnded	:: Maybe UTCTime }+	deriving (Read, Show, Eq)+	++-- | Given the current time and a list of events, determine which one should be started now.+--   If several events are avaliable then take the one with the earliest start time.+earliestEventToStartAt :: UTCTime -> [Event] -> Maybe Event+earliestEventToStartAt curTime events+ = let	eventsStartable	= filter (eventCouldStartAt curTime)   events+	eventsSorted	= sortBy (compare `on` eventLastStarted) eventsStartable+   in	listToMaybe eventsSorted+++-- | Given the current time, decide whether an event could be started.+--   If the `WhenModifier` is `Immediate` this always returns true.+--   The `SkipFirst` modifier is ignored, as this is handled separately.+eventCouldStartAt :: UTCTime -> Event -> Bool+eventCouldStartAt curTime event+ +	-- If the current end time is before the start time, then the most+	-- recent iteration is still running, so don't start it again.+	| Just lastStarted	<- eventLastStarted event+ 	, Just lastEnded	<- eventLastEnded   event+ 	= lastEnded < lastStarted+ +	-- If the event has never started or ended, and is marked as immediate,+	-- then start it right away.+	| Nothing		<- eventLastStarted  event+	, Nothing		<- eventLastEnded    event+	, Just Immediate	<- eventWhenModifier event+	= True++	-- Keep waiting if there's a seconday wait modifier.+	| Just (WaitUntil waitTime)	<- eventWhenModifier event+	, curTime < waitTime+	= False++	-- Otherwise we have to look at the real schedule.+	| otherwise+	= case eventWhen event of+		Always		-> True+		Never		-> False++		Every diffTime	+	 	 -> maybe True+			(\lastTime -> (curTime `diffUTCTime` lastTime ) > diffTime)+			(eventLastStarted event)++		After diffTime	+	 	 -> maybe True+			(\lastTime -> (curTime `diffUTCTime` lastTime ) > diffTime)+			(eventLastEnded event)+	+		Daily timeOfDay+		 -- If it's been more than a day since we last started it, then do it now.+		 | Just lastStarted	<- eventLastStarted event+		 , (curTime `diffUTCTime` lastStarted) > day+		 -> True+		+		 | otherwise+		 -> let	-- If we were going to run it today, this is when it would be.+			startTimeToday+				= curTime+				{ utctDayTime	= timeOfDayToTime timeOfDay }+				+			-- If it's after that time then quit fooling around..+		    in	curTime > startTimeToday+++-- Schedule ---------------------------------------------------------------------------------------+-- | Map of event names to their details and build commands.	+data Schedule cmd+	= Schedule (Map EventName (Event, cmd))+++-- | Get the list of events in a schedule, ignoring the build commands.+eventsOfSchedule :: Schedule cmd -> [Event]+eventsOfSchedule (Schedule sched)+	= map fst $ Map.elems sched+++-- | A nice way to produce a schedule.+makeSchedule :: [(EventName, When, Maybe WhenModifier, cmd)] -> Schedule cmd+makeSchedule tuples+ = let	makeSched (name, whn, mMod, cmd)+	  =	(name, (Event name whn mMod Nothing Nothing, cmd))+   in	Schedule $ Map.fromList $ map makeSched tuples+++-- | Given an event name, lookup the associated event from a schedule.+lookupEventOfSchedule :: EventName -> Schedule cmd -> Maybe Event+lookupEventOfSchedule name (Schedule sched)+	= liftM fst $ Map.lookup name sched+	+	+-- | Given an event name, lookup the associated build command from a schedule.+lookupCommandOfSchedule :: EventName -> Schedule cmd -> Maybe cmd+lookupCommandOfSchedule name (Schedule sched)+	= liftM snd $ Map.lookup name sched+++-- | Given a new version of an event, update any matching event in the schedule.+--   If the event not already there then return the original schedule.+adjustEventOfSchedule :: Event -> Schedule cmd -> Schedule cmd+adjustEventOfSchedule event (Schedule sched)+	= Schedule +	$ Map.adjust +		(\(_, build) -> (event, build))+		(eventName event) +		sched
+ BuildBox/Pretty.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- | Pretty printing utils.+module BuildBox.Pretty+	( module Text.PrettyPrint+	, Pretty(..)+	, pprPSecTime+	, pprFloatTime+	, pprFloatSF+	, pprFloatRef+	, padRc, padR+	, padLc, padL+	, blank)+where+import Text.PrettyPrint+import Data.Time++-- Things that can be pretty printed+class Pretty a where+ 	ppr :: a -> Doc++-- Basic instances+instance Pretty Doc where+	ppr = id++instance Pretty String where+	ppr = text+	+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+	++-- To handle type defaulting+ten12 :: Float+ten12 = 10^(12 :: Integer)++ten12i :: Integer+ten12i = 10^(12 :: Integer)+++-- | Print a number of picoseconds as a time.+pprPSecTime :: Integer -> Doc+pprPSecTime psecs+  	=  text (show (psecs `div` ten12i))+	<> text "." + 	<> (text $ (take 3 $ render $ padRc 12 '0' $ text $ show $ psecs `mod` ten12i))+++-- | Print a float number of seconds as a time.+pprFloatTime :: Float -> Doc+pprFloatTime stime+  = let	psecs	= truncate (stime * ten12)+    in	pprPSecTime psecs+++-- | Pretty print a signed float, with a percentage change relative to a reference figure.+--   Comes out like @0.235( +5)@ for a +5 percent swing.+pprFloatRef :: Float -> Float -> Doc+pprFloatRef stime stimeRef + = let	psecs		= truncate (stime    * ten12)+	diff		= (1 - (stimeRef / stime))*100+   in	pprPSecTime psecs+	 <> parens (padR 3 $ pprFloatSF diff)+++-- | Print a float number of seconds, flooring it and, prefixing with @+@ or @-@ appropriately.+pprFloatSF :: Float -> Doc+pprFloatSF p+ 	| p > 0+	= text "+" <> (ppr $ (floor p :: Integer))+	+	| otherwise+	= text "-" <> (ppr $ (floor (negate p) :: Integer))+++-- | Right justify a doc, padding with a given character.+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+padR n str	= padRc n ' ' str+++-- | Left justify a string, padding with a given character.+padLc :: Int -> Char -> Doc -> Doc+padLc n c str+	= str <> (text $ replicate (n - length (render str)) c)+++-- | Left justify a string with spaces.+padL :: Int -> Doc -> Doc+padL n str	= padLc n ' ' str++-- | Blank text. This is different different from `empty` because it comes out a a newline when used in a `vcat`.+blank :: Doc+blank = ppr ""
+ BuildBox/Time.hs view
@@ -0,0 +1,82 @@++-- | Time utils useful for writing buildbots.+module BuildBox.Time+	( module Data.Time+	, readLocalTimeOfDayAsUTC+	, getStampyTime+	, getMidnightTodayLocal+	, getMidnightTodayUTC+	, getMidnightTomorrowLocal+	, getMidnightTomorrowUTC)+where+import Data.Time+import System.Locale+++-- | Read a time of day string like @17:34:05@ in the local time zone+--   and convert that to a UTC time of day. Good for parsing command line args to buildbots.+readLocalTimeOfDayAsUTC :: String -> IO TimeOfDay+readLocalTimeOfDayAsUTC str+ = do	+	-- Get the current timeZone.+	curTime	<- getZonedTime++	-- Convert the time of day to what it would be as UTC.+	let (_, timeOfDayUTC)+		=  localToUTCTimeOfDay +			(zonedTimeZone curTime)+			(read str) ++	return timeOfDayUTC+++-- | Get a local time stamp with format YYYYMMDD_HHMMSS. Good for naming files with.+getStampyTime :: IO String+getStampyTime+ = do	time	<- getZonedTime+	return	$  formatTime defaultTimeLocale "%Y%m%d_%k%M%S" time+++-- | Get the local midnight we've just had as a `LocalTime`.+getMidnightTodayLocal :: IO LocalTime+getMidnightTodayLocal+ = do	curTime	<- getZonedTime+	return	$ LocalTime+		{ localDay		= localDay $ zonedTimeToLocalTime curTime+		, localTimeOfDay	= midnight }+++-- | Get the local midnight that we've just had, as a `UTCTime`.+getMidnightTodayUTC :: IO UTCTime +getMidnightTodayUTC+ = do	curTime	<- getZonedTime+	return	$ zonedTimeToUTC+		$ ZonedTime+			(LocalTime	+				{ localDay		= localDay $ zonedTimeToLocalTime curTime+				, localTimeOfDay	= midnight })+			(zonedTimeZone curTime)+++-- | Get the local midnight we're about to have as a `LocalTime`.+getMidnightTomorrowLocal :: IO LocalTime+getMidnightTomorrowLocal+ = do	curTime	<- getZonedTime+	return	$ LocalTime+		{ localDay		= addDays 1 (localDay (zonedTimeToLocalTime curTime)) +		, localTimeOfDay	= midnight }++-- | Get the local midnight we're about to have as a `UTCTime`.+getMidnightTomorrowUTC 	 :: IO UTCTime+getMidnightTomorrowUTC+ = do	curTime	<- getZonedTime+	return	$ zonedTimeToUTC+		$ ZonedTime+		  	(LocalTime+				{ localDay		= addDays 1 (localDay (zonedTimeToLocalTime curTime)) +				, localTimeOfDay	= midnight })+			(zonedTimeZone curTime)+++	+
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2010, University of New South Wales.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of the University of New South Wales nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ buildbox.cabal view
@@ -0,0 +1,64 @@+Name:                buildbox+Version:             1.0.0.0+License:             BSD3+License-file:        LICENSE+Author:              Ben Lippmeier+Maintainer:          Ben Lippmeier <benl@ouroborus.net>+Build-Type:          Simple+Cabal-Version:       >=1.6+Stability:           experimental+Category:            Development, Testing+Homepage:            http://code.haskell.org/~benl/code/buildbox-head+Description:+        Rehackable components for writing buildbots and test harnesses. Includes functions+        for checking the host platform, running tests, capturing output, handling errors,+        comparing runtimes against a baseline, sending mail, running events to a schedule etc.++	Some of these functions are just wrappers around shell commands, so be careful about passing+	them weirdly formed arguments.+	+Synopsis:+        Rehackable components for writing buildbots and test harnesses.++Tested-with:+        GHC == 6.12.1++Library+  Build-Depends: +        base                 == 4.*,+        time                 == 1.1.*,+        mtl                  == 1.1.*,+        directory            == 1.0.*,+        process              == 1.0.*,+        unix                 == 2.4.*,+        pretty               == 1.0.*,+        old-locale           == 1.0.*,+        containers           == 0.3.*++  ghc-options:+        -Wall++  Exposed-modules:+        BuildBox.Benchmark.Base+        BuildBox.Benchmark.Compare+        BuildBox.Benchmark.Pretty+        BuildBox.Benchmark.TimeAspect+        BuildBox.Benchmark+        BuildBox.Build.Base+        BuildBox.Build.Testable+        BuildBox.Build+        BuildBox.Command.Environment+        BuildBox.Command.File+        BuildBox.Command.Mail+        BuildBox.Command.Network+        BuildBox.Command.System+        BuildBox.Command.Sleep+        BuildBox.Cron.Schedule+        BuildBox.Cron+        BuildBox.Pretty+        BuildBox.Time+        BuildBox++  Other-modules:+        BuildBox.Command.System.Internals+