ddc-war (empty) → 0.2.1.1
raw patch · 30 files changed
+2751/−0 lines, 30 filesdep +basedep +buildboxdep +containerssetup-changed
Dependencies added: base, buildbox, containers, directory, filepath, process, random, stm
Files
- DDC/War/Config.hs +66/−0
- DDC/War/Create.hs +60/−0
- DDC/War/Create/CreateDCE.hs +87/−0
- DDC/War/Create/CreateDCX.hs +46/−0
- DDC/War/Create/CreateMainDS.hs +107/−0
- DDC/War/Create/CreateMainHS.hs +45/−0
- DDC/War/Create/CreateMainSH.hs +46/−0
- DDC/War/Create/CreateTestDS.hs +57/−0
- DDC/War/Create/Way.hs +15/−0
- DDC/War/Driver.hs +5/−0
- DDC/War/Driver/Base.hs +116/−0
- DDC/War/Driver/Chain.hs +72/−0
- DDC/War/Driver/Gang.hs +59/−0
- DDC/War/Interface/Controller.hs +246/−0
- DDC/War/Interface/VT100.hs +157/−0
- DDC/War/Job.hs +70/−0
- DDC/War/Job/CompileDCE.hs +125/−0
- DDC/War/Job/CompileDS.hs +137/−0
- DDC/War/Job/CompileHS.hs +119/−0
- DDC/War/Job/Diff.hs +72/−0
- DDC/War/Job/RunDCX.hs +78/−0
- DDC/War/Job/RunExe.hs +86/−0
- DDC/War/Job/Shell.hs +89/−0
- DDC/War/Option.hs +169/−0
- DDC/War/Task/Nightly.hs +279/−0
- DDC/War/Task/Test.hs +200/−0
- LICENSE +30/−0
- Main.hs +43/−0
- Setup.hs +2/−0
- ddc-war.cabal +68/−0
+ DDC/War/Config.hs view
@@ -0,0 +1,66 @@++module DDC.War.Config+ ( Config (..)+ , defaultConfig+ , defaultTestSpec+ , defaultNightlySpec)+where+import qualified DDC.War.Task.Test as T+import qualified DDC.War.Task.Nightly as N+import qualified BuildBox.Command.Mail as B+++-- | Configuration information read from command line arguments.+data Config+ = Config + { -- | Whether to emit debugging info for war.+ configDebug :: Bool++ -- | Config for test mode.+ , configTest :: Maybe T.Spec++ -- | Config for nightly build mode.+ , configNightly :: Maybe N.Spec }+ deriving Show+++-- | Default configuration.+defaultConfig :: Config+defaultConfig+ = Config+ { configDebug = False+ , configTest = Just defaultTestSpec+ , configNightly = Nothing }+++defaultTestSpec :: T.Spec+defaultTestSpec+ = T.Spec+ { T.specTestDirs = []+ , T.specWays = []+ , T.specThreads = 1+ , T.specFormatPathWidth = 70+ , T.specInteractive = True+ , T.specResultsFileAll = Nothing+ , T.specResultsFileFailed = Nothing }+++defaultNightlySpec :: N.Spec+defaultNightlySpec+ = N.Spec+ { N.specLocalBuildDir = Nothing+ , N.specRemoteSnapshotURL = "http://code.ouroborus.net/ddc/snapshot/ddc-head-latest.tgz"+ , N.specRemoteRepoURL = "http://code.ouroborus.net/ddc/ddc-head"+ , N.specBuildThreads = 1+ , N.specCleanup = False+ , N.specContinuous = Nothing+ , N.specNow = False+ , N.specLogUserHost = Just $ "overlord@deluge.ouroborus.net"+ , N.specLogRemoteDir = Just $ "log/desire/ddc/head"+ , N.specLogRemoteURL = Just $ "http://log.ouroborus.net/desire/ddc/head"+ , N.specMailer = Just $ B.MailerSendmail "sendmail" [] + , N.specMailFrom = Just $ "DDC Buildbot <overlord@ouroborus.net>"+ , N.specMailTo = Just $ "disciple-cafe@googlegroups.com" }+++
+ DDC/War/Create.hs view
@@ -0,0 +1,60 @@++-- | Creation of test jobs.+-- We decide what to do based on what files are in a directory.+--+-- The following have specicial meaning. +-- They are in priority order, so if there is both a Main.sh and Main.ds file+-- we run the Main.sh but don't then compile the Main.ds as well.+--+-- Main.sh Run this shell script.+--+-- Main.ds Compile with DDC and run the executable.+-- Main.error.check And expect compile failure, diff stdout with this file.+-- Main.runerror.check And expect run failure.+-- Main.stdout.check Diff run stdout with this file.+-- Main.stderr.check Diff run stderr with this file.+--+-- Main.dce Compile with ddci-core and run the executable.+-- Main.error.check And expect compile failure, diff stdout with this file.+-- Main.stdout.check Diff run stdout with this file.+-- Main.stderr.check Diff run stderr with this file.+--+-- *.ds Compile with DDC, but there is no executable produced.+-- *.error.check And expect compile failure, diff stdout with this file.+--+-- Test.dcx Run with ddci-core.+-- Test.stdout.check Diff run stdout with this file.+-- +module DDC.War.Create+ ( Way (..)+ , create)+where+import DDC.War.Create.Way+import DDC.War.Driver+import Data.Maybe+import Data.Set (Set)+import qualified DDC.War.Create.CreateMainSH as CreateMainSH+import qualified DDC.War.Create.CreateMainHS as CreateMainHS+import qualified DDC.War.Create.CreateMainDS as CreateMainDS+import qualified DDC.War.Create.CreateTestDS as CreateTestDS+import qualified DDC.War.Create.CreateDCX as CreateDCX+import qualified DDC.War.Create.CreateDCE as CreateDCE+++-- | Create job chains based on this file.+create :: Way -- ^ Create tests for this way.+ -> Set FilePath -- ^ All files in the test directory.+ -> FilePath -- ^ Create test chains based on this file.+ -> [Chain]++create way allFiles filePath+ = catMaybes+ [ creat way allFiles filePath+ | creat <- + [ CreateMainSH.create+ , CreateMainHS.create+ , CreateMainDS.create+ , CreateTestDS.create+ , CreateDCX.create+ , CreateDCE.create ]]+
+ DDC/War/Create/CreateDCE.hs view
@@ -0,0 +1,87 @@+++module DDC.War.Create.CreateDCE+ (create)+where+import DDC.War.Create.Way+import DDC.War.Driver+import System.FilePath+import DDC.War.Job ()+import Data.Set (Set)+import qualified DDC.War.Job.CompileDCE as CompileDCE+import qualified DDC.War.Job.RunExe as RunExe+import qualified DDC.War.Job.Diff as Diff+import qualified Data.Set as Set+++-- | Compile and run .dce files.+create :: Way -> Set FilePath -> FilePath -> Maybe Chain+create way allFiles filePath+ | takeFileName filePath == "Main.dce"+ = let + sourceDir = takeDirectory filePath+ buildDir = sourceDir </> "war-" ++ wayName way+ testName = filePath++ mainSH = sourceDir </> "Main.sh"+ mainBin = buildDir </> "Main.bin"+ mainCompStdout = buildDir </> "Main.compile.stdout"+ mainCompStderr = buildDir </> "Main.compile.stderr"+ mainCompDiff = buildDir </> "Main.compile.stderr.diff"+ mainRunStdout = buildDir </> "Main.run.stdout"+ mainRunStderr = buildDir </> "Main.run.stderr"++ mainErrorCheck = sourceDir </> "Main.error.check"+ shouldSucceed = not $ Set.member mainErrorCheck allFiles++ mainStdoutCheck = sourceDir </> "Main.stdout.check"+ mainStdoutDiff = buildDir </> "Main.run.stdout.diff"+ shouldDiffStdout = Set.member mainStdoutCheck allFiles++ mainStderrCheck = sourceDir </> "Main.stderr.check"+ mainStderrDiff = buildDir </> "Main.run.stderr.diff"+ shouldDiffStderr = Set.member mainStderrCheck allFiles++ -- compile the .ds into a .bin+ compile = jobOfSpec (JobId testName (wayName way))+ $ CompileDCE.Spec+ filePath+ buildDir mainCompStdout mainCompStderr+ (Just mainBin) shouldSucceed++ -- run the binary+ run = jobOfSpec (JobId testName (wayName way))+ $ RunExe.Spec+ filePath + mainBin []+ mainRunStdout mainRunStderr+ True++ -- diff errors produced by the compilation+ diffError = jobOfSpec (JobId testName (wayName way))+ $ Diff.Spec+ mainErrorCheck+ mainCompStderr mainCompDiff++ -- diff the stdout of the run+ diffStdout = jobOfSpec (JobId testName (wayName way))+ $ Diff.Spec+ mainStdoutCheck+ mainRunStdout mainStdoutDiff++ -- diff the stderr of the run+ diffStderr = jobOfSpec (JobId testName (wayName way))+ $ Diff.Spec+ mainStderrCheck+ mainRunStderr mainStderrDiff++ in if Set.member mainSH allFiles+ then Nothing+ else Just $ Chain + $ [compile]+ ++ (if shouldSucceed then [run] else [diffError])+ ++ (if shouldDiffStdout then [diffStdout] else [])+ ++ (if shouldDiffStderr then [diffStderr] else [])++ | otherwise = Nothing+
+ DDC/War/Create/CreateDCX.hs view
@@ -0,0 +1,46 @@++module DDC.War.Create.CreateDCX+ (create)+where+import DDC.War.Create.Way+import DDC.War.Driver+import System.FilePath+import DDC.War.Job ()+import Data.Set (Set)+import qualified DDC.War.Job.RunDCX as RunDCX+import qualified DDC.War.Job.Diff as Diff+import qualified Data.Set as Set+++-- | Run .dcx files with the interpreter.+create :: Way -> Set FilePath -> FilePath -> Maybe Chain+create way allFiles filePath+ | takeFileName filePath == "Test.dcx"+ = let + fileName = takeFileName filePath+ sourceDir = takeDirectory filePath+ buildDir = sourceDir </> "war-" ++ wayName way+ testName = filePath++ testDDCiStdout = buildDir </> replaceExtension fileName ".ddci-core.stdout"+ testDDCiStderr = buildDir </> replaceExtension fileName ".ddci-core.stderr"++ testStdoutCheck = sourceDir </> "Test.stdout.check"+ testStdoutDiff = buildDir </> "Test.stdout.check.diff"+ shouldDiffStdout = Set.member testStdoutCheck allFiles++ jobRun = jobOfSpec (JobId testName (wayName way))+ $ RunDCX.Spec+ filePath+ buildDir testDDCiStdout testDDCiStderr++ jobDiff = jobOfSpec (JobId testName (wayName way))+ $ Diff.Spec+ testStdoutCheck+ testDDCiStdout testStdoutDiff++ in Just $ Chain + $ [jobRun] + ++ (if shouldDiffStdout then [jobDiff] else [])++ | otherwise = Nothing
+ DDC/War/Create/CreateMainDS.hs view
@@ -0,0 +1,107 @@++module DDC.War.Create.CreateMainDS+ (create)+where+import DDC.War.Create.Way+import DDC.War.Driver+import System.FilePath+import Data.Set (Set)+import DDC.War.Job ()+import qualified DDC.War.Job.CompileDS as CompileDS+import qualified DDC.War.Job.RunExe as RunExe+import qualified DDC.War.Job.Diff as Diff+import qualified Data.Set as Set+++-- | Compile and run Main.ds files.+create :: Way -> Set FilePath -> FilePath -> Maybe Chain+create way allFiles filePath+ | takeFileName filePath == "Main.ds"+ = let + sourceDir = takeDirectory filePath+ buildDir = sourceDir </> "war-" ++ wayName way+ testName = filePath++ mainSH = sourceDir </> "Main.sh"++ -- Source ---------------------+ -- If this exists then expect compilation to fail.+ mainErrorCheck = sourceDir </> "Main.error.check"++ -- If this exists then expect the execuable to fail at runtime.+ mainRunErrorCheck = sourceDir </> "Main.runerror.check"++ -- Expected output of successful executable.+ mainStdoutCheck = sourceDir </> "Main.stdout.check"+ mainStderrCheck = sourceDir </> "Main.stderr.check"++ -- Output ---------------------+ -- Where to put compiler output.+ mainCompStdout = buildDir </> "Main.compile.stdout"+ mainCompStderr = buildDir </> "Main.compile.stderr"+ mainCompStderrDiff = buildDir </> "Main.compile.stderr.diff"++ -- Where to put exectuable output.+ mainBin = buildDir </> "Main.bin"+ mainRunStdout = buildDir </> "Main.run.stdout"+ mainRunStdoutDiff = buildDir </> "Main.run.stdout.diff"+ mainRunStderr = buildDir </> "Main.run.stderr"+ mainRunStderrDiff = buildDir </> "Main.run.stderr.diff"++ -- compile the .ds into a .bin+ -- We expect the compile to fail if there is a Main.error.check file.+ compShouldSucceed = not $ Set.member mainErrorCheck allFiles+ jobCompile = jobOfSpec (JobId testName (wayName way))+ $ CompileDS.Spec+ filePath+ (wayOptsComp way) ["-M60M"]+ buildDir mainCompStdout mainCompStderr+ (Just mainBin) compShouldSucceed++ -- If we expect the compile to fail, + -- then diff errors produced by the compilation+ shouldDiffCompError = not $ compShouldSucceed+ jobDiffCompError = jobOfSpec (JobId testName (wayName way))+ $ Diff.Spec+ mainErrorCheck+ mainCompStderr mainCompStderrDiff++ -- If we expect the compile to succeed, then run the resulting binary.+ -- We expect the run to fail if there is a Main.runerror.check file.+ shouldRunExe = compShouldSucceed+ runShouldSucceed = not $ Set.member mainRunErrorCheck allFiles+ jobRunExe = jobOfSpec (JobId testName (wayName way))+ $ RunExe.Spec+ filePath + mainBin []+ mainRunStdout mainRunStderr+ runShouldSucceed++ -- If we expect the run to succeed,+ -- then diff the stdout of the run.+ shouldDiffStdout = shouldRunExe && Set.member mainStdoutCheck allFiles+ jobDiffStdout = jobOfSpec (JobId testName (wayName way))+ $ Diff.Spec+ mainStdoutCheck+ mainRunStdout mainRunStdoutDiff++ -- If we expect the run to succeed,+ -- then diff the stderr of the run.+ shouldDiffStderr = shouldRunExe && Set.member mainStderrCheck allFiles+ jobDiffStderr = jobOfSpec (JobId testName (wayName way))+ $ Diff.Spec+ mainStderrCheck+ mainRunStderr mainRunStderrDiff++ in if Set.member mainSH allFiles+ then Nothing+ else Just $ Chain + $ [jobCompile]+ ++ (if shouldDiffCompError then [jobDiffCompError] else [])+ ++ (if shouldRunExe then [jobRunExe] else [])+ ++ (if shouldDiffStdout then [jobDiffStdout] else [])+ ++ (if shouldDiffStderr then [jobDiffStderr] else [])++ | otherwise = Nothing++
+ DDC/War/Create/CreateMainHS.hs view
@@ -0,0 +1,45 @@++module DDC.War.Create.CreateMainHS+ (create)+where+import DDC.War.Create.Way+import DDC.War.Driver+import System.FilePath+import DDC.War.Job ()+import Data.Set (Set)+import qualified DDC.War.Job.CompileHS as CompileHS+import qualified DDC.War.Job.RunExe as RunExe+++-- | Compile and run Main.hs files.+-- When we run the exectuable, pass it out build dir as the first argument.+create :: Way -> Set FilePath -> FilePath -> Maybe Chain+create way _allFiles filePath+ | takeFileName filePath == "Main.hs"+ = let + sourceDir = takeDirectory filePath+ buildDir = sourceDir </> "war-" ++ wayName way+ testName = filePath++ mainBin = buildDir </> "Main.bin"+ mainCompStdout = buildDir </> "Main.compile.stdout"+ mainCompStderr = buildDir </> "Main.compile.stderr"+ mainRunStdout = buildDir </> "Main.run.stdout"+ mainRunStderr = buildDir </> "Main.run.stderr"++ compile = jobOfSpec (JobId testName (wayName way))+ $ CompileHS.Spec+ filePath []+ buildDir mainCompStdout mainCompStderr+ mainBin++ run = jobOfSpec (JobId testName (wayName way))+ $ RunExe.Spec+ filePath + mainBin [buildDir]+ mainRunStdout mainRunStderr+ True++ in Just $ Chain [compile, run]++ | otherwise = Nothing
+ DDC/War/Create/CreateMainSH.hs view
@@ -0,0 +1,46 @@++module DDC.War.Create.CreateMainSH+ (create)+where+import DDC.War.Create.Way+import DDC.War.Driver+import System.FilePath+import Data.Set (Set)+import DDC.War.Job ()+import qualified DDC.War.Job.Shell as Shell+import qualified DDC.War.Job.Diff as Diff+import qualified Data.Set as Set+++-- | Run Main.sh files.+create :: Way -> Set FilePath -> FilePath -> Maybe Chain+create way allFiles filePath+ | takeFileName filePath == "Main.sh"+ = let+ sourceDir = takeDirectory filePath+ buildDir = sourceDir </> "war-" ++ wayName way+ testName = filePath+++ mainShellStdout = buildDir </> "Main.shell.stdout"+ mainShellStderr = buildDir </> "Main.shell.stderr"+ mainShellStderrDiff = buildDir </> "Main.compile.stderr.diff"+ mainErrorCheck = sourceDir </> "Main.error.check"+ shouldSucceed = not $ Set.member mainErrorCheck allFiles++ shell = jobOfSpec (JobId testName (wayName way))+ $ Shell.Spec + filePath sourceDir buildDir+ mainShellStdout mainShellStderr+ shouldSucceed++ diffError = jobOfSpec (JobId testName (wayName way))+ $ Diff.Spec+ mainErrorCheck+ mainShellStderr mainShellStderrDiff++ in Just $ Chain + $ [shell] + ++ (if shouldSucceed then [] else [diffError])++ | otherwise = Nothing
+ DDC/War/Create/CreateTestDS.hs view
@@ -0,0 +1,57 @@++module DDC.War.Create.CreateTestDS+ (create)+where+import DDC.War.Create.Way+import DDC.War.Driver+import System.FilePath+import Data.List+import DDC.War.Job ()+import Data.Set (Set)+import qualified DDC.War.Job.CompileDS as CompileDS+import qualified DDC.War.Job.Diff as Diff+import qualified Data.Set as Set+++-- | Compile Test.ds files.+create :: Way -> Set FilePath -> FilePath -> Maybe Chain+create way allFiles filePath+ | isSuffixOf ".ds" filePath+ = let + fileName = takeFileName filePath+ sourceDir = takeDirectory filePath+ buildDir = sourceDir </> "war-" ++ wayName way+ testName = filePath++ mainDS = sourceDir </> "Main.ds"+ mainSH = sourceDir </> "Main.sh"+ testErrorCheck = sourceDir </> replaceExtension fileName ".error.check"++ testCompStdout = buildDir </> replaceExtension fileName ".compile.stdout"+ testCompStderr = buildDir </> replaceExtension fileName ".compile.stderr"+ testCompDiff = buildDir </> replaceExtension fileName ".compile.stderr.diff"+ shouldSucceed = not $ Set.member testErrorCheck allFiles++ -- Compile the .ds file+ compile = jobOfSpec (JobId testName (wayName way))+ $ CompileDS.Spec+ filePath+ (wayOptsComp way) ["-M50M"]+ buildDir testCompStdout testCompStderr+ Nothing shouldSucceed++ diffError = jobOfSpec (JobId testName (wayName way))+ $ Diff.Spec+ testErrorCheck+ testCompStderr testCompDiff++ in -- Don't do anything if there is a Main.ds here.+ -- This other .ds file is probably a part of a larger program.+ if Set.member mainDS allFiles+ || Set.member mainSH allFiles+ then Nothing+ else Just $ Chain+ $ [compile] + ++ (if shouldSucceed then [] else [diffError])++ | otherwise = Nothing
+ DDC/War/Create/Way.hs view
@@ -0,0 +1,15 @@++module DDC.War.Create.Way+ (Way(..))+where+ ++-- | A way to build the test.+-- This holds extra options to pass to the program.+data Way+ = Way + { wayName :: String + , wayOptsComp :: [String] + , wayOptsRun :: [String] }+ deriving (Eq, Ord, Show)+
+ DDC/War/Driver.hs view
@@ -0,0 +1,5 @@++module DDC.War.Driver+ (module DDC.War.Driver.Base)+where+import DDC.War.Driver.Base
+ DDC/War/Driver/Base.hs view
@@ -0,0 +1,116 @@++module DDC.War.Driver.Base+ ( Job (..)+ , JobId (..)+ , Chain (..)+ , Product (..)+ , Result (..)+ , prettyResult+ , Spec (..))+where+import BuildBox.Pretty+import BuildBox+import Data.Maybe+import Data.List++-- | A printable job identifier.+data JobId+ = JobId+ { jobIdName :: String + , jobIdWay :: String }+ deriving Show++++-- | A single job to run.+-- The exact specification is defined by the client.+data Job+ = forall spec result. Spec spec result+ => Job JobId String spec (Build result)++instance Pretty Job where+ ppr (Job jobId actionName spec _)+ = text "Job" <+> text (show jobId) <+> text actionName <+> text (show spec)+++-- | A chain of jobs to run one after another.+-- Jobs later in the list are dependent on earlier ones, so if a job fails+-- then we skip the rest.+data Chain+ = Chain [Job]++instance Pretty Chain where+ ppr (Chain jobs)+ = text "Chain"+ <+> ppr jobs+++-- | The product that we got when running a job.+-- This is the information that the interactive interface needs to decide+-- how to proceed. +data Product+ = ProductStatus + { productStatusMsg :: Doc+ , productStatusSuccess :: Bool }++ | ProductDiff + { productDiffRef :: FilePath+ , productDiffOut :: FilePath+ , productDiffDiff :: FilePath }+++-- | Description of a job and the product we got from running it.+data Result+ = Result + { resultChainIx :: Int+ , resultJobIx :: Int+ , resultJobId :: JobId+ , resultJobActionName :: String+ , resultProduct :: Product }+++prettyResult :: Int -> String -> Int -> Result -> Doc+prettyResult chainsTotal prefix padWidth result+ | Result chainIx jobIx jobId actionName product' <- result+ , JobId testName wayName <- jobId+ = let status+ = case product' of+ ProductStatus s _ -> s+ ProductDiff{} -> text "diff"++ testName'+ = fromMaybe testName (stripPrefix prefix testName)++ in parens (padR (length $ show chainsTotal)+ (ppr chainIx)+ <> text "."+ <> (ppr jobIx))+ <+> padL padWidth (text testName') + <+> padL 5 (text wayName)+ <+> padL 8 (text actionName)+ <+> status++ where ++-- Spec -----------------------------------------------------------------------+-- | Class of Job specifications.+class (Show spec, Pretty result)+ => Spec spec result | spec -> result where++ -- | Get a short name to describe the job that this spec describes, + -- eg "compile" or "run"+ specActionName :: spec -> String++ -- | Wrap a specification into a job.+ jobOfSpec :: JobId -> spec -> Job+ jobOfSpec jobId s = Job jobId (specActionName s) s (buildFromSpec s)++ -- | Create a builder for this job specification.+ buildFromSpec :: spec -> Build result++ -- | Make the job product from its result.+ -- This cuts away information that the controller doesn't care about.+ productOfResult :: spec -> result -> Product+++
+ DDC/War/Driver/Chain.hs view
@@ -0,0 +1,72 @@++module DDC.War.Driver.Chain+ ( runChainWithTChan+ , runJobWithTChan+ , runChain+ , runJob)+where+import DDC.War.Driver+import BuildBox+import Control.Concurrent.STM.TChan+import Control.Monad+import Control.Monad.STM+++-- Run a chain of jobs, optionally writing the results to this channel+-- after each job finishes.+runChainWithTChan+ :: Maybe (TChan Result)+ -> Int+ -> Chain+ -> Build [Result]++runChainWithTChan mChannel ixChain (Chain jobs)+ = zipWithM (runJobWithTChan mChannel ixChain) [0..] jobs+++-- | Run a job, optionally writing the result to this channel.+runJobWithTChan+ :: Maybe (TChan Result)+ -> Int+ -> Int+ -> Job+ -> Build Result++runJobWithTChan mChannel ixChain ixJob job+ = case mChannel of+ Nothing + -> runJob ixChain ixJob job++ Just channel+ -> do result <- runJob ixChain ixJob job+ io $ atomically $ writeTChan channel result+ return result+++-- Run ------------------------------------------------------------------------+-- | Run a job chain, returning the results.+runChain :: Int -- ^ Index of this chain.+ -> Chain -- ^ Chain of jobs to run+ -> Build [Result] -- ^ Job results.++runChain ixChain (Chain jobs)+ = zipWithM (runJob ixChain) [0..] jobs+++-- | Run a single job, returning its result.+runJob :: Int -- ^ Index of this chain.+ -> Int -- ^ Index of this job of the chain.+ -> Job -- ^ The job to run.+ -> Build Result++runJob ixChain ixJob (Job jobId actionName spec builder)+ = do + -- Run the job.+ result <- builder++ -- Convert the result into the product the controller wants.+ let product' = productOfResult spec result+ let jobResult = Result ixChain ixJob jobId actionName product'++ return jobResult+
+ DDC/War/Driver/Gang.hs view
@@ -0,0 +1,59 @@++module DDC.War.Driver.Gang+ ( forkChainsIO+ , runChainIO)+where+import DDC.War.Driver.Base+import DDC.War.Driver.Chain+import BuildBox.Build.BuildState+import BuildBox.Control.Gang+import BuildBox+import Control.Concurrent.STM.TChan+import System.Random+++-- | Run some job chains.+forkChainsIO+ :: Int -- ^ Number of threads to use.+ -> FilePath -- ^ Scratch directory.+ -> Maybe (TChan Result) -- ^ Channel to write job results into.+ -> [Chain] -- ^ Chains of jobs to sun.+ -> IO Gang -- ^ The gang now running the jobs.++forkChainsIO numThreads dirScratch mChanResult chains+ = do + -- Fork a gang to run all the job chains.+ gang <- forkGangActions numThreads+ $ zipWith (runChainIO dirScratch mChanResult)+ [1..]+ chains++ return gang +++-- | Run a chain of jobs in the IO monad,+-- writing job results to the given channel when they finish.+runChainIO + :: FilePath+ -> Maybe (TChan Result)+ -> Int+ -> Chain+ -> IO ()++runChainIO tmpDir mChanResult ixChain chain+ = do uid <- getUniqueId -- TODO: buildbox should handle this+ -- should not need process id.+ let state = buildStateDefault uid tmpDir++ runBuildWithState state+ $ runChainWithTChan mChanResult ixChain chain++ return ()+++-- | Get a unique(ish) id for this process.+-- The random seeds the global generator with the cpu time in psecs,+-- which should be good enough.+getUniqueId :: IO Integer+getUniqueId+ = randomRIO (0, 1000000000)
+ DDC/War/Interface/Controller.hs view
@@ -0,0 +1,246 @@++-- | Gang controller and user interface.+module DDC.War.Interface.Controller+ ( Config (..)+ , controller)+where+import DDC.War.Driver+import BuildBox.Pretty+import BuildBox.Control.Gang+import System.IO+import Control.Concurrent+import Control.Concurrent.STM.TChan+import Control.Monad.STM+import Control.Monad+import Data.Maybe+import Data.List+import DDC.War.Interface.VT100 as VT100+import qualified System.Cmd+++data Config+ = Config+ { -- | Allow the user to control the driver from the console, + -- and ask what to do interactively if a file is different than expected.+ configInteractive :: Bool ++ -- | Use VT100 colors in the output.+ , configColoredOutput :: Bool++ -- | Pad test names out to this column width.+ , configFormatPathWidth :: Int ++ -- | Suppress this prefix from the front of displayed test names.+ -- Test names usually have fully qualified paths,+ -- but we wont want to display the "/Users/whoever/devel/code/ddc/test"+ -- prefix.+ , configSuppressPrefix :: String }+ deriving Show++ ++-- | Gang controller and user interface for the war test driver.+-- This should be forked into its own thread, so it runs concurrently+-- with the gang that is actually executing the tests.+controller + :: Config+ -> Gang+ -> Int -- ^ Total number of chains.+ -> TChan Result -- ^ Channel to receive results from.+ -> IO [Result]++controller config gang chainsTotal chanResult+ = liftM reverse $ go_start []+ where + -- See if there is an input on the console.+ go_start :: [Result] -> IO [Result]+ go_start jobResults++ | configInteractive config+ = hReady stdin >>= \gotInput+ -> if gotInput+ then go_input jobResults+ else go_checkResult jobResults++ | otherwise+ = go_checkResult jobResults++ + -- We've got input on the console, wait for already running tests then bail out.+ go_input jobResults+ = do putStrLn "Interrupt. Waiting for running jobs (CTRL-C kills)..."+ flushGang gang+ return jobResults+++ -- See if any job results have been written to our input channel.+ go_checkResult jobResults+ = (atomically $ isEmptyTChan chanResult) >>= \empty'+ -> if empty'+ then do+ gangState <- getGangState gang+ if gangState == GangFinished++ -- No job results in channel, and the gang has finished.+ -- We're done, so return to caller.+ then do+ return jobResults++ -- No job results in channel, but the gang is still running.+ -- Spin until something else happens.+ else do+ threadDelay 10000+ go_start jobResults++ -- We've got a job result from the input channel.+ -- Read the result and pass it off to the result handler.+ else do+ jobResult <- atomically $ readTChan chanResult+ keepGoing <- handleResult config gang chainsTotal jobResult+ if keepGoing+ then go_start (jobResult : jobResults)+ else do+ killGang gang+ return (jobResult : jobResults)+++-- | Handle a job result.+-- Returns True if the controller should continue, +-- or False if we should shut down and return to the caller.+handleResult :: Config -> Gang -> Int -> Result -> IO Bool+handleResult config gang chainsTotal+ (Result chainIx jobIx jobId actionName product')+ | JobId testName wayName <- jobId+ , ProductStatus status _ <- product'+ = do let testName2 = fromMaybe testName + (stripPrefix (configSuppressPrefix config) testName)++ let width = configFormatPathWidth config++ putStrLn + $ render + $ parens (padR (length $ show chainsTotal)+ (ppr $ chainIx) + <> text "."+ <> ppr jobIx+ <> text "/" + <> ppr chainsTotal)+ <+> padL width (text testName2)+ <+> padL 5 (text wayName)+ <+> padL 8 (text actionName)+ <+> colorizeStatus config actionName (render status)++ hFlush stdout+ return True++ -- If a file is different than expected in interactive mode,+ -- then ask the user what to do about it.+ | ProductDiff fileRef fileOut fileDiff <- product'+ , configInteractive config+ = do + putStr $ "\n"+ ++ "-- Output Differs -------------------------------------------------------------\n"+ ++ " expected file: " ++ fileRef ++ "\n"+ ++ " actual file: " ++ fileOut ++ "\n"+ ++ replicate 80 '-' ++ "\n"++ -- Show the difference+ str <- readFile fileDiff+ putStr str+ hFlush stdout+ + -- Ask the user what to do about it, + -- and pause the gang while we're waiting for user input+ pauseGang gang+ keepGoing <- handleResult_askDiff fileRef fileOut fileDiff+ when keepGoing+ $ resumeGang gang++ return keepGoing++ -- If a file is different than expected in batch mode,+ -- then just print the status.+ | ProductDiff{} <- product'+ = handleResult config gang chainsTotal + $ Result chainIx jobIx jobId actionName+ $ ProductStatus (text "failed") False++ -- Bogus pattern match to avoid warning.+ | otherwise+ = error "DDC.War.Interface.Controller.handleResult: no match"+++handleResult_askDiff :: FilePath -> FilePath -> FilePath -> IO Bool+handleResult_askDiff fileRef fileOut fileDiff+ = do putStr $ replicate 80 '-' ++ "\n"+ ++ " (ENTER) continue (e) show expected (a) show actual\n"+ ++ " (CONTROL-C) quit (u) update expected\n"+ ++ "\n"+ ++ "? "++ hFlush stdout+ cmd <- hGetLine stdin++ let result+ -- continue, ignoring that the test gave a different result.+ | "" <- cmd+ = return True++ -- Print the expected output+ | ('e': _) <- cmd+ = do str <- readFile fileRef+ putStr $ replicate 80 '-' ++ "\n"+ putStr str+ handleResult_askDiff fileRef fileOut fileDiff++ -- Print the actual output+ | ('a': _) <- cmd+ = do str <- readFile fileOut+ putStr $ replicate 80 '-' ++ "\n"+ putStr str+ handleResult_askDiff fileRef fileOut fileDiff++ -- Update the expected output with the actual one+ | ('u': _) <- cmd+ = do System.Cmd.system + $ "cp " ++ fileOut ++ " " ++ fileRef++ return True++ -- Invalid Command+ | otherwise+ = do putStr $ "Invalid command.\n"+ handleResult_askDiff fileRef fileOut fileDiff+ + result+++colorizeStatus :: Config -> String -> String -> Doc+colorizeStatus config jobName status+ | not $ configColoredOutput config+ = text status++ | isPrefixOf "ok" status+ = colorDoc [Foreground Green] (text status)++ | isPrefixOf "success" status+ , jobName == "run"+ = colorDoc [Foreground Green] (text status)++ | isPrefixOf "success" status+ , jobName == "compile"+ = colorDoc [Foreground Blue] (text status)++ | isPrefixOf "failed" status+ = colorDoc [Foreground Red] (text status)++ | otherwise+ = text status+++colorDoc :: [VT100.Mode] -> Doc -> Doc+colorDoc vmode doc+ = text + $ concat [ setMode vmode+ , render doc+ , setMode [Reset] ]
+ DDC/War/Interface/VT100.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS -fno-warn-missing-signatures #-}+-- | Generation of VT100 terminal control codes.+module DDC.War.Interface.VT100 + ( Color(..), codeOfColor+ , Mode (..), codeOfMode+ , ModeState (..), modeStateInit, applyMode+ + , eraseDisplay+ , eraseLine+ , setCursorPos+ , moveCursorUp+ , moveCursorDown+ , moveCursorLeft+ , moveCursorRight+ , saveCursorPosition+ , restoreCursorPosition+ , setMode )+where+import Data.List++-- Color ----------------------------------------------------------------------+-- | VT100 / ANSI colors+data Color+ = Black+ | Red+ | Green+ | Yellow+ | Blue+ | Magenta+ | Cyan+ | White+ deriving (Show, Eq, Ord)++-- | Control code offset for rendering colors.+-- Need to add 30 for foreground, 40 for background to get real code.+codeOfColor :: Color -> Int+codeOfColor color+ = case color of+ Black -> 0+ Red -> 1+ Green -> 2+ Yellow -> 3+ Blue -> 4+ Magenta -> 5+ Cyan -> 6+ White -> 7+ ++-- Mode -----------------------------------------------------------------------+-- | Rendering mode commands.+data Mode+ = Reset+ | Bold+ | Dim+ | Underscore+ | Blink+ | Reverse+ | Concealed+ | Foreground Color+ | Background Color+ deriving (Show, Eq, Ord)+++-- | Control codes for rendering mode commands.+codeOfMode :: Mode -> Int+codeOfMode mode+ = case mode of+ Reset -> 0+ Bold -> 1+ Dim -> 3+ Underscore -> 4+ Blink -> 5+ Reverse -> 7+ Concealed -> 8+ Foreground color -> 30 + codeOfColor color+ Background color -> 40 + codeOfColor color+++-- ModeState ------------------------------------------------------------------+-- Model of VT100 terminal state, to help keep track what state+-- the terminal is in after accepting a string of commands.++data ModeState+ = ModeState+ { sBold :: Bool+ , sDim :: Bool+ , sUnderscore :: Bool+ , sBlink :: Bool+ , sReverse :: Bool+ , sConcealed :: Bool+ , sForeground :: Color+ , sBackground :: Color }+ deriving (Show, Eq)+ +modeStateInit+ = ModeState+ { sBold = False+ , sDim = False+ , sUnderscore = False+ , sBlink = False+ , sReverse = False+ , sConcealed = False+ , sForeground = White+ , sBackground = Black }+++applyMode :: ModeState -> Mode -> ModeState+applyMode state m+ = case m of+ Reset -> modeStateInit+ Bold -> state { sBold = True }+ Dim -> state { sDim = True }+ Underscore -> state { sUnderscore = True }+ Blink -> state { sBlink = True }+ Reverse -> state { sReverse = True }+ Concealed -> state { sConcealed = True }+ Foreground c -> state { sForeground = c }+ Background c -> state { sBackground = c }+++-- Commands -------------------------------------------------------------------++-- | Erase entire display.+eraseDisplay = "\27[2J"++-- | Erase current line of display.+eraseLine = "\27[K"++-- | Set the position of the cursor.+setCursorPos x y = "\27[" ++ show y ++ ";" ++ show x ++ "H"++-- | Move cursor up some number of lines.+moveCursorUp n = "\27[" ++ show n ++ "A"++-- | Move cursor down some number of lines.+moveCursorDown n = "\27[" ++ show n ++ "B"++-- | Move cursor right / forward some number of columns.+moveCursorRight n = "\27[" ++ show n ++ "C"++-- | Move cursor left / backward some number of columns.+moveCursorLeft n = "\27[" ++ show n ++ "D"++-- | Save cursor position +saveCursorPosition = "\27[s"++-- | Restore cursor position+restoreCursorPosition = "\27[u"++-- | Set graphics mode+setMode modes+ = "\27[" + ++ concat + (intersperse ";" + $ map (show . codeOfMode) modes) + ++ "m"+
+ DDC/War/Job.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# OPTIONS -fno-warn-orphans #-}+module DDC.War.Job where+import DDC.War.Driver.Base+import qualified DDC.War.Job.CompileDCE as CompileDCE+import qualified DDC.War.Job.CompileDS as CompileDS+import qualified DDC.War.Job.CompileHS as CompileHS+import qualified DDC.War.Job.Diff as Diff+import qualified DDC.War.Job.RunDCX as RunDCX+import qualified DDC.War.Job.RunExe as RunExe+import qualified DDC.War.Job.Shell as Shell+import BuildBox.Pretty+++instance Spec CompileDCE.Spec CompileDCE.Result where+ specActionName _ = "compile"+ buildFromSpec = CompileDCE.build+ productOfResult _ result + = ProductStatus (ppr result) (CompileDCE.resultSuccess result)+++instance Spec CompileDS.Spec CompileDS.Result where+ specActionName _ = "compile"+ buildFromSpec = CompileDS.build+ productOfResult _ result + = ProductStatus (ppr result) (CompileDS.resultSuccess result)+++instance Spec CompileHS.Spec CompileHS.Result where+ specActionName _ = "compile"+ buildFromSpec = CompileHS.build+ productOfResult _ result+ = ProductStatus (ppr result) (CompileHS.resultSuccess result)+++instance Spec Diff.Spec Diff.Result where+ specActionName _ = "diff"+ buildFromSpec = Diff.build+ productOfResult _ result+ = case result of+ Diff.ResultSame + -> ProductStatus (ppr result) True++ Diff.ResultDiff ref out diff + -> ProductDiff ref out diff+++instance Spec RunDCX.Spec RunDCX.Result where+ specActionName _ = "run"+ buildFromSpec = RunDCX.build+ productOfResult _ result+ = ProductStatus (ppr result) (RunDCX.resultSuccess result)+++instance Spec RunExe.Spec RunExe.Result where+ specActionName _ = "run"+ buildFromSpec = RunExe.build+ productOfResult _ result+ = ProductStatus (ppr result) (RunExe.resultSuccess result)+++instance Spec Shell.Spec Shell.Result where+ specActionName _ = "shell"+ buildFromSpec = Shell.build+ productOfResult _ result+ = ProductStatus (ppr result) (Shell.resultSuccess result)++++
+ DDC/War/Job/CompileDCE.hs view
@@ -0,0 +1,125 @@++module DDC.War.Job.CompileDCE+ ( Spec (..)+ , Result(..)+ , resultSuccess+ , build)+where+import BuildBox.Command.File+import BuildBox.Command.System+import BuildBox.Build.Benchmark+import BuildBox.Data.Physical+import BuildBox.IO.Directory+import BuildBox.Pretty+import BuildBox+import System.FilePath+import Control.Monad+import Data.List+++-- | Use ddci-core to compile/make file a DCE file+data Spec+ = Spec+ { -- | Root source file of the program (the 'Main.ds')+ specFile :: FilePath + + -- | Scratch dir to do the build in.+ , specScratchDir :: String++ -- | Put what DDC says to stdout here.+ , specCompileStdout :: FilePath+ + -- | Put what DDC says to stderr here.+ , specCompileStderr :: FilePath ++ -- | If Just, then we're making an executable, and put the binary here.+ -- Otherwise simply compile it+ , specMaybeMainBin :: Maybe FilePath + + -- | True if the compile is expected to succeed, else not.+ , specShouldSucceed :: Bool }+ deriving Show+++data Result+ = ResultSuccess Seconds+ | ResultUnexpectedFailure+ | ResultUnexpectedSuccess+ deriving Show++resultSuccess :: Result -> Bool+resultSuccess result+ = case result of+ ResultSuccess{} -> True+ _ -> False+++instance Pretty Result where+ ppr result+ = case result of + ResultSuccess seconds -> text "success" <+> parens (ppr seconds)+ ResultUnexpectedFailure -> text "failed"+ ResultUnexpectedSuccess -> text "unexpected"+++-- Build ----------------------------------------------------------------------+-- | Compile a Disciple Core Sea source file.+build :: Spec -> Build Result+build (Spec srcDCE+ buildDir mainCompOut mainCompErr+ mMainBin shouldSucceed)++ = do needs srcDCE+ needs "bin/ddci-core"++ -- The directory holding the Main.dce file.+ let (srcDir, _srcFile) = splitFileName srcDCE+ + -- Touch the .dce files to the build directory to ensure they're built.+ sources <- io+ $ liftM (filter (\f -> isSuffixOf ".dce" f))+ $ lsFilesIn srcDir++ ssystemq $ "touch " ++ (intercalate " " sources)++ -- ensure the output directory exists+ ensureDir buildDir++ -- Do the compile.+ let compile+ | Just mainBin <- mMainBin+ = do -- If there is an existing binary then remove it.+ ssystemq $ "rm -f " ++ mainBin++ -- Build the program.+ timeBuild+ $ systemTee False + ("bin/ddci-core"+ ++ " -set output " ++ mainBin+ ++ " -set outputdir " ++ buildDir+ ++ " -make " ++ srcDCE)+ ""++ -- Compile the program.+ | otherwise+ = do timeBuild+ $ systemTee False+ ("bin/ddci-core"+ ++ " -set outputdir " ++ buildDir+ ++ " -compile " ++ srcDCE)+ ""+ (time, (code, strOut, strErr))+ <- compile++ atomicWriteFile mainCompOut strOut+ atomicWriteFile mainCompErr strErr++ case code of+ ExitFailure _+ | shouldSucceed -> return ResultUnexpectedFailure+ + ExitSuccess+ | not shouldSucceed -> return ResultUnexpectedSuccess++ _ -> return $ ResultSuccess time+
+ DDC/War/Job/CompileDS.hs view
@@ -0,0 +1,137 @@++module DDC.War.Job.CompileDS+ ( Spec (..)+ , Result (..)+ , resultSuccess+ , build)+where+import BuildBox.Command.File+import BuildBox.Command.System+import BuildBox.Build.Benchmark+import BuildBox.Data.Physical+import BuildBox.IO.Directory+import BuildBox.Pretty+import BuildBox+import System.FilePath+import Control.Monad+import Data.List+++-- | Use DDC to compile a source file.+data Spec+ = Spec+ { -- | Root source file of the program (the 'Main.ds')+ specFile :: FilePath + + -- | Extra DDC options for building in this way.+ , specOptionsDDC :: [String] + + -- | Extra GHC RTS options for building in this way.+ , specOptionsRTS :: [String]+ + -- | Scratch dir to do the build in.+ , specScratchDir :: String++ -- | Put what DDC says to stdout here.+ , specCompileStdout :: FilePath+ + -- | Put what DDC says to stderr here.+ , specCompileStderr :: FilePath ++ -- | If Just, then we're making an executable, and put the binary here.+ -- Otherwise simply compile it+ , specMaybeMainBin :: Maybe FilePath + + -- | True if the compile is expected to succeed, else not.+ , specShouldSucceed :: Bool }+ deriving Show+++data Result+ = ResultSuccess Seconds+ | ResultUnexpectedSuccess+ | ResultUnexpectedFailure+ deriving Show++resultSuccess :: Result -> Bool+resultSuccess result+ = case result of+ ResultSuccess{} -> True+ _ -> False+++instance Pretty Result where+ ppr result + = case result of+ ResultSuccess seconds -> text "success" <+> parens (ppr seconds)+ ResultUnexpectedFailure -> text "failed"+ ResultUnexpectedSuccess -> text "unexpected"+++-- | Compile a Disciple source file.+build :: Spec -> Build Result+build (Spec srcDS optionsDDC optionsRTS+ buildDir mainCompOut mainCompErr+ mMainBin shouldSucceed)++ = do needs srcDS+ needs "bin/ddc"+ + -- The directory holding the Main.ds file.+ let (srcDir, _srcFile) = splitFileName srcDS+ + -- Touch the .ds files to the build directory to ensure they're built.+ sources <- io+ $ liftM (filter (\f -> isSuffixOf ".ds" f || isSuffixOf ".build" f))+ $ lsFilesIn srcDir++ ssystemq $ "touch " ++ (intercalate " " sources)++ -- ensure the output directory exists+ ensureDir buildDir++ -- Do the compile.+ let compile+ | Just mainBin <- mMainBin+ = do + -- If there is an existing binary then remove it.+ ssystemq $ "rm -f " ++ mainBin++ -- Build the program.+ timeBuild + $ systemTee False + ("bin/ddc"+ ++ " -v -make " ++ srcDS+ ++ " -o " ++ mainBin+ ++ " -outputdir " ++ buildDir+ ++ " " ++ intercalate " " optionsDDC+ ++ " +RTS " ++ intercalate " " optionsRTS)+ ""+++ -- Compile the program.+ | otherwise+ = do timeBuild+ $ systemTee False+ ("bin/ddc"+ ++ " -c " ++ srcDS+ ++ " -outputdir " ++ buildDir+ ++ " " ++ intercalate " " optionsDDC+ ++ " +RTS " ++ intercalate " " optionsRTS)+ ""++ (time, (code, strOut, strErr))+ <- compile+ + atomicWriteFile mainCompOut strOut+ atomicWriteFile mainCompErr strErr++ case code of+ ExitFailure _+ | shouldSucceed -> return ResultUnexpectedFailure+ + ExitSuccess+ | not shouldSucceed -> return ResultUnexpectedSuccess++ _ -> return $ ResultSuccess time+
+ DDC/War/Job/CompileHS.hs view
@@ -0,0 +1,119 @@++module DDC.War.Job.CompileHS+ ( Spec (..)+ , Result (..)+ , resultSuccess+ , build)+where+import BuildBox.Command.File+import BuildBox.Command.System+import BuildBox.Build.Benchmark+import BuildBox.Data.Physical+import BuildBox.IO.Directory+import BuildBox.Pretty+import BuildBox+import System.FilePath+import System.Directory+import Control.Monad+import Data.List+++-- | Use GHC to compile/make file.+data Spec+ = Spec + { -- | Root source file of the program (the 'Main.ds')+ specFile :: FilePath + + -- | Extra DDC options for building in this way.+ , specOptionsGHC :: [String] + + -- | Scratch dir to do the build in.+ , specScratchDir :: String++ -- | Put what DDC says to stdout here.+ , specCompileStdout :: FilePath+ + -- | Put what DDC says to stderr here.+ , specCompileStderr :: FilePath ++ -- | If Just, then we're making an executable, and put the binary here.+ -- Otherwise simply compile it+ , specMainBin :: FilePath }+ deriving Show+++data Result+ = ResultSuccess Seconds+ | ResultFailure+ deriving Show++resultSuccess :: Result -> Bool+resultSuccess result+ = case result of+ ResultSuccess{} -> True+ _ -> False+++instance Pretty Result where+ ppr result + = case result of+ ResultSuccess seconds -> text "success" <+> parens (ppr seconds)+ ResultFailure -> text "failed"+++-- | Compile a Haskell Source File+build :: Spec -> Build Result+build (Spec srcHS _optionsGHC+ buildDir mainCompOut mainCompErr+ mainBin)++ = do needs srcHS+ + -- The directory holding the Main.hs file.+ let (srcDir, srcFile) = splitFileName srcHS+ + -- Copy the .hs files to the build directory.+ -- This freshens them and ensures we won't conflict with other make jobs+ -- running on the same source files, but in different ways.+ ensureDir buildDir+ sources <- io+ $ liftM (filter (\f -> isSuffixOf ".hs" f))+ $ lsFilesIn srcDir++ _ <- ssystemq $ "cp " ++ (intercalate " " sources) ++ " " ++ buildDir++ -- The copied version of the root source file.+ let srcCopyHS = buildDir ++ "/" ++ srcFile+ let buildMk = buildDir ++ "/build.mk"+ + -- We're doing this via a makefile so we get the ghc flags and options+ -- from the DDC build system. The paths in the make file need to be in+ -- posix form with '/' as the separators.+ currentDir <- io $ getCurrentDirectory+ let hacks f = map (\z -> if z == '\\' then '/' else z) f+ let mainBin' = hacks $ makeRelative currentDir mainBin+ let srcCopyHS' = hacks $ makeRelative currentDir srcCopyHS+ + genBuildMk buildMk mainBin' srcCopyHS'+ + (time, (code, strOut, strErr))+ <- timeBuild+ $ systemTee False+ ("make -f " ++ buildMk)+ ""+ atomicWriteFile mainCompOut strOut+ atomicWriteFile mainCompErr strErr++ case code of+ ExitSuccess -> return $ ResultSuccess time+ ExitFailure _ -> return ResultFailure+ ++genBuildMk :: FilePath -> String -> String -> Build ()+genBuildMk outfile mainBin mainHs+ = do let str = "# Generated Makefile\n\n"+ ++ "include make/build.mk\n\n"+ ++ mainBin ++ " : " ++ mainHs ++ "\n"+ ++ "\t$(GHC) $(GHC_LANGUAGE) $(DDC_PACKAGES) -ipackages/ddc-main --make $^ -o $@\n\n"+ io $ writeFile outfile str+
+ DDC/War/Job/Diff.hs view
@@ -0,0 +1,72 @@++module DDC.War.Job.Diff+ ( Spec (..)+ , Result (..)+ , resultSuccess + , build)+where+import BuildBox.Command.File+import BuildBox.Command.System+import BuildBox.Pretty+import BuildBox+++-- | Diff two files.+data Spec+ = Spec+ { -- | The baseline file.+ specFile :: FilePath + + -- | File produced that we want to compare with the baseline.+ , specFileOut :: FilePath + + -- | Put the result of the diff here.+ , specFileDiff :: FilePath }+ deriving Show+++data Result+ = ResultSame++ | ResultDiff + { resultFileRef :: FilePath+ , resultFileOut :: FilePath+ , resultFileDiff :: FilePath }+++resultSuccess :: Result -> Bool+resultSuccess result+ = case result of+ ResultSame{} -> True+ _ -> False+++instance Pretty Result where+ ppr result+ = case result of+ ResultSame -> text "ok"+ ResultDiff{} -> text "diff"++++-- | Compare two files for differences.+build :: Spec -> Build Result+build (Spec fileRef fileOut fileDiff)+ = do needs fileRef+ needs fileOut+ + let diffExe = "diff"+ + -- Run the binary.+ (_code, strOut, _strErr)+ <- systemTee False + (diffExe ++ " " ++ fileRef ++ " " ++ fileOut)+ ""+ + -- Write its output to file.+ atomicWriteFile fileDiff strOut++ if strOut == ""+ then return $ ResultSame+ else return $ ResultDiff fileRef fileOut fileDiff+
+ DDC/War/Job/RunDCX.hs view
@@ -0,0 +1,78 @@++module DDC.War.Job.RunDCX+ ( Spec (..)+ , Result (..)+ , resultSuccess+ , build)+where+import BuildBox.Command.File+import BuildBox.Command.System+import BuildBox.Build.Benchmark+import BuildBox.Data.Physical+import BuildBox.Pretty+import BuildBox+import System.Directory+++-- | Feed a file into DDCi-core +data Spec+ = Spec+ { -- | Root source file of the program (the 'Main.ds')+ specFile :: FilePath + + -- | Scratch dir to do the build in.+ , specScratchDir :: String++ -- | Put what DDC says to stdout here.+ , specCompileStdout :: FilePath+ + -- | Put what DDC says to stderr here.+ , specCompileStderr :: FilePath }+ deriving Show+++data Result+ = ResultSuccess Seconds+ | ResultFailure+ deriving Show+++resultSuccess :: Result -> Bool+resultSuccess result+ = case result of+ ResultSuccess{} -> True+ _ -> False+++instance Pretty Result where+ ppr result + = case result of+ ResultSuccess seconds -> text "success" <+> parens (ppr seconds)+ ResultFailure -> text "failed"+++-- | Compile a Haskell Source File+build :: Spec -> Build Result+build (Spec srcDCX+ buildDir testRunStdout testRunStderr)++ = do needs srcDCX+ needs "bin/ddci-core"++ -- ensure the output directory exists+ ensureDir buildDir++ ddciBin' <- io $ canonicalizePath "bin/ddci-core"++ (time, (code, strOut, strErr))+ <- timeBuild+ $ systemTee False+ (ddciBin' ++ " --batch " ++ srcDCX)+ ""+ atomicWriteFile testRunStdout strOut+ atomicWriteFile testRunStderr strErr++ case code of+ ExitSuccess -> return $ ResultSuccess time+ _ -> return $ ResultFailure+
+ DDC/War/Job/RunExe.hs view
@@ -0,0 +1,86 @@++module DDC.War.Job.RunExe+ ( Spec (..)+ , Result (..)+ , resultSuccess+ , build)+where+import BuildBox.Build.Benchmark+import BuildBox.Command.File+import BuildBox.Command.System+import BuildBox.Data.Physical+import BuildBox.Pretty+import BuildBox+import Data.List++-- | Run a binary.+data Spec+ = Spec+ { -- | The main source file this binary was built from.+ specFileSrc :: FilePath++ -- | Binary to run.+ , specFileBin :: FilePath + + -- | Command line arguments to pass.+ , specCmdArgs :: [String]++ -- | Put what binary said on stdout here.+ , specRunStdout :: FilePath+ + -- | Put what binary said on stderr here.+ , specRunStderr :: FilePath ++ -- | True if we expect the executable to succeed.+ , specShouldSucceed :: Bool }+ deriving Show+++data Result+ = ResultSuccess Seconds+ | ResultUnexpectedFailure+ | ResultUnexpectedSuccess+ deriving Show+++resultSuccess :: Result -> Bool+resultSuccess result+ = case result of+ ResultSuccess{} -> True+ _ -> False+++instance Pretty Result where+ ppr result + = case result of+ ResultSuccess seconds -> text "success" <+> parens (ppr seconds)+ ResultUnexpectedFailure -> text "failed"+ ResultUnexpectedSuccess -> text "unexpected"+++-- | Run a binary+build :: Spec -> Build Result+build (Spec _fileName+ mainBin args + mainRunOut mainRunErr+ shouldSucceed)+ = do + needs mainBin+ + -- Run the binary.+ (time, (code, strOut, strErr))+ <- timeBuild+ $ systemTee False (mainBin ++ " " ++ intercalate " " args) ""++ -- Write its output to files.+ atomicWriteFile mainRunOut strOut+ atomicWriteFile mainRunErr strErr+ + case code of+ ExitFailure _+ | shouldSucceed -> return ResultUnexpectedFailure++ ExitSuccess + | not shouldSucceed -> return ResultUnexpectedSuccess++ _ -> return $ ResultSuccess time
+ DDC/War/Job/Shell.hs view
@@ -0,0 +1,89 @@++module DDC.War.Job.Shell+ ( Spec (..)+ , Result (..)+ , resultSuccess+ , build)+where+import BuildBox.Command.File+import BuildBox.Command.System+import BuildBox.Build.Benchmark+import BuildBox.Data.Physical+import BuildBox.Pretty+import BuildBox+++-- | Run a shell script.+data Spec+ = Spec+ { -- | Shell script to run+ specShellSource :: FilePath++ -- | Source dir that the script is in.+ , specSourceDir :: FilePath++ -- | Scratch dir that the script can write files to.+ , specScratchDir :: FilePath++ -- | Put what DDC says to stdout here.+ , specShellStdout :: FilePath+ + -- | Put what DDC says to stderr here.+ , specShellStderr :: FilePath ++ -- | True if the compile is expected to succeed, else not.+ , specShouldSucceed :: Bool }+ deriving Show+++data Result+ = ResultSuccess Seconds+ | ResultUnexpectedSuccess+ | ResultUnexpectedFailure+ deriving Show+++resultSuccess :: Result -> Bool+resultSuccess result+ = case result of+ ResultSuccess{} -> True+ _ -> False+++instance Pretty Result where+ ppr result + = case result of+ ResultSuccess seconds -> text "success" <+> parens (ppr seconds)+ ResultUnexpectedFailure -> text "failed"+ ResultUnexpectedSuccess -> text "unexpected"+++-- | Run a binary+build :: Spec -> Build Result+build (Spec mainSH sourceDir scratchDir+ mainRunOut mainRunErr+ shouldSucceed)+ = do + needs mainSH+ ensureDir scratchDir+ + -- Run the binary.+ (time, (code, strOut, strErr))+ <- timeBuild+ $ systemTee False + ("sh " ++ mainSH ++ " " ++ sourceDir ++ " " ++ scratchDir) + ""+ + -- Write its output to files.+ atomicWriteFile mainRunOut strOut+ atomicWriteFile mainRunErr strErr+ + case code of+ ExitSuccess+ | shouldSucceed -> return $ ResultSuccess time+ | otherwise -> return ResultUnexpectedSuccess++ ExitFailure _+ | shouldSucceed -> return ResultUnexpectedFailure+ | otherwise -> return $ ResultSuccess time+
+ DDC/War/Option.hs view
@@ -0,0 +1,169 @@++module DDC.War.Option+ (parseOptions)+where+import DDC.War.Create.Way+import DDC.War.Config+import Data.Char+import DDC.War.Task.Test as T+import DDC.War.Task.Nightly as N+import qualified BuildBox.Command.Mail as B+import qualified BuildBox.Data.Schedule as B+++parseOptions :: [String] -> Config -> IO Config+parseOptions [] _ + = do printUsage Nothing+ error "Nothing to do..."++parseOptions args _+ | elem "-help" args || elem "--help" args+ = do printUsage Nothing+ error "Nothing to do..."++parseOptions args0 config0+ = return $ eat args0 config0+ where+ eat [] config = config+ eat args@(arg : rest) config+ | elem arg ["-d", "-debug"]+ = eat rest $ config { configDebug = True }++ | "-nightly" : dir : more <- args+ = case eatn more defaultNightlySpec of+ Left badArg -> error $ "Invalid argument " ++ show badArg+ Right nspec -> config { configNightly = Just (nspec { specLocalBuildDir = Just dir }) }++ | otherwise+ = case eatt args defaultTestSpec of+ Left badArg -> error $ "Invalid argument " ++ show badArg+ Right tspec -> config { configTest = Just tspec }+++ -- Parse options for test mode+ eatt [] spec = Right spec+ eatt args@(arg : rest) spec+ | elem arg ["-b", "-batch"]+ = eatt rest $ spec { T.specInteractive = False }++ | "-j" : sThreads : more <- args+ , all isDigit sThreads+ = eatt more $ spec { T.specThreads = read sThreads}++ | "-results" : file : more <- args+ = eatt more $ spec { T.specResultsFileAll = Just file }++ | "-results-failed" : file : more <- args+ = eatt more $ spec { T.specResultsFileFailed = Just file }++ | "+compway" : name : flags <- args+ , (wayFlags, more) <- break (\x -> take 1 x == "+") flags+ = eatt more $ spec { T.specWays = T.specWays spec ++ [Way name wayFlags []] }++ | "+runway" : name : flags <- args+ , (wayFlags, more) <- break (\x -> take 1 x == "+") flags+ = eatt more $ spec { T.specWays = T.specWays spec ++ [Way name [] wayFlags] }++ | '-' : _ <- arg+ = Left arg++ -- Accept dirs for test mode+ | otherwise+ = eatt rest $ spec { specTestDirs = specTestDirs spec ++ [arg]}+++ -- Parse options for nightly mode.+ eatn [] spec = Right spec+ eatn args@(_arg:_rest) spec+ | "-build-dir" : dir : more <- args+ = eatn more $ spec { N.specLocalBuildDir = Just dir }++ | "-daily" : time : more <- args+ = eatn more $ spec { N.specContinuous = Just $ B.Daily $ read time }++ | "-now" : more <- args+ = eatn more $ spec { N.specNow = True }++ | "-cleanup" : more <- args+ = eatn more $ spec { N.specCleanup = True }++ | "-sendmail" : more <- args+ = eatn more $ spec { N.specMailer = Just $ B.MailerSendmail "sendmail" [] }++ | "-msmtp" : port : more <- args+ = eatn more $ spec { N.specMailer = Just $ B.MailerMSMTP "msmtp" (Just $ read port) }++ | "-mail-from" : addr : more <- args+ = eatn more $ spec { N.specMailFrom = Just addr }++ | "-mail-to" : addr : more <- args+ = eatn more $ spec { N.specMailTo = Just addr }++ | "-log-userhost" : str : more <- args+ = eatn more $ spec { N.specLogUserHost = Just str }++ | "-log-remote-dir" : dir : more <- args+ = eatn more $ spec { N.specLogRemoteDir = Just dir }++ | "-log-remote-url" : url : more <- args+ = eatn more $ spec { N.specLogRemoteURL = Just url }++ | "-build-threads" : threads : more <- args+ , all isDigit threads+ , t <- read threads+ , t > 0+ = eatn more $ spec { N.specBuildThreads = t}++ eatn (arg : _) _+ = Left arg+++printUsage :: Maybe String -> IO ()+printUsage badArg+ = putStr + $ unlines+ $ maybe [] (\arg -> ["invalid argument " ++ arg]) badArg+ ++ [ "Usage: war [flags]"+ , " -help Display this help."+ , " -debug, -d Emit debugging info for the war test driver."+ , " -nightly <DIR> Become the nightly buildbot in this directory."+ , ""+ , " Test mode: war <TESTDIR> ..."+ , " -batch, -b Don't interactively ask what to do if a test fails."+ , " -j <INT> Set number of threads (jobs) to use." + , " -results <FILE> Log test results to this file."+ , " -results-failed <FILE> Log failed tests to this file."+ , " +compway <NAME> [OPTIONS] Also compile with these DDC options."+ , " +runway <NAME> [OPTIONS] Also run executables with these RTS options."+ , ""+ , " Buildbot mode: war -nightly <DIR> [flags] ..."+ , " -cleanup Delete build dir after a successful build."+ , " -daily <HH:MM:SS> Build every day at this time (in UTC)"+ , " -now ... and also do a build right now."+ , ""+ , " -sendmail (*) Use sendmail to report build results"+ , " -msmtp <PORT> (or) msmtp instead"+ , " -mail-from <ADDRESS> (*) ... and send from this address"+ , " -mail-to <ADDRESS> (*) ... to this address."+ , ""+ , " -log-userhost <USER@HOSTNAME> (*) Use 'scp' to copy logs to this server"+ , " -log-remote-dir <DIR> (*) ... to this remote directory"+ , " -log-remote-url <URL> (*) ... with the logs appearing at this public URL."+ , ""+ , " -ddc-snapshot <URL> (*) Download DDC snapshot from this URL."+ , " -ddc-repository <URL> (*) Update snapshot with this repository."+ , " -build-threads <INT> (*) Threads to use when building DDC."+ , ""+ , " (*) Defaults are:"+ , " -sendmail"+ , " -mail-from \"DDC Buildbot <overlord@ouroborus.net>\""+ , " -mail-to disciple-cafe@googlegroups.com"+ , " -log-userhost overlord@ouroborus.net"+ , " -log-remote-dir log/desire/ddc/head"+ , " -log-remote-url http://log.ouroborus.net/desire/ddc/head"+ , " -ddc-snapshot http://code.ouroborus.net/ddc/snapshot/ddc-head-latest.tgz"+ , " -ddc-repository http://code.ouroborus.net/ddc/ddc-head"+ , " -build-threads 1"+ , ""+ ]+
+ DDC/War/Task/Nightly.hs view
@@ -0,0 +1,279 @@+{-# OPTIONS -fno-warn-unused-matches #-}+-- | Run the nightly DDC build.+module DDC.War.Task.Nightly+ ( Spec (..)+ , Result (..)+ , build)+where+import BuildBox.Command.Mail+import BuildBox.Command.System+import BuildBox.Command.File+import BuildBox.Command.Environment+import BuildBox.Control.Cron+import BuildBox.Pretty+import BuildBox.Build+import BuildBox.Time+import BuildBox as BuildBox+import Control.Monad+import Data.Char++import System.FilePath.Posix as Remote+import System.FilePath as Local+++-- Spec -----------------------------------------------------------------------+data Spec+ = Spec+ { -- | Use this scratch directory to perform the build.+ specLocalBuildDir :: Maybe FilePath ++ -- | URL of DDC snapshot.tgz+ , specRemoteSnapshotURL :: String++ -- | URL of DDC repository, used to update the snapshot.+ , specRemoteRepoURL :: String ++ -- | Number of threads to use when building.+ , specBuildThreads :: Int++ -- | Cleanup after build+ , specCleanup :: Bool++ -- | If set build continuously+ , specContinuous :: Maybe When++ -- | If we're doing a continuous build, also build once on startup+ , specNow :: Bool+++ -- | Mailer to use to send build results,+ -- or Nothing if to not send mail.+ , specMailer :: Maybe Mailer++ -- | Send mail from this address.+ , specMailFrom :: Maybe String ++ -- | Send mail to this address.+ , specMailTo :: Maybe String +++ -- | User and host name to copy logs to eg 'overlord@deluge.ouroborus.net'+ , specLogUserHost :: Maybe String++ -- | Copy logs into this directory on the server+ , specLogRemoteDir :: Maybe String++ -- | HTTP address of where the above logs appear+ , specLogRemoteURL :: Maybe String }+++ deriving Show+++-- Result ---------------------------------------------------------------------+data Result+ = ResultSuccess+ | ResultFailure+++instance Pretty Result where+ ppr result+ = case result of+ ResultSuccess -> text "success"+ ResultFailure -> text "failure"+++-- Build ----------------------------------------------------------------------+-- | Run the nightly DDC build.+build :: Spec -> Build Result+build spec+ = case specContinuous spec of+ -- Do a one-shot build.+ Nothing + -> buildCatch spec++ -- Continuous build+ Just whence + -> do outLn $ "* Starting cron loop"+ cronLoop + $ makeSchedule + [ ("nightly"+ , whence+ , if specNow spec + then Just Immediate + else Nothing+ , buildCatch spec >> return ()) ]++ -- The cron loop will quit if the build died and we couldn't+ -- send a failure message. If that happens then give up completely.+ return ResultFailure+++buildCatch :: Spec -> Build Result+buildCatch spec+ = BuildBox.catch + (buildProject spec) + (\err -> do+ postFailure spec err+ return ResultFailure)+++buildProject :: Spec -> Build Result+buildProject spec+ = do + strTime <- io $ getStampyTime+ let Just localBuildDir = specLocalBuildDir spec + let buildDir = localBuildDir Local.</> strTime++ let urlSnapshot = specRemoteSnapshotURL spec+ let urlRepo = specRemoteRepoURL spec+ let buildThreads = specBuildThreads spec++ ensureDir buildDir+ inDir buildDir+ $ do + outLn "* Creating log directory"+ ensureDir "log"+ + outLn "* Downloading snapshot"+ (getOut, getErr) <- ssystem $ "wget --progress=bar " ++ urlSnapshot+ io $ writeFile "log/01-wget.stdout" getOut+ io $ writeFile "log/01-wget.stderr" getErr++ needs (takeFileName urlSnapshot)+ outLn "* Unpacking snapshot"+ ssystem $ "tar zxf " ++ takeFileName urlSnapshot++ inDir "ddc-head"+ $ do+ outLn "* Updating shapshot"+ (darcsOut, darcsErr) <- ssystem $ "darcs pull -av " ++ urlRepo+ io $ writeFile "../log/02-darcs.stdout" darcsOut+ io $ writeFile "../log/02-darcs.stderr" darcsErr++ outLn "* Writing build config"+ needs "make"+ io $ writeFile "make/config-override.mk" + $ unlines ["THREADS = " ++ show buildThreads]++ outLn "* Building project"+ needs "Makefile"+ (makeOut, makeErr) <- ssystem $ "make nightly"+ io $ writeFile "../log/03-make.stdout" makeOut+ io $ writeFile "../log/03-make.stderr" makeErr++ outLn "* Copying results"+ needs "war.results"+ needs "war.failed"+ ssystem "cp war.results ../log"+ ssystem "cp war.failed ../log"++ return ()++ -- Copy logs to remote host.+ copyLogs spec strTime++ -- Send mail reporting build success including failed tests.+ strFailed <- io $ readFile "log/war.failed"+ postSuccess spec strTime strFailed++ when (specCleanup spec)+ $ do outLn "* Cleaning up"+ clobberDir buildDir++ return ResultSuccess+++-- | Copy logs to the remote host+copyLogs :: Spec -> String -> Build ()+copyLogs spec strTime+ | Just userHost <- specLogUserHost spec+ , Just logDir <- specLogRemoteDir spec+ = do + outLn $ "* Copying logs to " ++ userHost++ let dir = logDir Remote.</> strTime++ -- Make the destination directory.+ sesystemq $ "ssh " ++ userHost ++ " mkdir -p " ++ dir++ -- Copy the files.+ sesystemq $ "scp -r log/* " ++ userHost ++ ":" ++ dir++ return ()++ | otherwise = return ()+++-- | Send mail reporting build success.+postSuccess :: Spec -> String -> String -> Build ()+postSuccess spec strTime strFailed+ | Just mailer <- specMailer spec+ , Just addrFrom <- specMailFrom spec+ , Just addrTo <- specMailTo spec+ = do + outLn "* Reporting build success"++ -- The overall build succeeded, but some tests might have failed.+ let nFailed = length $ lines strFailed++ -- Create message subject.+ hostId <- getHostId+ let subject + | nFailed == 0 + = "DDC Build Success (" ++ hostId ++ ")"++ | otherwise + = "DDC Build Success (" ++ hostId ++ ") with " ++ show nFailed ++ " failed tests"++ -- Create message body.+ let strLog + = case specLogRemoteURL spec of+ Nothing -> ""+ Just url -> "Logs are at: " ++ url ++ "/" ++ strTime ++ "\n\n"++ let body = strLog ++ strFailed++ -- Send the mail+ mail <- createMailWithCurrentTime addrFrom addrTo subject body++ sendMailWithMailer mail mailer++-- don't send mail.+postSuccess _ _ _ = return ()+++-- | Send mail reporting build failure.+postFailure :: Spec -> BuildError -> Build ()+postFailure spec err+ | Just mailer <- specMailer spec+ , Just addrFrom <- specMailFrom spec+ , Just addrTo <- specMailTo spec+ = do + outLn "* Reporting build failure"++ -- Create message subject.+ hostId <- getHostId+ let subject = "DDC Build FAILURE (" ++ hostId ++ ")"++ -- Create message body.+ let body = render $ ppr err++ -- Send the mail+ mail <- createMailWithCurrentTime addrFrom addrTo subject body++ sendMailWithMailer mail mailer++-- don't send mail+postFailure spec strFailed = return ()+++-- | Build a string identifying this host+getHostId :: Build String+getHostId+ = do+ hostName <- liftM (takeWhile (not . (==) '.')) $ getHostName+ machName <- liftM (takeWhile (not . isSpace)) $ sesystemq "uname -m"+ osName <- liftM (takeWhile (not . isSpace)) $ sesystemq "uname"+ return $ hostName ++ "." ++ machName ++ "." ++ osName+
+ DDC/War/Task/Test.hs view
@@ -0,0 +1,200 @@++module DDC.War.Task.Test+ ( Spec (..)+ , Result (..)+ , build)+where+import DDC.War.Create++import qualified DDC.War.Interface.Controller as Controller++import DDC.War.Driver (Chain(..))+import qualified DDC.War.Driver as Driver+import qualified DDC.War.Driver.Gang as Driver++import BuildBox.Control.Gang+import BuildBox.IO.Directory+import BuildBox.Pretty+import BuildBox++import System.Directory+import Control.Concurrent+import Control.Concurrent.STM.TChan+import Control.Monad+import Control.Monad.STM+import Control.Exception+import Data.List++import qualified Data.Sequence as Seq+import qualified Data.Foldable as Seq+import qualified Data.Set as Set+import qualified Data.Traversable as Seq+++-- | Run regression tests.+data Spec+ = Spec+ { -- | Start looking for tests from these directories.+ specTestDirs :: [FilePath]++ -- | Ways to run each test.+ , specWays :: [Way]++ -- | Number of concurrent threads to use.+ , specThreads :: Int++ -- | Ask user what to do about unexpected test outputs interactively.+ , specInteractive :: Bool ++ -- | Pad test names out to this column width in log files.+ , specFormatPathWidth :: Int++ -- | Write all test results to this file.+ , specResultsFileAll :: Maybe FilePath++ -- | Write only failed test results to this file+ , specResultsFileFailed :: Maybe FilePath }+ deriving Show+++data Result+ = ResultSuccess+ deriving Show+++instance Pretty Result where+ ppr result+ = case result of+ ResultSuccess -> text "success"+++build :: Spec -> Build Result+build spec+ = do+ currentDir <- io $ getCurrentDirectory++ -- All the starting test directories from the command line.+ testDirs <- io $ mapM (makeRelativeToCurrentDirectory <=< canonicalizePath)+ $ specTestDirs spec++ -- Trace all the files reachable from these directories.+ testFilesRaw <- io $ liftM (join . Seq.fromList)+ $ mapM traceFilesFrom testDirs+ + -- Canonicalize all the paths and put them in a set (which sorts them)+ testFilesSet <- io $ liftM (Set.fromList . Seq.toList)+ $ Seq.mapM canonicalizePath+ $ testFilesRaw++ -- Skip over files with 'skip' in the path,+ -- and don't decend into our own build dirs.+ let testFilesSorted+ = filter (not . isInfixOf "skip-")+ $ filter (not . isInfixOf "-skip")+ $ filter (not . isInfixOf "war-")+ $ Set.toList testFilesSet++ let testFilesSortedSet+ = Set.fromList testFilesSorted++ -- Create test chains based on the files we have.+ let ways'+ = case specWays spec of+ [] -> [Way "std" [] []]+ ways -> ways++ let chains :: [Chain]+ chains = concat + [ concat $ map (\way -> create way testFilesSortedSet file) ways'+ | file <- testFilesSorted]++ -- Suppress this prefix from the front of test names when we display them.+ let prefix = currentDir ++ "/"++ -- Run all the chains.+ results <- io $ runChainsWithControllerIO prefix spec chains+ + -- Write all results to file if we were asked for it+ let chainsTotal = length chains+ let pathWidth = specFormatPathWidth spec+ let pprResult = render . Driver.prettyResult chainsTotal prefix pathWidth+ (case specResultsFileAll spec of+ Nothing -> return ()+ Just file -> io $ writeFile file + $ unlines + $ map pprResult+ $ results)++ -- Write failed results to file if we were asked for it.+ let wasSuccess p+ = case p of+ Driver.ProductStatus _ True -> True+ _ -> False+ (case specResultsFileFailed spec of + Nothing -> return ()+ Just file -> io $ writeFile file+ $ unlines+ $ map pprResult+ $ filter (not . wasSuccess . Driver.resultProduct)+ $ results)++ return ResultSuccess+++-- | Fork threads to run job chains.+-- We display test results interactivly on the console,+-- as well as allowing the user to interrupt by pressing ENTER.+--+-- In batch mode: if we get a ResultDiff saying a test file is different+-- then just treat it as failed.+--+-- In non-batch mode: if we get a ResultDiff then use the controller+-- to ask the user what to do about it interactively.+--+runChainsWithControllerIO+ :: String -- ^ Suppress this prefix from the front of test names.+ -> Spec -- ^ Build configuration.+ -> [Chain] -- ^ Chains of jobs to run.+ -> IO [Driver.Result]++runChainsWithControllerIO prefix spec chains+ = do + -- Count the total number of chains for the status display.+ let chainsTotal = length chains++ -- Create a new channel to communicate between the test driver and the+ -- controller. As each test finishes, the driver writes the result to the+ -- channel, and the controller reads the results and displays them + -- on the console.+ (chanResult :: TChan Driver.Result)+ <- atomically $ newTChan+ + -- Fork a gang to run all the job chains.+ gang <- Driver.forkChainsIO + (specThreads spec) "/tmp"+ (Just chanResult) chains++ -- Fork the controller to display results and manage user input.+ -- When the controller it done it also writes all the results+ -- it received to an MVar to send them back to the main thread.+ let configController+ = Controller.Config+ { Controller.configFormatPathWidth = specFormatPathWidth spec+ , Controller.configInteractive = specInteractive spec + , Controller.configColoredOutput = specInteractive spec+ , Controller.configSuppressPrefix = prefix }++ varResults <- newEmptyMVar+ forkIO + $ do results <- Controller.controller configController gang chainsTotal chanResult+ putMVar varResults results+ `finally` (putMVar varResults [])++ -- Wait for the controller to finish.+ results <- takeMVar varResults++ -- Wait until the gang is finished running chains, + -- or has been killed by the controller.+ joinGang gang++ return results
+ LICENSE view
@@ -0,0 +1,30 @@+--------------------------------------------------------------------------------+The Disciplined Disciple Compiler License (MIT style)++Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force+All rights reversed.++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++-------------------------------------------------------------------------------+Under Australian law copyright is free and automatic.+By contributing to DDC authors grant all rights they have regarding their+contributions to the other members of the Disciplined Disciple Compiler Strike+Force, past, present and future, as well as placing their contributions under+the above license.++Use "darcs show authors" to get a list of Strike Force members.++--------------------------------------------------------------------------------+Redistributions of libraries in ./external are governed by their own licenses:++ - TinyPTC GNU Lesser General Public License+
+ Main.hs view
@@ -0,0 +1,43 @@++import DDC.War.Config+import DDC.War.Option+import BuildBox.Pretty+import BuildBox+import System.Environment+import qualified DDC.War.Task.Nightly as N+import qualified DDC.War.Task.Test as T+++main :: IO ()+main + = do -- Parse command line options, and exit if they're no good.+ args <- getArgs+ config <- parseOptions args defaultConfig+ + case configNightly config of+ Nothing + -> let Just spec = configTest config+ in mainTest spec++ Just spec + -> mainNightly spec+++-- | Run tests from the provided directories+mainTest :: T.Spec -> IO ()+mainTest spec+ = let + in do+ result <- runBuild "/tmp" $ T.build spec+ case result of+ Left err -> error $ render $ ppr err+ Right _ -> return ()+++-- | Run the nightly build.+mainNightly :: N.Spec -> IO ()+mainNightly spec+ = do result <- runBuild "/tmp" $ N.build spec+ case result of+ Left err -> error $ render $ ppr err+ Right result' -> putStrLn $ render $ ppr result'
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ddc-war.cabal view
@@ -0,0 +1,68 @@+Name: ddc-war+Version: 0.2.1.1+License: MIT+License-file: LICENSE+Author: The Disciplined Disciple Compiler Strike Force+Maintainer: Ben Lippmeier <benl@ouroborus.net>+Build-Type: Simple+Cabal-Version: >=1.6+Stability: experimental+Category: Compilers/Interpreters+Homepage: http://disciple.ouroborus.net+Bug-reports: disciple@ouroborus.net+Synopsis: Disciplined Disciple Compiler test driver and buildbot.+Description: Disciplined Disciple Compiler test driver and buildbot.++Executable ddc-war+ Build-depends:+ base == 4.5.*,+ containers == 0.4.*,+ stm == 2.2.*,+ directory == 1.1.*,+ buildbox == 2.1.*,+ random == 1.0.*,+ process == 1.1.*,+ filepath == 1.3.*++ Main-is:+ Main.hs+ + Other-modules:+ DDC.War.Create.CreateDCE+ DDC.War.Create.CreateDCX+ DDC.War.Create.CreateMainDS+ DDC.War.Create.CreateMainHS+ DDC.War.Create.CreateMainSH+ DDC.War.Create.CreateTestDS+ DDC.War.Create.Way+ DDC.War.Driver.Base+ DDC.War.Driver.Chain+ DDC.War.Driver.Gang+ DDC.War.Interface.Controller+ DDC.War.Interface.VT100+ DDC.War.Job.CompileDCE+ DDC.War.Job.CompileDS+ DDC.War.Job.CompileHS+ DDC.War.Job.Diff+ DDC.War.Job.RunDCX+ DDC.War.Job.RunExe+ DDC.War.Job.Shell+ DDC.War.Task.Nightly+ DDC.War.Task.Test+ DDC.War.Config+ DDC.War.Create+ DDC.War.Driver+ DDC.War.Job+ DDC.War.Option++ Extensions:+ PatternGuards+ ExistentialQuantification+ MultiParamTypeClasses+ FunctionalDependencies+ ScopedTypeVariables++ ghc-options:+ -Wall -O2+ -fno-warn-unused-do-bind+ -threaded