bake 0.2 → 0.3

raw patch · 42 files changed

+3888/−1263 lines, 42 filesdep +containersdep +direct-sqlitedep +disk-free-spacedep ~extradep ~shakePVP ok

version bump matches the API change (PVP)

Dependencies added: containers, direct-sqlite, disk-free-space, old-locale, safe, smtp-mail, sqlite-simple, transformers, unordered-containers

Dependency ranges changed: extra, shake

API changes (from Hackage documentation)

Files

• CHANGES.txt +4/−0
• LICENSE +1/−1
• README.md +83/−0
• bake.cabal +46/−18
• src/Development/Bake.hs +14/−11
• src/Development/Bake/Args.hs +0/−101
• src/Development/Bake/Build.hs +0/−68
• src/Development/Bake/Client.hs +0/−58
• src/Development/Bake/Core/Args.hs +153/−0
• src/Development/Bake/Core/Client.hs +59/−0
• src/Development/Bake/Core/GC.hs +66/−0
• src/Development/Bake/Core/Message.hs +174/−0
• src/Development/Bake/Core/Run.hs +61/−0
• src/Development/Bake/Core/Send.hs +39/−0
• src/Development/Bake/Core/Type.hs +220/−0
• src/Development/Bake/Email.hs +10/−6
• src/Development/Bake/Format.hs +0/−39
• src/Development/Bake/Git.hs +126/−55
• src/Development/Bake/Message.hs +0/−129
• src/Development/Bake/Pretty.hs +18/−14
• src/Development/Bake/Send.hs +0/−25
• src/Development/Bake/Server/Brain.hs +297/−0
• src/Development/Bake/Server/Brains.hs +0/−107
• src/Development/Bake/Server/Database.hs +123/−0
• src/Development/Bake/Server/Memory.hs +61/−0
• src/Development/Bake/Server/Property.hs +87/−0
• src/Development/Bake/Server/Start.hs +106/−103
• src/Development/Bake/Server/Stats.hs +132/−0
• src/Development/Bake/Server/Store.hs +382/−0
• src/Development/Bake/Server/Type.hs +0/−34
• src/Development/Bake/Server/Web.hs +368/−140
• src/Development/Bake/StepGit.hs +108/−0
• src/Development/Bake/Test/Simulate.hs +265/−0
• src/Development/Bake/Type.hs +0/−188
• src/Development/Bake/Util.hs +0/−51
• src/Development/Bake/Web.hs +0/−77
• src/Example.hs +27/−27
• src/General/Database.hs +245/−0
• src/General/Extra.hs +319/−0
• src/General/HTML.hs +180/−0
• src/General/Web.hs +92/−0
• src/Test.hs +22/−11

@@ -1,5 +1,9 @@ Changelog for Bake +0.3+    Add persistence to an SQLite db+    Add ping expiration+    Start testing as soon as you are launched 0.2     Require extra-0.3     Lots of work on lots of things

@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2014.+Copyright Neil Mitchell 2014-2015. All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -0,0 +1,83 @@+# Bake [![Hackage version](https://img.shields.io/hackage/v/bake.svg?style=flat)](https://hackage.haskell.org/package/bake) [![Build Status](https://img.shields.io/travis/ndmitchell/bake.svg?style=flat)](https://travis-ci.org/ndmitchell/bake)++**Warning: This project is still under heavy development and you are recommended to use the Git repo rather than a packaged release.**++Bake is a continuous integration server, designed for large, productive, semi-trusted teams. In particular it primarily targets:++* _Large teams_ where there are at least several contributors working full-time on a single code base.+* _Productive teams_ which are regularly pushing code, many times a day.+* _Semi-trusted teams_ where code does not go through manual code review, but code does need to pass a test suite and perhaps some static analysis. People are assumed to be fallible.++To give a flavour, the web GUI looks of a running Bake system looks like:++![](https://raw.githubusercontent.com/ndmitchell/bake/master/screenshot-part.png)++_Acknowledgements:_ The name "Bake" is thanks to Andy Adams-Moran.+++## The Design++Bake is a Haskell library that can be used to put together a continuous integration server. To run Bake you start a single server for your project, which coordinates tasks, provides an HTTP API for submitting new patches, and a web-based GUI for viewing the progress of your patches. You also run some Bake clients which run the tests on behalf of the server. While Bake is written in Haskell, most of the tests are expected to just call some system command.++There are a few aspects that make Bake different from most alternatives:++* Patches are submitted to Bake, but are not applied to the main repo until they have passed all their tests. There is no way for someone to "break the build" - at all points the repo will build on all platforms and all tests will pass.+* Bake scales up so that even if you have 5 hours of testing and 50 commits a day it will not require 250 hours of computation per day. In order for Bake to prove that a set of patches pass a test, it does not have to test each patch individually.+* Bake allows multiple clients to run tests, even if some tests are only able to be run on some clients, allowing both parallelisation and specialisation (testing both Windows and Linux, for example).+* Bake can detect that tests are no longer valid, for example because they access a server that is no longer running, and report the issue without blaming the submitted patches.++## The Workflow++Bake is highly parametrisable, and can be reconfigured to support several different styles of use, but here I give one plausible workflow. Imagine a number of developers, somewhere between 5 and 50. Each developer has 1 or 2 active branches they are working on. You have a master branch, which developers merge from once a day. When a developer has completed something they push their branch to the Git repo and register the SHA1 with Bake. Bake then tests the patch on all tests (in conjunction with all other patches that got promoted) and if it passes merges it into the master branch. Once a day (say 7pm) you pause the incoming patches, ensure the queue has emptied, then resume.+++## An Example++The test suite provides both [an example configuration](https://github.com/ndmitchell/bake/blob/master/src/Example.hs) and [commands to drive it](https://github.com/ndmitchell/bake/blob/master/src/Test.hs). Here we annotate a slightly simplified version of the example, for lists of imports see the original code.++First we define an enumeration for where we want tests to run. Our server is going to require tests on both Windows and Linux before a `patch` is accepted.++    data Platform = Linux | Windows deriving (Show,Read)+    platforms = [Linux,Windows]++Next we define the `test` type. A `test` is something that must pass before a `patch` is accepted.++    data Action = Compile | Run Int deriving (Show,Read)++Our type is named `Action`. We have two distinct types of tests, compiling the code, and running the result with a particular argument. Now we need to supply some information about the tests:++    allTests = [(p,t) | p <- platforms, t <- Compile : map Run [1,10,0]]+    +    execute :: (Platform,Action) -> TestInfo (Platform,Action)+    execute (p,Compile) = matchOS p $ run $ do+        cmd "ghc --make Main.hs"+    execute (p,Run i) = require [(p,Compile)] $ matchOS p $ run $ do+        cmd ("." </> "Main") (show i)++We have to declare `allTests`, then list of all tests that must pass, and `execute`, which gives information about a test. Note that the `test` type is `(Platform,Action)`, so a test is a platform (where to run the test) and an `Action` (what to run). The `run` function gives an `IO` action to run, and `require` specifies dependencies. We use an auxiliary `matchOS` to detect whether a test is running on the right platform:++    #if WINDOWS+    myPlatform = Windows+    #else+    myPlatform = Linux+    #endif++    matchOS :: Platform -> TestInfo t -> TestInfo t+    matchOS p = suitable (return . (==) myPlatform)++We use the `suitable` function to declare whether a test can run on a particular client. Finally, we define the `main` function:++    main :: IO ()+    main = bake $+        ovenGit "http://example.com/myrepo.git" "master" $+        ovenTest readShowStringy (return allTests) execute+        defaultOven{ovenServer=("127.0.0.1",5000)}++We define `main = bake`, then fill in some configuration. We first declare we are working with Git, and give a repo name and branch name. Next we declare what the tests are, passing the information about the tests. Finally we give a host/port for the server, which we can visit in a web browser or access via the HTTP API.+++## Using the Example++Now we have defined the example, we need to start up some servers and clients using the command line for our tool. Assuming we compiled as `bake`, we can write `bake server` and `bake client` (we'll need to launch at least one client per OS). We can view the state by visiting `http://127.0.0.1:5000` in a web browser.++To add a patch we can run `bake addpatch --name=cb3c2a71`, using the SHA1 of the commit, which will try and integrate that patch into the `master` branch, after all the tests have passed.

@@ -1,13 +1,13 @@ cabal-version:      >= 1.10 build-type:         Simple name:               bake-version:            0.2+version:            0.3 license:            BSD3 license-file:       LICENSE category:           Development author:             Neil Mitchell <ndmitchell@gmail.com> maintainer:         Neil Mitchell <ndmitchell@gmail.com>-copyright:          Neil Mitchell 2014+copyright:          Neil Mitchell 2014-2015 synopsis:           Continuous integration system description:     Bake is a continuous integration server, designed for large, productive, semi-trusted teams.@@ -19,10 +19,11 @@     * /Semi-trusted teams/ where code does not go through manual code review, but code does need to pass a test suite and perhaps some static analysis. People are assumed not to be malicious, but are fallible. homepage:           https://github.com/ndmitchell/bake#readme bug-reports:        https://github.com/ndmitchell/bake/issues-tested-with:        GHC==7.8.2, GHC==7.6.3+tested-with:        GHC==7.10.1, GHC==7.8.4, GHC==7.6.3  extra-source-files:     CHANGES.txt+    README.md  data-files:     html/favicon.ico@@ -37,19 +38,28 @@     build-depends:         base == 4.*,         cmdargs >= 0.10,-        shake >= 0.10,+        shake >= 0.15,         directory,         bytestring,+        containers,         text,         time,         random,         hashable,+        transformers,         HTTP,+        safe,+        old-locale,         http-types,         deepseq,         filepath,         aeson,-        extra >= 0.3,+        sqlite-simple,+        direct-sqlite,+        disk-free-space,+        unordered-containers,+        smtp-mail,+        extra >= 1.1,         wai >= 3.0.1,         warp >= 3.0 @@ -57,22 +67,29 @@         Development.Bake      other-modules:-        Development.Bake.Args-        Development.Bake.Build-        Development.Bake.Client+        Development.Bake.Core.Args+        Development.Bake.Core.Client+        Development.Bake.Core.GC+        Development.Bake.Core.Message+        Development.Bake.Core.Run+        Development.Bake.Core.Send+        Development.Bake.Core.Type         Development.Bake.Email-        Development.Bake.Format         Development.Bake.Git-        Development.Bake.Message+        Development.Bake.StepGit         Development.Bake.Pretty-        Development.Bake.Send-        Development.Bake.Server.Brains+        Development.Bake.Server.Brain+        Development.Bake.Server.Database+        Development.Bake.Server.Memory+        Development.Bake.Server.Property         Development.Bake.Server.Start-        Development.Bake.Server.Type+        Development.Bake.Server.Stats+        Development.Bake.Server.Store         Development.Bake.Server.Web-        Development.Bake.Type-        Development.Bake.Util-        Development.Bake.Web+        General.Database+        General.Extra+        General.HTML+        General.Web         Paths_bake  -- don't use 'cabal test' since that loses the child stdout@@ -80,22 +97,33 @@     default-language: Haskell2010     hs-source-dirs: src     main-is: Test.hs-    other-modules: Example+    other-modules:+        Example+        Development.Bake.Test.Simulate     ghc-options: -threaded -main-is Test.main     build-depends:         base == 4.*,         cmdargs >= 0.10,-        shake >= 0.10,+        shake >= 0.15,         directory,         bytestring,+        containers,         text,+        old-locale,         time,         random,         hashable,         HTTP,+        safe,         http-types,+        transformers,         deepseq,         aeson,+        smtp-mail,+        disk-free-space,+        unordered-containers,+        sqlite-simple,+        direct-sqlite,         extra >= 0.2,         wai >= 3.0.1,         warp >= 3.0,

@@ -6,25 +6,28 @@     bake,     -- * Central types     Oven(..), defaultOven,-    Stringy(..), readShowStringy,+    Stringy(..),     -- ** Oven modifiers-    ovenTest, ovenGit, ovenNotifyStdout, ovenNotifyEmail, ovenPretty,-    ovenIncremental, incrementalDone,+    ovenTest,+    SHA1, ovenGit, ovenStepGit,+    ovenNotifyAdd, ovenNotifyStdout, ovenNotifyEmail,+    ovenPretty, ovenPrettyMerge,     -- ** TestInfo members-    TestInfo, run, threads, threadsAll, require, suitable,+    TestInfo, run, threads, threadsAll, depend, require, priority,     -- * Operations-    startServer, startClient,-    module Development.Bake.Send,+    startServer, startClient, garbageCollect,+    module Development.Bake.Core.Send,     -- * Utility types     Host, Port, Author     ) where -import Development.Bake.Type+import Development.Bake.Core.Type import Development.Bake.Server.Start-import Development.Bake.Client-import Development.Bake.Args-import Development.Bake.Send+import Development.Bake.Core.Client+import Development.Bake.Core.Args+import Development.Bake.Core.GC+import Development.Bake.Core.Send import Development.Bake.Git-import Development.Bake.Build+import Development.Bake.StepGit import Development.Bake.Pretty import Development.Bake.Email

@@ -1,101 +0,0 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}---- | Define a continuous integration system.-module Development.Bake.Args(-    bake-    ) where--import System.Console.CmdArgs-import Development.Bake.Type hiding (Client)-import Development.Bake.Client-import Development.Bake.Server.Start-import Development.Bake.Send-import Control.Exception.Extra-import Control.DeepSeq-import System.Directory-import Control.Monad.Extra-import Data.Maybe-import System.Random-import Paths_bake---data Bake-    = Server {port :: Port, author :: Author, name :: String, timeout :: Double, datadir :: FilePath}-    | Client {host :: Host, port :: Port, author :: Author, name :: String, threads :: Int, ping :: Double}-    | AddPatch {host :: Host, port :: Port, author :: Author, name :: String}-    | DelPatch {host :: Host, port :: Port, author :: Author, name :: String}-    | DelPatches {host :: Host, port :: Port, author :: Author}-    | Pause {host :: Host, port :: Port, author :: Author}-    | Unpause {host :: Host, port :: Port, author :: Author}-    | RunTest {output :: FilePath, test :: Maybe String, state :: String, patch :: [String]}-    | RunExtra {output :: FilePath, state :: String, patch :: [String]}-      deriving (Typeable,Data)---bakeMode = cmdArgsMode $ modes-    [Server{port = 0, author = "unknown", name = "", timeout = 5*60, datadir = ""}-    ,Client{host = "", threads = 1, ping = 60}-    ,AddPatch{}-    ,DelPatch{}-    ,DelPatches{}-    ,Pause{}-    ,Unpause{}-    ,RunTest "" Nothing "" []-    ,RunExtra "" "" []-    ] &= verbosity---- | The entry point to the system. Usually you will define:------ > main = bake myOven------   Where @myOven@ defines details about the server. The program---   deals with command line arguments, run @--help@ for details.-bake :: Oven state patch test -> IO ()-bake oven@Oven{..} = do-    x <- cmdArgsRun bakeMode-    case x of-        Server{..} -> do-            datadir <- canonicalizePath =<< if datadir == "" then getDataDir else return datadir-            startServer (getPort port) datadir author name timeout oven-        Client{..} -> do-            name <- if name /= "" then return name else pick defaultNames-            startClient (getHostPort host port) author name threads ping oven-        AddPatch{..} -> sendAddPatch (getHostPort host port) author =<< check "patch" ovenStringyPatch name-        DelPatch{..} -> sendDelPatch (getHostPort host port) author =<< check "patch" ovenStringyPatch name-        DelPatches{..} -> sendDelAllPatches (getHostPort host port) author-        Pause{..} -> sendPause (getHostPort host port) author-        Unpause{..} -> sendUnpause (getHostPort host port) author-        RunTest{..} -> do-            case test of-                Nothing -> do-                    res <- ovenPrepare-                        (stringyFrom ovenStringyState state)-                        (map (stringyFrom ovenStringyPatch) patch)-                    (yes,no) <- partitionM (testSuitable . ovenTestInfo) res-                    let op = map (stringyTo ovenStringyTest)-                    writeFile output $ show (op yes, op no)-                Just test -> do-                    testAction $ ovenTestInfo $ stringyFrom ovenStringyTest test-        RunExtra{..} -> do-            res <- ovenPatchExtra-                (stringyFrom ovenStringyState state)-                (fmap (stringyFrom ovenStringyPatch) $ listToMaybe patch)-            writeFile output $ show res-    where-        getPort p = if p == 0 then snd ovenServer else p-        getHostPort h p = (if h == "" then fst ovenServer else h, getPort p)---check :: String -> Stringy s -> String -> IO String-check typ Stringy{..} x = do-    res <- try_ $ evaluate $ force $ stringyTo $ stringyFrom x-    case res of-        Left err -> error $ "Couldn't stringify the " ++ typ ++ " " ++ show x ++ ", got " ++ show err-        Right v -> return v---defaultNames = words "Simon Lennart Dave Brian Warren Joseph Kevin Ralf Paul John Thomas Mark Erik Alastair Colin Philip"--pick :: [a] -> IO a-pick xs = randomRIO (0, (length xs - 1)) >>= return . (xs !!)

@@ -1,68 +0,0 @@-{-# LANGUAGE RecordWildCards, ViewPatterns #-}--module Development.Bake.Build(ovenIncremental, incrementalDone) where--import Development.Bake.Type-import Development.Shake.Command-import Control.Monad.Extra-import Data.List.Extra-import Control.Arrow-import Data.Function-import System.Directory-import System.IO.Extra-import System.FilePath-import Data.Maybe----- | This requires a version of @cp@. On Windows, you can get that here:---   <http://gnuwin32.sourceforge.net/packages/coreutils.htm>-ovenIncremental :: Oven state patch test -> Oven state patch test-ovenIncremental oven@Oven{..} = oven-    {ovenUpdateState = \s -> do r <- ovenUpdateState s; whenJust s $ addUpdateState r; return r-    ,ovenPrepare = \s ps -> do incPrepare s ps; ovenPrepare s ps-    }-    where-        showState = stringyTo   ovenStringyState-        readState = stringyFrom ovenStringyState-        showPatch = stringyTo   ovenStringyPatch-        readPatch = stringyFrom ovenStringyPatch--        showUpdate (s1,(s2,ps2)) = show (showState s1, (showState s2, map showPatch ps2))-        readUpdate (read -> (s1,(s2,ps2))) = (readState s1, (readState s2, map readPatch ps2))--        addUpdateState new old =-            appendFile "../incremental-update.txt" $ showUpdate (new,old) ++ "\n"--        readUpdateState = do-            appendFile "../incremental-update.txt" ""-            src <- readFile' "../incremental-update.txt"-            return $ map readUpdate $ lines src--        readCandidate file = do-            state:patches <- fmap lines $ readFile' file-            return (readState state, map readPatch patches)--        incPrepare s ps = do-            me <- getDirectoryContents "."-            -- check we haven't already been prepared, probably in a previous client run-            when (null $ filter (not . all (== '.')) me) $ do-                dir <- getDirectoryContents ".."-                states <- fmap (map (first showState)) readUpdateState-                let resolve (s,ps) | Just new <- lookup (showState s) states = resolve $ second (++ps) new-                                   | otherwise = (showState s, map showPatch ps)-                (selfState, selfPatches) <- return $ resolve (s,ps)--                poss <- fmap catMaybes $ forM [x | x <- dir, "bake-test-" `isPrefixOf` x, takeExtension x == ".incremental"] $ \x -> do-                    (state, patches) <- fmap resolve $ readCandidate $ "../" ++ replaceExtension x ".txt"-                    return $ if state /= selfState && any (`notElem` selfPatches) patches then Nothing else-                        Just (length $ filter (`notElem` patches) selfPatches, dropExtension x)--                when (not $ null poss) $ do-                    let best = snd $ minimumBy (compare `on` fst) poss-                    unit $ cmd "cp --preserve=timestamps --recursive --no-target-directory" ("../" ++ best) "."---incrementalDone :: IO ()-incrementalDone = do-    x <- getCurrentDirectory-    writeFile (x <.> "incremental") ""

@@ -1,58 +0,0 @@-{-# LANGUAGE RecordWildCards, ViewPatterns, ScopedTypeVariables #-}--module Development.Bake.Client(-    startClient-    ) where--import Development.Bake.Type-import Development.Bake.Util-import Development.Bake.Message-import System.Exit-import Control.Exception.Extra-import Development.Shake.Command-import Control.Concurrent-import Control.Monad.Extra-import System.Time.Extra-import System.FilePath-import Data.IORef-import Data.Maybe-import System.Environment----- given server, name, threads-startClient :: (Host,Port) -> Author -> String -> Int -> Double -> Oven state patch test -> IO ()-startClient hp author (Client -> client) maxThreads ping (validate . concrete -> oven) = do-    when (client == Client "") $ error "You must give a name to the client, typically with --name"-    queue <- newChan-    nowThreads <- newIORef maxThreads--    root <- myThreadId-    exe <- getExecutablePath-    let safeguard = handle_ (throwTo root)-    forkIO $ safeguard $ forever $ do-        readChan queue-        now <- readIORef nowThreads-        q <- sendMessage hp $ Pinged $ Ping client author maxThreads now-        whenJust q $ \q@Question{..} -> do-            atomicModifyIORef nowThreads $ \now -> (now - qThreads, ())-            writeChan queue ()-            void $ forkIO $ safeguard $ do-                dir <- createDir "bake-test" $ fromState (fst qCandidate) : map fromPatch (snd qCandidate)-                (time, (exit, Stdout sout, Stderr serr)) <- duration $-                    cmd (Cwd dir) exe "runtest"-                        "--output=tests.txt"-                        ["--test=" ++ fromTest t | Just t <- [qTest]]-                        ("--state=" ++ fromState (fst qCandidate))-                        ["--patch=" ++ fromPatch p | p <- snd qCandidate]-                        ["+RTS","-N" ++ show qThreads]-                tests <- if isJust qTest || exit /= ExitSuccess then return ([],[]) else do-                    src ::  ([String],[String]) <- fmap read $ readFile $ dir </> "tests.txt"-                    let op = map (stringyFrom (ovenStringyTest oven))-                    putStrLn "FIXME: Should validate the next set forms a DAG"-                    return (op (fst src), op (snd src))-                atomicModifyIORef nowThreads $ \now -> (now + qThreads, ())-                sendMessage hp $ Finished q $-                    Answer (sout++serr) time tests $ exit == ExitSuccess-                writeChan queue ()--    forever $ writeChan queue () >> sleep ping

@@ -0,0 +1,153 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++-- | Define a continuous integration system.+module Development.Bake.Core.Args(+    bake+    ) where++import System.Console.CmdArgs+import Development.Bake.Core.Type hiding (Client)+import Development.Bake.Core.Client+import Development.Bake.Core.GC+import Development.Bake.Server.Start+import Development.Bake.Core.Send+import Control.Exception.Extra+import General.Extra+import Control.DeepSeq+import System.FilePath+import System.IO.Extra+import System.Directory.Extra+import Control.Monad.Extra+import Control.Applicative+import Data.Either.Extra+import Data.Maybe+import Data.List.Extra+import Data.Tuple.Extra+import Paths_bake+import Prelude+++data Bake+    = Server {port :: Port, author :: [Author], timeout :: Double, admin :: String}+    | Client {host :: Host, port :: Port, author :: [Author], name :: String, threads :: Int, provide :: [String], ping :: Double}+    | AddPatch {host :: Host, port :: Port, author :: [Author], name :: String}+    | DelPatch {host :: Host, port :: Port, author :: [Author], name :: String}+    | DelPatches {host :: Host, port :: Port, author :: [Author]}+    | Requeue {host :: Host, port :: Port, author :: [Author]}+    | SetState {host :: Host, port :: Port, author :: [Author], state :: String}+    | Pause {host :: Host, port :: Port, author :: [Author]}+    | Unpause {host :: Host, port :: Port, author :: [Author]}+    | GC {bytes :: Integer, ratio :: Double, days :: Double, dirs :: [FilePath]}+    | Admin {password :: [String]}+    | View {port :: Port, file :: FilePath}+      -- actions sent through from Bake itself+    | RunInit+    | RunUpdate {state :: String, patch :: [String]}+    | RunTest {test :: Maybe String, state :: String, patch :: [String]}+    | RunExtra {state :: String, patch :: [String]}+      deriving (Typeable,Data)+++bakeMode = cmdArgsMode $ modes+    [Server{port = 0, author = [], timeout = 10*60, admin = ""}+    ,Client{host = "", threads = 1, name = "", ping = 60, provide = []}+    ,AddPatch{}+    ,DelPatch{}+    ,DelPatches{}+    ,Requeue{}+    ,SetState{state = ""}+    ,Pause{}+    ,Unpause{}+    ,GC 0 0 7 ([] &= args)+    ,Admin ([] &= args)+    ,View{file = "" &= args}+    ,RunTest def def def+    ,RunInit{}+    ,RunExtra{}+    ,RunUpdate{}+    ] &= verbosity++-- | The entry point to the system. Usually you will define:+--+-- > main = bake myOven+--+--   Where @myOven@ defines details about the server. The program+--   deals with command line arguments, run @--help@ for details.+bake :: (Stringy state, Stringy patch, Stringy test) => Oven state patch test -> IO ()+bake = bake_ -- so the forall's don't show up in Haddock++bake_ :: forall state patch test . (Stringy state, Stringy patch, Stringy test) => Oven state patch test -> IO ()+bake_ oven = do+    registerMaster+    timeInit+    getDataDir -- ensure it gets forced in case you change directory+    x <- cmdArgsRun bakeMode+    let author1 = head $ author x ++ ["unknown"]+    case x of+        Server{..} -> startServer (getPort port) author timeout admin False oven+        View{..} -> do+            when (file == "") $ error "You must pass a file"+            file <- canonicalizePath file+            withTempDir $ \dir -> withCurrentDirectory dir $ do+                createDirectoryIfMissing True $ dir </> "bake-store"+                copyFile file $ dir </> "bake-store" </> "bake.sqlite"+                -- the concrete ensures nothing ever results in a parse error+                startServer (getPort port) [] 100 "" True $ snd $ concrete oven+        Client{..} -> do+            name <- if name /= "" then return name else pick defaultNames+            startClient (getHostPort host port) author1 name threads provide ping oven+        AddPatch{..} -> sendAddPatch (getHostPort host port) author1 =<< check "patch" (undefined :: patch) name+        DelPatch{..} -> sendDelPatch (getHostPort host port) author1 =<< check "patch" (undefined :: patch) name+        DelPatches{..} -> sendDelAllPatches (getHostPort host port) author1+        Requeue{..} -> sendRequeue (getHostPort host port) author1+        SetState{..} -> sendSetState (getHostPort host port) author1 state+        Pause{..} -> sendPause (getHostPort host port) author1+        Unpause{..} -> sendUnpause (getHostPort host port) author1+        GC{..} -> garbageCollect bytes ratio (days * 24*60*60) (if null dirs then ["."] else dirs)+        Admin{..} -> do+            when (null password) $ putStrLn "Pass passwords on the command line to be suitable for 'server --admin=XXX'"+            forM_ password $ \x -> putStrLn $ "Password " ++ x ++ " requires --admin=" ++ encryptish x+        RunInit -> do+            s <- ovenInit oven+            writeFile ".bake.result" $ stringyTo s+        RunUpdate{..} -> do+            s <- ovenUpdate oven (stringyFrom state) $ map stringyFrom patch+            writeFile ".bake.result" $ stringyTo s+        RunTest{..} -> do+            case test of+                Nothing -> do+                    res <- nubOn stringyTo <$> ovenPrepare oven+                        (stringyFrom state)+                        (map stringyFrom patch)++                    -- check the patches all make sense+                    let follow t = map stringyTo $ testDepend $ ovenTestInfo oven $ stringyFrom t+                    whenJust (findCycle follow $ map stringyTo res) $ \xs ->+                        error $ unlines $ "Tests form a cycle:" : xs+                    let missing = transitiveClosure follow (map stringyTo res) \\ map stringyTo res+                    when (missing /= []) $+                        error $ unlines $ "Test is a dependency that cannot be reached:" : missing++                    writeFile ".bake.result" $ show $ map stringyTo res+                Just test -> do+                    testAction $ ovenTestInfo oven $ stringyFrom test+        RunExtra{..} -> do+            res <- ovenPatchExtra oven+                (stringyFrom state)+                (fmap stringyFrom $ listToMaybe patch)+            writeFile ".bake.result" $ show res+    where+        getPort p = if p == 0 then snd $ ovenServer oven else p+        getHostPort h p = (if h == "" then fst $ ovenServer oven else h, getPort p)+++check :: Stringy s => String -> s -> String -> IO String+check typ _ x = do+    res <- try_ $ evaluate $ force $ stringyTo $ asTypeOf (stringyFrom x) x+    case res of+        Left err -> error $ "Couldn't stringify the " ++ typ ++ " " ++ show x ++ ", got " ++ show err+        Right v -> return v+++defaultNames = words "Simon Lennart Dave Brian Warren Joseph Kevin Ralf Paul John Thomas Mark Erik Alastair Colin Philip"

@@ -0,0 +1,59 @@+{-# LANGUAGE RecordWildCards, ViewPatterns, ScopedTypeVariables #-}++module Development.Bake.Core.Client(+    startClient+    ) where++import Development.Bake.Core.Type+import Development.Bake.Core.Run+import General.Extra+import Development.Bake.Core.Message+import Control.Concurrent+import Control.Monad.Extra+import System.Time.Extra+import Data.IORef+import Data.Tuple.Extra+import System.Environment.Extra+import qualified Data.Text.Lazy as TL+++-- given server, name, threads+startClient :: (Stringy state, Stringy patch, Stringy test)+            => (Host,Port) -> Author -> String -> Int -> [String] -> Double -> Oven state patch test -> IO ()+startClient hp author (toClient -> client) maxThreads provide ping (concrete -> (prettys, oven)) = do+    when (client == toClient "") $ error "You must give a name to the client, typically with --name"+    queue <- newChan+    nowThreads <- newIORef maxThreads++    unique <- newIORef 0+    root <- myThreadId+    exe <- getExecutablePath+    forkSlave $ forever $ do+        readChan queue+        now <- readIORef nowThreads+        q <- sendMessage hp $ Pinged $ Ping client author provide maxThreads now+        whenJust q $ \q@Question{..} -> do+            atomicModifyIORef nowThreads $ \now -> (now - qThreads, ())+            writeChan queue ()+            void $ forkSlave $ do+                i <- atomicModifyIORef unique $ dupe . succ+                putBlock "Client start" $+                    ["Client: " ++ fromClient client+                    ,"Id: " ++ show i+                    ,"Test: " ++ maybe "Prepare" fromTest qTest+                    ,"State: " ++ fromState (fst qCandidate)+                    ,"Patches:"] +++                    map ((++) "    " . fromPatch) (snd qCandidate)+                a@Answer{..} <- runTest (fst qCandidate) (snd qCandidate) qTest+                putBlock "Client stop" $+                    ["Client: " ++ fromClient client+                    ,"Id: " ++ show i+                    ,"Result: " ++ (if aSuccess then "Success" else "Failure")+                    ,"Duration: " ++ maybe "none" showDuration aDuration+                    ,"Output: " ++ TL.unpack aStdout+                    ]+                atomicModifyIORef nowThreads $ \now -> (now + qThreads, ())+                sendMessage hp $ Finished q a+                writeChan queue ()++    forever $ writeChan queue () >> sleep ping

@@ -0,0 +1,66 @@++-- | Define a continuous integration system.+module Development.Bake.Core.GC(garbageCollect) where++import Control.Exception.Extra+import General.Extra+import System.Directory.Extra+import System.FilePath+import Control.Monad.Extra+import Control.Applicative+import Data.Either.Extra+import Data.List.Extra+import System.Time.Extra+import Data.Maybe+import System.DiskSpace+import Prelude+++-- | Garbage collect enough files to satisfy the requirements.+garbageCollect+    :: Integer -- ^ Minimum number of bytes you want free on the drive (use 0 if you don't want any)+    -> Double -- ^ Ratio of the drive you want free, e.g. 0.25 to demand a quarter of the drive free (1 to delete everything you can)+    -> Seconds -- ^ Minimum age to delete in seconds+    -> [FilePath] -- ^ Directories containing Bake stuff+    -> IO ()+garbageCollect _ _ _ [] = return ()+garbageCollect bytes ratio limit dirs@(d:_) = do+    total <- diskTotal <$> getDiskUsage d+    gs <- reverse . sortOn gAge . filter ((>= limit) . gAge) <$> garbageQuery dirs++    bytes <- return $ max (floor $ fromIntegral total * ratio) bytes++    done <- flip loopM (False,gs) $ \(done,gs) -> case gs of+        [] -> return $ Right done+        g:gs -> do+            b <- getAvailSpace d+            if b >= bytes then+                return $ Right done+            else do+                putStr $ "[BAKE-GC] Deleting " ++ gPath g ++ "..."+                res <- try_ $ do+                    renameDirectory (gPath g) (gPath g <.> "gc")+                    removeDirectoryRecursive (gPath g <.> "gc")+                putStrLn $ either (\e -> "FAILED\n" ++ show e) (const "success") res+                return $ Left (True,gs)+    when done $+        putStrLn "[BAKE-GC] Disk space garbage collection complete"+++data Garbage = Garbage+    {gPath :: FilePath+    ,gAge :: Seconds -- ^ Age in seconds, will be positive (unless clock adjustments)+    }+++-- | Given a list of directories, find the possible garbage present.+garbageQuery :: [FilePath] -> IO [Garbage]+garbageQuery dirs = do+    now <- getCurrentTime+    let f gen file = fmap eitherToMaybe $ try_ $ do+            t <- getModificationTime file+            return $ gen $ now `subtractTime` t++    fmap (concatMap catMaybes) $ forM dirs $ \dir -> do+        dirs <- listContents dir+        forM dirs $ \dir -> f (Garbage dir) $ dir </> ".bake.name"

@@ -0,0 +1,174 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}++module Development.Bake.Core.Message(+    Message(..), Ping(..), Question(..), Answer(..),+    sendMessage, messageToInput, messageFromInput, questionToOutput+    ) where++import Development.Bake.Core.Type+import General.Web+import Control.Applicative+import Control.Monad+import Control.DeepSeq+import Data.Aeson hiding (Success)+import System.Time.Extra+import Safe+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString.Lazy.Char8 as LBS+import Prelude+++data Message+    -- Send by the user+    = AddPatch Author Patch+    | DelPatch Author Patch+    | DelAllPatches Author+    | Requeue Author+    | SetState Author State+    | Pause Author+    | Unpause Author+    | AddSkip Author Test+    | DelSkip Author Test+    | ClearSkip Author+    -- Sent by the client+    | Pinged Ping+    | Finished {question :: Question, answer :: Answer}+    deriving (Show,Eq)++instance NFData Message where+    rnf (AddPatch x y) = rnf x `seq` rnf y+    rnf (DelPatch x y) = rnf x `seq` rnf y+    rnf (DelAllPatches x) = rnf x+    rnf (Requeue x) = rnf x+    rnf (SetState x y) = rnf x `seq` rnf y+    rnf (Pause x) = rnf x+    rnf (Unpause x) = rnf x+    rnf (AddSkip x y) = rnf x `seq` rnf y+    rnf (DelSkip x y) = rnf x `seq` rnf y+    rnf (ClearSkip x) = rnf x+    rnf (Pinged x) = rnf x+    rnf (Finished x y) = rnf x `seq` rnf y++data Question = Question+    {qCandidate :: (State, [Patch])+    ,qTest :: Maybe Test+    ,qThreads :: Int+    ,qClient :: Client+    }+    deriving (Show,Eq,Ord)++instance NFData Question where+    rnf (Question a b c d) = rnf (a,b,c,d)++data Answer = Answer+    {aStdout :: TL.Text+    ,aDuration :: Maybe Seconds -- Nothing for a skip+    ,aTests :: [Test]+    ,aSuccess :: Bool+    }+    deriving (Show,Eq)++instance NFData Answer where+    rnf (Answer a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d++data Ping = Ping+    {pClient :: Client+    ,pAuthor :: Author+    ,pProvide :: [String] -- matches with testRequire+    ,pMaxThreads :: Int+    ,pNowThreads :: Int+    }+    deriving (Show,Eq)++instance NFData Ping where+    rnf (Ping a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e++-- JSON instance is only true for Finished+instance ToJSON Message where+    toJSON (Finished q a) = object ["question" .= q, "answer" .= a]+    toJSON _ = error "ToJSON Message is only supported for Finished"++instance FromJSON Message where+    parseJSON (Object v) = Finished <$>+        (v .: "question") <*> (v .: "answer")+    parseJSON _ = mzero++instance ToJSON Question where+    toJSON Question{..} = object+        ["candidate" .= toJSONCandidate qCandidate+        ,"test" .= qTest+        ,"threads" .= qThreads+        ,"client" .= qClient]++instance FromJSON Question where+    parseJSON (Object v) = Question <$>+        (fromJSONCandidate =<< (v .: "candidate")) <*> (v .: "test") <*> (v .: "threads") <*> (v .: "client")+    parseJSON _ = mzero++toJSONCandidate (s, ps) = object ["state" .= s, "patches" .= ps]++fromJSONCandidate (Object v) = (,) <$> (v .: "state") <*> (v .: "patches")+fromJSONCandidate _ = mzero++instance ToJSON Answer where+    toJSON Answer{..} = object+        ["stdout" .= aStdout+        ,"duration" .= aDuration+        ,"tests" .= aTests+        ,"success" .= aSuccess]++instance FromJSON Answer where+    parseJSON (Object v) = Answer <$>+        (v .: "stdout") <*> (v .: "duration") <*> (v .: "tests") <*> (v .: "success")+    parseJSON _ = mzero+++messageToInput :: Message -> Input+messageToInput (AddPatch author patch) = Input ["api","add"] [("author",author),("patch",fromPatch patch)] ""+messageToInput (DelPatch author patch) = Input ["api","del"] [("author",author),("patch",fromPatch patch)] ""+messageToInput (DelAllPatches author) = Input ["api","delall"] [("author",author)] ""+messageToInput (Requeue author) = Input ["api","requeue"] [("author",author)] ""+messageToInput (SetState author state) = Input ["api","set"] [("author",author),("state",fromState state)] ""+messageToInput (Pause author) = Input ["api","pause"] [("author",author)] ""+messageToInput (Unpause author) = Input ["api","unpause"] [("author",author)] ""+messageToInput (AddSkip author test) = Input ["api","addskip"] [("author",author),("test",fromTest test)] ""+messageToInput (DelSkip author test) = Input ["api","delskip"] [("author",author),("test",fromTest test)] ""+messageToInput (ClearSkip author) = Input ["api","clearskip"] [("author",author)] ""+messageToInput (Pinged Ping{..}) = Input ["api","ping"] +    ([("client",fromClient pClient),("author",pAuthor)] +++     [("provide",x) | x <- pProvide] +++     [("maxthreads",show pMaxThreads),("nowthreads",show pNowThreads)]) ""+messageToInput x@Finished{} = Input ["api","finish"] [] $ encode x+++-- return either an error message (not a valid message), or a message+messageFromInput :: Input -> Either String Message+messageFromInput (Input [msg] args body)+    | msg == "add" = AddPatch <$> str "author" <*> (toPatch <$> str "patch")+    | msg == "del" = DelPatch <$> str "author" <*> (toPatch <$> str "patch")+    | msg == "delall" = DelAllPatches <$> str "author"+    | msg == "addskip" = AddSkip <$> str "author" <*> (toTest <$> str "test")+    | msg == "delskip" = DelSkip <$> str "author" <*> (toTest <$> str "test")+    | msg == "clearskip" = ClearSkip <$> str "author"+    | msg == "requeue" = Requeue <$> str "author"+    | msg == "set" = SetState <$> str "author" <*> (toState <$> str "state")+    | msg == "pause" = Pause <$> str "author"+    | msg == "unpause" = Unpause <$> str "author"+    | msg == "ping" = Pinged <$> (Ping <$> (toClient <$> str "client") <*>+        str "author" <*> strs "provide" <*> int "maxthreads" <*> int "nowthreads")+    | msg == "finish" = eitherDecode body+    where strs x = Right $ map snd $ filter ((==) x . fst) args+          str x | Just v <- lookup x args = Right v+                | otherwise = Left $ "Missing field " ++ show x ++ " from " ++ show msg+          int x = readNote "messageFromInput, expecting Int" <$> str x+messageFromInput (Input msg args body) = Left $ "Invalid API call, got " ++ show msg+++questionToOutput :: Maybe Question -> Output+questionToOutput = OutputString . LBS.unpack . encode+++sendMessage :: (Host,Port) -> Message -> IO (Maybe Question)+sendMessage hp msg = do+    res <- send hp $ messageToInput msg+    return $ decode res

@@ -0,0 +1,61 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}++module Development.Bake.Core.Run(+    runInit, runUpdate, runTest, runExtra+    ) where++import Development.Bake.Core.Type hiding (Client)+import Development.Bake.Core.Message+import Development.Shake.Command+import Control.Exception.Extra+import General.Extra+import System.Time.Extra+import Control.DeepSeq+import Data.Tuple.Extra+import System.IO.Extra+import System.Environment.Extra+import System.FilePath+import Data.Maybe+import System.Exit+import Safe+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+++state x = "--state=" ++ fromState x+patch x = "--patch=" ++ fromPatch x+test  x = "--test="  ++ fromTest  x++runInit :: IO (Maybe State, Answer)+runInit = runAll "init" [] [] toState++runUpdate :: State -> [Patch] -> IO (Maybe State, Answer)+runUpdate s ps = runAll "update" (state s : map patch ps) [] toState++runTest :: State -> [Patch] -> Maybe Test -> IO Answer+runTest s ps t = do+    (ex, ans) <- runAll "test" (state s : map patch ps) (map test $ maybeToList t) (map toTest . readNote "runTest")+    return $ maybe ans (\ex -> ans{aTests=ex}) (if t == Nothing then ex else Nothing)++runExtra :: State -> Maybe Patch -> IO (Maybe (T.Text, TL.Text), Answer)+runExtra s ps = runAll "extra" (state s : map patch (maybeToList ps)) [] ((T.pack *** TL.pack) . readNote "runExtra")+++runAll :: NFData a => String -> [String] -> [String] -> (String -> a) -> IO (Maybe a, Answer)+runAll name args1 args2 parse = do+    exe <- getExecutablePath+    dir <- createDir ("bake-" ++ name) args1++    (time, res) <- duration $ try_ $ do+        exe <- getExecutablePath+        (exit, Stdout sout, Stderr serr) <- cmd (Cwd dir) exe ("run" ++ name) args1 args2+        ex <- if exit /= ExitSuccess then return Nothing else do+            ans <- fmap parse $ readFile' $ dir </> ".bake.result"+            evaluate $ rnf ans+            return $ Just ans+        return (ex, Answer (TL.pack $ sout++serr) (Just 0) [] (exit == ExitSuccess))+    case res of+        Left e -> do+            e <- showException e+            return (Nothing, Answer (TL.pack e) (Just time) [] False)+        Right (ex,ans) -> return (ex, ans{aDuration=Just time})

@@ -0,0 +1,39 @@+{-# LANGUAGE RecordWildCards #-}++module Development.Bake.Core.Send(+    sendPause, sendUnpause,+    sendAddPatch, sendDelPatch, sendDelAllPatches, sendRequeue,+    sendAddSkip, sendDelSkip,+    sendSetState+    ) where++import Control.Monad+import Development.Bake.Core.Type+import Development.Bake.Core.Message++sendPause :: (Host,Port) -> Author -> IO ()+sendPause hp author = void $ sendMessage hp $ Pause author++sendUnpause :: (Host,Port) -> Author -> IO ()+sendUnpause hp author = void $ sendMessage hp $ Unpause author++sendAddPatch :: (Host,Port) -> Author -> String -> IO ()+sendAddPatch hp author x = void $ sendMessage hp $ AddPatch author $ toPatch x++sendDelPatch :: (Host,Port) -> Author -> String -> IO ()+sendDelPatch hp author x = void $ sendMessage hp $ DelPatch author $ toPatch x++sendDelAllPatches :: (Host,Port) -> Author -> IO ()+sendDelAllPatches hp author = void $ sendMessage hp $ DelAllPatches author++sendRequeue :: (Host,Port) -> Author -> IO ()+sendRequeue hp author = void $ sendMessage hp $ Requeue author++sendAddSkip :: (Host,Port) -> Author -> String -> IO ()+sendAddSkip hp author x = void $ sendMessage hp $ AddSkip author $ toTest x++sendDelSkip :: (Host,Port) -> Author -> String -> IO ()+sendDelSkip hp author x = void $ sendMessage hp $ DelSkip author $ toTest x++sendSetState :: (Host,Port) -> Author -> String -> IO ()+sendSetState hp author x = void $ sendMessage hp $ SetState author $ toState x

@@ -0,0 +1,220 @@+{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++-- | Define a continuous integration system.+module Development.Bake.Core.Type(+    Host, Port,+    Stringy(..),+    Oven(..), TestInfo(..), defaultOven, ovenTest,+    ovenNotifyAdd, ovenNotifyStdout,+    threads, threadsAll, depend, run, require, priority,+    State, toState, fromState,+    Patch, toPatch, fromPatch,+    Test, toTest, fromTest,+    Client, toClient, fromClient,+    Point,+    concrete, Prettys(..),+    Author+    ) where++import General.Extra+import Control.Monad.Extra+import Control.DeepSeq+import Data.Monoid+import Data.Aeson+import Data.Hashable+import Data.Typeable+import Database.SQLite.Simple.FromField+import Database.SQLite.Simple.ToField+import General.Database+import Data.List.Extra+import Prelude+++type Author = String++type Host = String++type Port = Int++-- | The central type defining a continuous integration system.+--   Usually constructed with 'defaultOven' then filled out with other+--   'Oven' modifiers such as 'ovenGit' and 'ovenTest'.+--+--   The types are: @state@ is the base state of the system (think HEAD on the master branch);+--   @patch@ is a change that is proposed (think a diff); @test@ is the type of tests that+--   are run.+--+--   All IO operations will be called in a direct subdirectory of the directory you start+--   'bake' from. In particular:+--   'ovenInit' will always be called single-threaded from @bake-init@;+--   'ovenUpdate' will always be called single-threaded from @bake-update-/hash/@;+--   'ovenPatchExtra' will always be called from @bake-extra-/hash/@;+--   'ovenPrepare' and 'run' will always be called from @bake-test-/hash/@.+data Oven state patch test = Oven+    {ovenInit :: IO state+        -- ^ Get an initial state+    ,ovenUpdate :: state -> [patch] -> IO state+        -- ^ Given a state, and a set of candiates that have passed,+        --   merge to create a new state+    ,ovenPrepare :: state -> [patch] -> IO [test]+        -- ^ Prepare a candidate to be run, produces the tests that must pass+    ,ovenTestInfo :: test -> TestInfo test+        -- ^ Produce information about a test+    ,ovenNotify :: [Author] -> String -> IO ()+        -- ^ Tell an author some information contained in the string (usually an email)+    ,ovenPatchExtra :: state -> Maybe patch -> IO (String, String)+        -- ^ Extra information about a patch, a single line (HTML span),+        --   and a longer chunk (HTML block)+    ,ovenServer :: (Host, Port)+        -- ^ Default server to use+    ,ovenSupersede :: patch -> patch -> Bool+        -- ^ Given two patches (first on submitted first) is the first now redundant+    }++-- | Given a 'Stringy' for @test@, and a function that when run on a code base+--   returns the list of tests that need running, and a function to populate+--   a 'TestInfo', modify the 'Oven' with a test type.+ovenTest :: IO [test] -> (test -> TestInfo test)+         -> Oven state patch () -> Oven state patch test+ovenTest prepare info o = o{ovenPrepare= \_ _ -> prepare, ovenTestInfo=info}++-- | Add an additional notification to the list.+ovenNotifyAdd :: ([Author] -> String -> IO ()) -> Oven state patch test -> Oven state patch test+ovenNotifyAdd f o = o{ovenNotify = \a s -> f a s >> ovenNotify o a s}++-- | Produce notifications on 'stdout' when users should be notified about success/failure.+ovenNotifyStdout :: Oven state patch test -> Oven state patch test+ovenNotifyStdout = ovenNotifyAdd $ \a s -> putBlock "Email" ["To: " ++ commas a, s]++-- | A type representing a translation between a value and a string, which can be+--   produced by 'readShowStringy' if the type has both 'Read' and 'Show' instances.+--   The functions 'stringyTo' and 'stringyFrom' should be inverses of each other.+--   The function 'stringyPretty' shows a value in a way suitable for humans, and can+--   discard uninteresting information.+class Stringy s where+    stringyTo :: s -> String+    stringyFrom :: String -> s+    stringyPretty :: s -> String+    stringyPretty = stringyTo++instance Stringy () where+    stringyTo () = "_"+    stringyFrom "_" = ()+    stringyFrom x = error $ "Invalid stringyFrom on (), expected \"_\", got " ++ show x++instance Stringy String where+    stringyTo = id+    stringyFrom = id+    stringyPretty x+        | (pre,sha) <- spanEnd (`elem` "0123456789abcdef") x+        , length sha >= 32 -- git is 40+        = pre ++ take 7 sha+    stringyPretty x = x+++-- | The default oven, which doesn't do anything interesting. Usually the starting point.+defaultOven :: Oven () () ()+defaultOven = Oven+    {ovenInit = return ()+    ,ovenUpdate = \_ _ -> return ()+    ,ovenNotify = \_ _ -> return ()+    ,ovenPrepare = \_ _ -> return []+    ,ovenTestInfo = \_ -> mempty+    ,ovenPatchExtra = \_ _ -> return ("","")+    ,ovenServer = ("127.0.0.1",80)+    ,ovenSupersede = \_ _ -> False+    }++-- | Information about a test.+data TestInfo test = TestInfo+    {testThreads :: Maybe Int -- number of threads, defaults to 1, Nothing for use all+    ,testAction :: IO ()+    ,testRequire :: [String] -- attributes that are required+    ,testDepend :: [test]+    ,testPriority :: Int+    }++instance Functor TestInfo where+    fmap f t = t{testDepend = map f $ testDepend t}++instance Monoid (TestInfo test) where+    mempty = TestInfo (Just 1) (return ()) [] [] 0+    mappend (TestInfo x1 x2 x3 x4 x5) (TestInfo y1 y2 y3 y4 y5) =+        TestInfo (liftM2 (+) x1 y1) (x2 >> y2) (x3 ++ y3) (x4 ++ y4) (x5 + y5)++-- | Change the number of threads a test requires, defaults to 1.+threads :: Int -> TestInfo test -> TestInfo test+threads j t = t{testThreads=Just j}++-- | Record that a test requires all available threads on a machine,+--   typically used for the build step.+--   Use 'getNumCapabilities' to find out how many threads you were allocated.+threadsAll :: TestInfo test -> TestInfo test+threadsAll t = t{testThreads=Nothing}+++-- | Require the following tests have been evaluated on this machine+--   before this test is run. Typically used to require compilation+--   before running most tests.+depend :: [test] -> TestInfo test -> TestInfo test+depend xs t = t{testDepend=testDepend t++xs}++-- | The action associated with a @test@.+run :: IO () -> TestInfo test+run act = mempty{testAction=act}++-- | Set the priority of a test, those with higher priority are run first.+--   Tests have a default priority of 0.+priority :: Int -> TestInfo test -> TestInfo test+priority p t = t{testPriority = p + testPriority t}++-- | Is a particular client capable of running a test.+--   Usually an OS check. To run a test must have all its requirements met.+--   Clients can satisfy a requirement by passing @--provide=...@ on the command line.+require :: [String] -> TestInfo test -> TestInfo test+require xs t = t{testRequire = xs ++ testRequire t}+++newtype State = State {fromState :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField,Stringy)+newtype Patch = Patch {fromPatch :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField,Stringy)+newtype Test = Test {fromTest :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField,Stringy)+newtype Client = Client {fromClient :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField)++toState :: String -> State; toState = State+toPatch :: String -> Patch; toPatch = Patch+toTest :: String -> Test; toTest = Test+toClient :: String -> Client; toClient = Client++type Point = (State, [Patch])++data Prettys = Prettys+    {prettyState :: State -> String+    ,prettyPatch :: Patch -> String+    ,prettyTest  :: Test  -> String+    }++concrete :: (Stringy state, Stringy patch, Stringy test) => Oven state patch test -> (Prettys, Oven State Patch Test)+concrete o@Oven{..} = (Prettys prestate prepatch pretest, o+    {ovenInit = fmap restate ovenInit+    ,ovenUpdate = \s ps -> fmap restate $ ovenUpdate (unstate s) (map unpatch ps)+    ,ovenPrepare = \s ps -> fmap (map retest) $ ovenPrepare (unstate s) (map unpatch ps)+    ,ovenTestInfo = fmap retest . ovenTestInfo . untest+    ,ovenPatchExtra = \s p -> ovenPatchExtra (unstate s) (fmap unpatch p)+    ,ovenSupersede = \p1 p2 -> ovenSupersede (unpatch p1) (unpatch p2) +    })+    where+        (unstate,restate,prestate) = f State fromState+        (unpatch,_      ,prepatch) = f Patch fromPatch+        (untest ,retest ,pretest ) = f Test  fromTest++        f :: forall o s . Stringy o => (String -> s) -> (s -> String) -> (s -> o, o -> s, s -> String)+        f inj proj =+            (check . stringyFrom . proj+            ,inj . stringyTo . check+            ,stringyPretty . flip asTypeOf (undefined :: o) . check . stringyFrom . proj)++        check :: forall o . Stringy o => o -> o+        check s | null $ stringyTo s = error "Problem with stringyTo/stringyFrom, generated blank string"+                | stringyTo s == stringyTo (stringyFrom (stringyTo s) :: o) = s+                | otherwise = error $ "Problem with stringyTo/stringyFrom on " ++ stringyTo s

@@ -1,13 +1,17 @@  module Development.Bake.Email(ovenNotifyEmail) where -import Development.Bake.Type+import Development.Bake.Core.Type+import Network.Mail.SMTP+import Data.String+import Data.List.Extra   -- | Email notifications when users should be notified about success/failure.---   Requires the host/port of an SMTP server. Not yet implemented, will always crash.-ovenNotifyEmail :: (Host,Port) -> Oven state patch test -> Oven state patch test-ovenNotifyEmail hp o = o{ovenNotify = \a s -> sendEmail hp a s >> ovenNotify o a s}+ovenNotifyEmail :: (Host,Port) -> (Author -> [String]) -> Oven state patch test -> Oven state patch test+ovenNotifyEmail hp resolve = ovenNotifyAdd $ \a s -> sendEmail hp (nubOrd $ concatMap resolve a) s -sendEmail :: (Host,Port) -> [Author] -> String -> IO ()-sendEmail = error "Bake.sendEmail not yet implemented"+sendEmail :: (Host,Port) -> [String] -> String -> IO ()+sendEmail (h,p) to msg = sendMail' h (fromIntegral p) email+    where email = simpleMail (addr "bake@example.com") (map addr to) [] [] (fromString "Bake notification") [plainTextPart $ fromString msg]+          addr x = Address Nothing (fromString x)

@@ -1,39 +0,0 @@--module Development.Bake.Format(-    tag, tag_,-    table,-    commas, commasLimit, unwordsLimit-    ) where--import Data.List.Extra---table :: String -> [String] -> [[String]] -> [String]-table zero cols [] = ["<p>" ++ zero ++ "</p>"]-table _ cols body =-    ["<table>"-    ,tag_ "thead" $ tag_ "tr" $ concatMap (tag_ "td") cols-    ,"<tbody>"] ++-    [tag_ "tr" $ concatMap (tag_ "td") x | x <- body] ++-    ["</tbody>"-    ,"</table>"]---tag_ :: String -> String -> String-tag_ t = tag t []--tag :: String -> [String] -> String -> String-tag t at x = "<" ++ t ++ concatMap f at ++ ">" ++ x ++ "</" ++ t ++ ">"-    where f x = let (a,b) = break (== '=') x in ' ':a ++ (if null b then "" else "=\"" ++ drop1 b ++ "\"")---commas :: [String] -> String-commas = intercalate ", "--commasLimit :: Int -> [String] -> String-commasLimit i xs = intercalate ", " a ++ (if null b then "" else "...")-    where (a,b) = splitAt i xs--unwordsLimit :: Int -> [String] -> String-unwordsLimit i xs = unwords a ++ (if null b then "" else "...")-    where (a,b) = splitAt i xs

@@ -1,18 +1,24 @@ {-# LANGUAGE ViewPatterns #-}  module Development.Bake.Git(-    SHA1, ovenGit,+    SHA1(..), sha1, ovenGit,+    gitPatchExtra, gitInit     ) where -import Development.Bake.Type-import Development.Bake.Util+import Development.Bake.Core.Type+import General.Extra import Development.Shake.Command import Control.Monad.Extra import Data.List.Extra-import Development.Bake.Format+import General.HTML import System.Directory.Extra import System.FilePath import Data.Maybe+import Data.Tuple.Extra+import Data.Char+import Data.Hashable+import Data.Monoid+import Prelude   newtype SHA1 = SHA1 {fromSHA1 :: String} deriving (Show,Eq)@@ -22,12 +28,10 @@        | not $ all (`elem` "0123456789abcdef") x = error $ "SHA1 for Git must be all lower case hex, got " ++ show x         | otherwise = SHA1 x -stringySHA1 :: Stringy SHA1-stringySHA1 = Stringy-    {stringyTo = fromSHA1-    ,stringyFrom = sha1-    ,stringyPretty = take 7 . fromSHA1-    }+instance Stringy SHA1 where+    stringyTo = fromSHA1+    stringyPretty = take 7 . fromSHA1+    stringyFrom = sha1   -- | Modify an 'Oven' to work with the Git version control system.@@ -36,72 +40,139 @@ --   which is used to clone into. ovenGit :: String -> String -> Maybe FilePath -> Oven () () test -> Oven SHA1 SHA1 test ovenGit repo branch (fromMaybe "." -> path) o = o-    {ovenUpdateState = gitUpdateState+    {ovenInit = gitInit repo branch+    ,ovenUpdate = gitUpdate     ,ovenPrepare = \s ps -> do gitCheckout s ps; ovenPrepare o () $ map (const ()) ps-    ,ovenPatchExtra = gitPatchExtra-    ,ovenStringyState = stringySHA1-    ,ovenStringyPatch = stringySHA1+    ,ovenPatchExtra = \s p -> gitPatchExtra s p =<< gitInitMirror+    ,ovenSupersede = \_ _ -> False     }     where-        traced msg act = do-            putStrLn $ "% GIT: Begin " ++ msg-            res <- act-            putStrLn $ "% GIT: Finish " ++ msg-            return res-         gitSafe dir = do-            unit $ cmd (Cwd dir) "git config user.email" ["https://github.com/ndmitchell/bake"]-            unit $ cmd (Cwd dir) "git config user.name" ["Bake Continuous Integration"]+            time_ $ cmd (Cwd dir) "git config user.email" ["https://github.com/ndmitchell/bake"]+            time_ $ cmd (Cwd dir) "git config user.name" ["Bake Continuous Integration"]          -- initialise the mirror, or make it up to date         gitInitMirror = traced "gitInitMirror" $ do-            mirror <- createDir "../bake-git" [repo]+            -- make sure we descend one directory, since bake writes .bake.name+            mirror <- fmap (</> "mirror") $ createDir "../bake-git" [repo]+            createDirectoryIfMissing True mirror             -- see http://blog.plataformatec.com.br/2013/05/how-to-properly-mirror-a-git-repository/             ready <- doesFileExist $ mirror </> "HEAD"             if ready then-                unit $ cmd (Cwd mirror) "git fetch --prune"+                time_ $ cmd (Cwd mirror) "git fetch --prune"              else do-                unit $ cmd (Cwd mirror) "git clone --mirror" [repo] "."+                time_ $ cmd (Cwd mirror) "git clone --mirror" [repo] "."                 gitSafe mirror             return mirror -        gitUpdateState Nothing = traced "gitUpdateState Nothing" $ do-            mirror <- gitInitMirror-            Stdout hash <- cmd (Cwd mirror) "git rev-parse" [branch]-            case words hash of-                [] -> error "Couldn't find branch"-                x:xs -> return $ sha1 $ trim x--        gitUpdateState (Just (s, ps)) = traced "gitUpdateState Just" $ do+        gitUpdate s ps = traced "gitUpdate" $ do             gitCheckout s ps-            Stdout x <- cmd (Cwd path) "git rev-parse" [branch]-            unit $ cmd (Cwd path) "git push" [repo] [branch ++ ":" ++ branch]+            Stdout x <- time $ cmd (Cwd path) "git rev-parse" [branch]+            time_ $ cmd (Cwd path) "git push" [repo] [branch ++ ":" ++ branch]             return $ sha1 $ trim x          gitCheckout s ps = traced "gitCheckout" $ do             createDirectoryIfMissing True path             mirror <- gitInitMirror-            b <- doesDirectoryExist $ path </>".git"-            if b then-                unit $ cmd (Cwd path) "git pull origin"-             else do-                unit $ cmd (Cwd path) "git clone" [(if path == "." then "" else "../") ++ mirror] "." ["--branch",branch]+            unlessM (doesDirectoryExist $ path </>".git") $ do+                time_ $ cmd (Cwd path) "git init"                 gitSafe path-            unit $ cmd (Cwd path) "git checkout" [branch]-            unit $ cmd (Cwd path) "git reset --hard" ["origin/" ++ branch]-            Stdout x <- cmd (Cwd path) "git rev-parse HEAD"-            when (trim x /= fromSHA1 s) $ error "Branch changed while running"+                time_ $ cmd (Cwd path) "git remote add origin" [(if path == "." then "" else "../") ++ mirror]+            time_ $ cmd (Cwd path) "git fetch"+            time_ $ cmd (Cwd path) "git checkout" [branch]+            time_ $ cmd (Cwd path) "git reset --hard" ["origin/" ++ branch]+            Stdout x <- time $ cmd (Cwd path) "git rev-parse HEAD"+            when (trim x /= fromSHA1 s) $ error $+                "The branch " ++ branch ++ " changed SHA1 independently of bake.\n" +++                "Expected value: " ++ fromSHA1 s ++ "\n" +++                "But has become: " ++ trim x             forM_ ps $ \p ->-                unit $ cmd (Cwd path) "git merge" (fromSHA1 p)+                time_ $ cmd (Cwd path) "git merge" (fromSHA1 p) -        gitPatchExtra s Nothing = traced "gitPatchExtra Nothing" $ do-            mirror <- gitInitMirror-            Stdout full <- cmd (Cwd mirror) "git log -n3" [fromSHA1 s]-            return (concat $ take 1 $ lines full, tag_ "pre" full) -        gitPatchExtra s (Just p) = traced "gitPatchExtra Just" $ do-            mirror <- gitInitMirror-            Stdout full <- cmd (Cwd mirror) "git diff" (fromSHA1 s ++ ".." ++ fromSHA1 p)-            Stdout numstat <- cmd (Cwd mirror) "git diff --numstat" (fromSHA1 s ++ ".." ++ fromSHA1 p)-            let xs = [x | [_,_,x] <- map words $ lines numstat]-            return (unwordsLimit 3 xs, tag_ "pre" full)+gitInit :: String -> String -> IO SHA1+gitInit repo branch = traced "gitInit" $ do+    Stdout hash <- time $ cmd "git ls-remote" [repo] [branch]+    case words $ concat $ takeEnd 1 $ lines hash of+        [] -> error "Couldn't find branch"+        x:xs -> return $ sha1 $ trim x+++traced :: String -> IO a -> IO a+traced msg act = do+    putStrLn $ "% GIT: Begin " ++ msg+    res <- act+    putStrLn $ "% GIT: Finish " ++ msg+    return res+++---------------------------------------------------------------------+-- DIFF UTILITIES++gitPatchExtra :: SHA1 -> Maybe SHA1 -> FilePath -> IO (String, String)+gitPatchExtra s Nothing dir = do+    Stdout full <- time $ cmd (Cwd dir) "git log --no-merges -n10 --pretty=format:%s" [fromSHA1 s]+    Stdout count <- time $ cmd (Cwd dir) "git rev-list --count" [fromSHA1 s]+    let summary = takeWhile (/= '\n') full+    return (renderHTML $ do str_ $ count ++ " patches"; br_; str_ summary+           ,renderHTML $ pre_ $ str_ full)++gitPatchExtra (SHA1 s) (Just (SHA1 p)) dir = do+    Stdout diff <- time $ cmd (Cwd dir)+        "git diff" [s ++ "..." ++ p]+    Stdout stat <- time $ cmd (Cwd dir)+        "git diff --stat" [s ++ "..." ++ p]+    Stdout log <- time $ cmd (Cwd dir)+        "git log --no-merges -n1 --pretty=format:%s" [p]+    return (renderHTML $ do str_ $ reduceStat stat; br_; str_ $ take 120 $ takeWhile (/= '\n') log+           ,renderHTML $ pre_ $ do prettyStat stat; str_ "\n"; prettyDiff diff)+++reduceStat :: String -> String+reduceStat = commasLimit 3 . map trim . map (takeWhile (/= '|')) . dropEnd 1 . lines+++diff :: FilePath -> String+diff x = "diff:" ++ show (abs $ hash x)++-- |+-- > src/Paths.hs                          |   11 +++-- > src/Test.hs                           |  258 ++++++++++++------------+-- > travis.hs                             |    4 +-+-- > 28 files changed, 1612 insertions(+), 1302 deletions(-)+prettyStat :: String -> HTML+prettyStat = unlines_ . maybe [] (uncurry snoc . (map f *** str_)) . unsnoc . map trimStart . lines+    where+        f x = a__ [href_ $ "#" ++ diff a] (str_ a) <> str_ b <> g c+            where (ab,c) = break (== '|') x+                  (a,b) = spanEnd isSpace ab+        g x@('+':_) = span__ [class_ "green"] (str_ a) <> g b+            where (a,b) = span (== '+') x+        g x@('-':_) = span__ [class_ "red"] (str_ a) <> g b+            where (a,b) = span (== '-') x+        g (x:xs) = str_ [x] <> g xs+        g [] = mempty+++-- |+-- > diff --git a/bake.cabal b/bake.cabal+-- > index 1aa1251..785cecc 100755+-- > --- a/bake.cabal+-- > +++ b/bake.cabal+-- > @@ -1,7 +1,7 @@+-- >  cabal-version:      >= 1.10+-- >  build-type:         Simple+-- >  name:               bake+-- > -version:            0.1+-- > +version:            0.2+prettyDiff :: String -> HTML+prettyDiff = unlines_ . map f . lines+    where+        f x | "diff --git " `isPrefixOf` x =+            let files = [y | ab:'/':y <- drop 2 $ words x, ab `elem` "ab"] in+            a__ (take 1 [name_ $ diff y | y <- files]) mempty <>+            b_ (str_ x)+        f x | any (`isPrefixOf` x) ["index ","--- ","+++ "] = b_ $ str_ x+        f xs@('+':_) = span__ [class_ "green"] $ str_ xs+        f xs@('-':_) = span__ [class_ "red"] $ str_ xs+        f xs = str_ xs

@@ -1,129 +0,0 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings #-}--module Development.Bake.Message(-    Message(..), Ping(..), Question(..), Answer(..),-    sendMessage, messageFromInput, questionToOutput-    ) where--import Development.Bake.Type-import Development.Bake.Web-import Control.Applicative-import Control.Monad-import Data.Aeson hiding (Success)-import qualified Data.ByteString.Lazy.Char8 as LBS---data Message-    -- Send by the user-    = AddPatch Author Patch-    | DelPatch Author Patch-    | DelAllPatches Author-    | Pause Author-    | Unpause Author-    -- Sent by the client-    | Pinged Ping-    | Finished {question :: Question, answer :: Answer}-    deriving (Show,Eq)--data Question = Question-    {qCandidate :: (State, [Patch])-    ,qTest :: Maybe Test-    ,qThreads :: Int-    ,qClient :: Client-    }-    deriving (Show,Eq)--data Answer = Answer-    {aStdout :: String-    ,aDuration :: Double-    ,aTests :: ([Test],[Test])-        -- only filled in if qTest is Nothing-        -- (those tests which are suitable, those which are unsuitable)-    ,aSuccess :: Bool-    }-    deriving (Show,Eq)--data Ping = Ping-    {pClient :: Client-    ,pAuthor :: Author-    ,pMaxThreads :: Int-    ,pNowThreads :: Int-    }-    deriving (Show,Eq)----- JSON instance is only true for Finished-instance ToJSON Message where-    toJSON (Finished q a) = object ["question" .= q, "answer" .= a]--instance FromJSON Message where-    parseJSON (Object v) = Finished <$>-        (v .: "question") <*> (v .: "answer")-    parseJSON _ = mzero--instance ToJSON Question where-    toJSON Question{..} = object-        ["candidate" .= toJSONCandidate qCandidate-        ,"test" .= qTest-        ,"threads" .= qThreads-        ,"client" .= qClient]--instance FromJSON Question where-    parseJSON (Object v) = Question <$>-        (fromJSONCandidate =<< (v .: "candidate")) <*> (v .: "test") <*> (v .: "threads") <*> (v .: "client")-    parseJSON _ = mzero--toJSONCandidate (s, ps) = object ["state" .= s, "patches" .= ps]--fromJSONCandidate (Object v) = (,) <$> (v .: "state") <*> (v .: "patches")-fromJSONCandidate _ = mzero--instance ToJSON Answer where-    toJSON Answer{..} = object-        ["stdout" .= aStdout-        ,"duration" .= aDuration-        ,"tests" .= aTests-        ,"success" .= aSuccess]--instance FromJSON Answer where-    parseJSON (Object v) = Answer <$>-        (v .: "stdout") <*> (v .: "duration") <*> (v .: "tests") <*> (v .: "success")-    parseJSON _ = mzero---messageToInput :: Message -> Input-messageToInput (AddPatch author (Patch patch)) = Input ["api","add"] [("author",author),("patch",patch)] ""-messageToInput (DelPatch author (Patch patch)) = Input ["api","del"] [("author",author),("patch",patch)] ""-messageToInput (DelAllPatches author) = Input ["api","delall"] [("author",author)] ""-messageToInput (Pause author) = Input ["api","pause"] [("author",author)] ""-messageToInput (Unpause author) = Input ["api","unpause"] [("author",author)] ""-messageToInput (Pinged Ping{..}) = Input ["api","ping"]-    [("client",fromClient pClient),("author",pAuthor)-    ,("maxthreads",show pMaxThreads),("nowthreads",show pNowThreads)] ""-messageToInput x@Finished{} = Input ["api","finish"] [] $ LBS.unpack $ encode x----- return either an error message (not a valid message), or a message-messageFromInput :: Input -> Either String Message-messageFromInput (Input [msg] args body)-    | msg == "add" = AddPatch <$> str "author" <*> (Patch <$> str "patch")-    | msg == "del" = DelPatch <$> str "author" <*> (Patch <$> str "patch")-    | msg == "delall" = DelAllPatches <$> str "author"-    | msg == "pause" = Pause <$> str "author"-    | msg == "ping" = Pinged <$> (Ping <$> (Client <$> str "client") <*>-        str "author" <*> int "maxthreads" <*> int "nowthreads")-    | msg == "finish" = eitherDecode $ LBS.pack body-    where str x | Just v <- lookup x args = Right v-                | otherwise = Left $ "Missing field " ++ show x ++ " from " ++ show msg-          int x = read <$> str x-messageFromInput (Input msg args body) = Left $ "Invalid API call, got " ++ show msg---questionToOutput :: Maybe Question -> Output-questionToOutput = OutputString . LBS.unpack . encode---sendMessage :: (Host,Port) -> Message -> IO (Maybe Question)-sendMessage hp msg = do-    res <- send hp $ messageToInput msg-    return $ decode $ LBS.pack res

@@ -1,29 +1,33 @@ {-# LANGUAGE RecordWildCards, ViewPatterns #-} -module Development.Bake.Pretty(ovenPretty, Pretty(..)) where+module Development.Bake.Pretty(ovenPretty, ovenPrettyMerge, Pretty(..)) where -import Development.Bake.Type+import Development.Bake.Core.Type import Data.List.Extra-import Control.Arrow   data Pretty a = Pretty String a deriving (Read,Show,Eq) -prettyStringy :: Show a => String -> Stringy a -> Stringy (Pretty a)-prettyStringy sep Stringy{..} = Stringy-    {stringyTo = \(Pretty a b) -> a ++ sep ++ stringyTo b-    ,stringyFrom = \s -> let (a,b) = breakOn sep s in-        if null b then Pretty "" $ stringyFrom a else Pretty a $ stringyFrom $ drop (length sep) b-    ,stringyPretty = \(Pretty a b) -> a ++ sep ++ stringyPretty b-    }+instance Stringy a => Stringy (Pretty a) where+    stringyTo (Pretty a b) = a ++ "=" ++ stringyTo b+    stringyFrom s = case breakOn "=" s of+        (a,_:b) -> Pretty a $ stringyFrom b+        _ -> Pretty "" $ stringyFrom s+    stringyPretty (Pretty a b) = a ++ "=" ++ stringyPretty b -ovenPretty :: Show patch => String -> Oven state patch test -> Oven state (Pretty patch) test-ovenPretty sep oven@Oven{..} = oven-    {ovenUpdateState = ovenUpdateState . fmap (second $ map unpretty)++ovenPretty :: Oven state patch test -> Oven state (Pretty patch) test+ovenPretty oven@Oven{..} = oven+    {ovenUpdate = \s ps -> ovenUpdate s (map unpretty ps)     ,ovenPrepare = \s ps -> ovenPrepare s (map unpretty ps)     ,ovenPatchExtra = \s p -> ovenPatchExtra s (fmap unpretty p)-    ,ovenStringyPatch = prettyStringy sep ovenStringyPatch+    ,ovenSupersede = \p1 p2 -> ovenSupersede (unpretty p1) (unpretty p2)     }     where         unpretty :: Pretty a -> a         unpretty (Pretty _ x) = x++ovenPrettyMerge :: Oven state (Pretty patch) test -> Oven state (Pretty patch) test+ovenPrettyMerge oven = oven+    {ovenSupersede = \(Pretty p1 _) (Pretty p2 _) -> p1 == p2+    }

@@ -1,25 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Development.Bake.Send(-    sendPause, sendUnpause,-    sendAddPatch, sendDelPatch, sendDelAllPatches-    ) where--import Control.Monad-import Development.Bake.Type-import Development.Bake.Message--sendPause :: (Host,Port) -> Author -> IO ()-sendPause hp author = void $ sendMessage hp $ Pause author--sendUnpause :: (Host,Port) -> Author -> IO ()-sendUnpause hp author = void $ sendMessage hp $ Unpause author--sendAddPatch :: (Host,Port) -> Author -> String -> IO ()-sendAddPatch hp author x = void $ sendMessage hp $ AddPatch author $ Patch x--sendDelPatch :: (Host,Port) -> Author -> String -> IO ()-sendDelPatch hp author x = void $ sendMessage hp $ DelPatch author $ Patch x--sendDelAllPatches :: (Host,Port) -> Author -> IO ()-sendDelAllPatches hp author = void $ sendMessage hp $ DelAllPatches author

@@ -0,0 +1,297 @@+{-# LANGUAGE RecordWildCards, TupleSections #-}++-- | Define a continuous integration system.+module Development.Bake.Server.Brain(+    Memory(..), expire,+    Question(..), Answer(..), Ping(..),+    ClientInfo(..),+    prod+    ) where++import Development.Bake.Core.Run+import Development.Bake.Core.Type+import Development.Bake.Core.Message+import General.Extra+import Data.Tuple.Extra+import Data.Maybe+import Data.Monoid+import Control.Monad+import Data.List.Extra+import qualified Data.Map as Map+import qualified Data.Set as Set+import Development.Bake.Server.Store+import qualified Data.Text.Lazy as TL+import Control.Exception.Extra+import Prelude++import Development.Bake.Server.Memory+import Development.Bake.Server.Property+++-- any question that has been asked of a client who hasn't pinged since the time is thrown away+expire :: UTCTime -> Memory -> Memory+expire cutoff s+    | null died = s+    | otherwise = s{running = filter (flip notElem died . qClient . snd) $ running s+                   ,clients = Map.map (\ci@ClientInfo{..} -> ci{ciAlive = ciAlive && pClient ciPing `notElem` died}) $ clients s}+    where died = [pClient ciPing | ClientInfo{..} <- Map.elems $ clients s, ciPingTime < cutoff, ciAlive]+++prod :: Oven State Patch Test -> Memory -> Message -> IO (Memory, Maybe (Either String Question))+prod oven mem msg = safely $ do+    res <- update oven mem msg+    case res of+        Left err -> return (mem, Just $ Left err)+        Right mem -> do+            mem <- reacts oven mem+            case msg of+                Pinged p | null $ fatal mem, Just q <- output (ovenTestInfo oven) mem p ->+                    case () of+                        -- we still test things on the skip list when testing on a state (to get some feedback)+                        _ | Just t <- qTest q, snd (qCandidate q) /= [], Just reason <- Map.lookup t (storeSkip $ store mem) ->+                            prod oven mem $ Finished q $ Answer (TL.pack $ "Skipped due to being on the skip list\n" ++ reason) Nothing [] True+                        _ -> do+                            now <- getCurrentTime+                            return (mem{running = (now,q) : running mem}, Just $ Right q)+                _ -> return (mem, Nothing)+    where+        safely x = do+            res <- try_ x+            case res of+                Left e -> return (mem{fatal = show e : fatal mem}, Nothing)+                Right v -> return v+++reacts :: Oven State Patch Test -> Memory -> IO Memory+reacts oven = f 10+    where+        f 0 mem = return mem{fatal = "React got into a loop" : fatal mem}+        f i mem | null $ fatal mem, Just mem <- react oven mem = f (i-1) =<< mem+                | otherwise = return mem+++react :: Oven State Patch Test -> Memory -> Maybe (IO Memory)+react oven mem@Memory{..}+    | xs <- rejectable mem+    , xs@(_:_) <- filter (\(p,t) -> t `Map.notMember` maybe Map.empty snd (paReject $ storePatch store p)) xs+    = Just $ do+        let fresh = filter (isNothing . paReject . storePatch store . fst) xs+        bad <- if fresh == [] then return [] else do+            -- only notify on the first rejectable test for each patch+            let authors = map (paAuthor . storePatch store . fst) fresh+            notify authors $ "Your patch has been rejected\n" ++ unlines+                [fromPatch p ++ " due to " ++ maybe "Preparing" fromTest t | (p,t) <- fresh]+        store <- storeUpdate store+            [IUReject p t (fst active, takeWhile (/= p) (snd active) ++ [p]) | (p,t) <- xs]+        return mem{store = store, fatal = bad ++ fatal}++    | plausible mem+    , xs@(_:_) <- filter (isNothing . paPlausible . storePatch store) $ snd active+    = Just $ do+        let authors = map (paAuthor . storePatch store) xs+        bad <- notify authors $ "Your patch is now plausible\n" ++ unlines (map fromPatch xs)+        store <- storeUpdate store $ map IUPlausible xs+        return mem{store = store, fatal = bad ++ fatal}++    | mergeable mem+    , not $ null $ snd active+    = Just $ do+        (s, answer) <-+            if not simulated then uncurry runUpdate active+            else do s <- ovenUpdate oven (fst active) (snd active); return (Just s, Answer mempty (Just 0) mempty True)++        let pauthors = map (paAuthor . storePatch store) $ snd active+        case s of+            Nothing -> do+                return mem{fatal = ("Failed to update\n" ++ TL.unpack (aStdout answer)) : fatal}+            Just s -> do+                bad <- notify pauthors $ "Your patch was merged\n" ++ unlines (map fromPatch $ snd active)+                store <- storeUpdate store $ IUState s answer (Just active) : map IUMerge (snd active)+                return mem{active = (s, []), store = store, fatal = bad ++ fatal}++    | restrictActive oven mem+    , (reject@(_:_), keep) <- partition (isJust . paReject . storePatch store) $ snd active+    = Just $ do+        return mem{active = (fst active, keep)}++    | not paused+    , extendActive mem+    , add@(_:_) <- Set.toList $ storeAlive store `Set.difference` Set.fromList (snd active)+    = Just $ do+        store <- storeUpdate store $ map IUStart add+        return mem+            {active = (fst active, snd active ++ sortOn (paQueued . storePatch store) add)+            ,store = store}++    | otherwise = Nothing+    where+        notify people msg = do+            res <- try_ $ ovenNotify oven people msg+            return ["Notification failure: " ++ show e | Left e <- [res]]++++update :: Oven State Patch Test -> Memory -> Message -> IO (Either String Memory)+update oven mem _ | fatal mem /= [] = return $ Right mem++update oven mem@Memory{..} (AddPatch author p) =+    if storeIsPatch store p then+        return $ Left "patch has already been submitted"+     else do+        let queued = storeAlive store `Set.difference` Set.fromList (snd active)+            supersede = filter (\old -> ovenSupersede oven old p) $ Set.toList queued+        store <- storeUpdate store $ IUQueue p author : map IUSupersede supersede+        return $ Right mem{store = store}++update oven mem@Memory{..} (DelPatch _ p) =+    if not $ p `Set.member` storeAlive store then+        return $ Left "patch is already dead or not known"+    else do+        store <- storeUpdate store [IUDelete p]+        return $ Right mem{store = store, active = second (delete p) active}++update oven mem@Memory{..} (DelAllPatches author) = do+    store <- storeUpdate store $ map IUDelete $ Set.toList $ storeAlive store+    return $ Right mem{store = store, active = (fst active, [])}++update oven mem@Memory{..} (SetState author s) = +    if fst active == s then+        return $ Left "state is already at that value"+    else do+        store <- storeUpdate store [IUState s (Answer (TL.pack $ "From SetState by " ++ author) Nothing [] True) Nothing]+        return $ Right mem{store = store, active = (s, snd active)}++update oven mem@Memory{..} (Requeue author) = do+    let add = Set.toList $ storeAlive store `Set.difference` Set.fromList (snd active)+    store <- storeUpdate store $ map IUStart add+    return $ Right mem+        {active = (fst active, snd active ++ sortOn (paAuthor . storePatch store) add)+        ,store = store}++update oven mem@Memory{..} (Pause _)+    | paused = return $ Left "already paused"+    | otherwise = return $ Right mem{paused = True}++update oven mem@Memory{..} (Unpause _)+    | not paused = return $ Left "already unpaused"+    | otherwise = return $ Right mem{paused = False}++update oven mem@Memory{..} (Pinged ping) = do+    now <- getCurrentTime+    return $ Right mem{clients = Map.alter (Just . ClientInfo now ping True . maybe Map.empty ciTests) (pClient ping) clients}++update oven mem@Memory{..} (AddSkip author test)+    | test `Map.member` storeSkip store = return $ Left "already skipped"+    | otherwise = do+        store <- storeUpdate store [SUAdd test author]+        return $ Right mem{store = store}++update oven mem@Memory{..} (DelSkip author test)+    | test `Map.notMember` storeSkip store = return $ Left "already not skipped"+    | otherwise = do+        store <- storeUpdate store [SUDel test]+        return $ Right mem{store = store}++update oven mem@Memory{..} (ClearSkip author) = do+    store <- storeUpdate store $ map SUDel $ Map.keys $ storeSkip store+    return $ Right mem{store = store}++update oven mem@Memory{..} (Finished q@Question{..} a@Answer{..}) = do+    case () of+        _ | snd qCandidate == [] -- on a state+          , not aSuccess+          , let skip = Set.mapMonotonic Just $ Map.keysSet $ storeSkip store+          , qTest `Set.notMember` skip -- not on the skip list+          , let failed = poFail $ storePoint store qCandidate+          , failed `Set.isSubsetOf` skip -- no notifications already+          -> void $ try_ $ ovenNotify oven admins $+                "A state has failed\n" ++ fromState (fst qCandidate) ++ " due to " ++ maybe "Preparing" fromTest qTest+        _ -> return ()++    now <- getCurrentTime+    let (eq,neq) = partition ((==) q . snd) running+    let time = head $ map fst eq ++ [now]+    store <- storeUpdate store [PURun time q a]+    let add ci = ci{ciTests = Map.insertWith (&&) (qCandidate, qTest) aSuccess $ ciTests ci}+    return $ Right mem+        {store = store+        ,clients = Map.adjust add qClient clients+        ,running = neq}+++-- | Given a state, figure out what you should do next.+output :: (Test -> TestInfo Test) -> Memory -> Ping -> Maybe Question+output info mem Ping{..} | pNowThreads == 0 = Nothing+{-+1) try anyone who failed in active by bisecting+2) anyone not done in active or a superset+3) anyone not done in active+-}+output info mem@Memory{..} Ping{..} = -- trace (show (length bad, length good)) $+        fmap question $ enoughThreads $ listToMaybe $ filter suitable $ nubOrd $ concatMap dependencies $ bad ++ good+    where+        self = storePoint store active+        failedSelf = Set.toList $ poFail self+        failedPrefix = Map.fromListWith mappend $+            [ (t, case poTest po t of Just True -> ([i],[]); Just False -> ([],[i]); Nothing -> ([],[]))+            | (i, ps) <- zip [1..] $ tail $ inits $ snd active, let po = storePoint store (fst active, ps)+            , t <- failedSelf]++        bad = -- trace ("bisecting: " ++ show failedSelf) $+            [(i, t) | (t,(pass,fail)) <- Map.toList failedPrefix+                      -- assume 0 passed, so add to pass and delete from fail,+                      -- ensures we never try and "blame" 0 (which we can't reject)+                    , i <- bisect (0:pass) $ filter (/= 0) $ length (snd active):fail]++        setAddNothing = Set.insert Nothing . Set.mapMonotonic Just+        tests = setAddNothing $ fromMaybe Set.empty $ poTodo self+        doneSelf = poPass self `Set.union` poFail self+        passSuper = setAddNothing $ storeSupersetPass store active+        good = let (pri2,pri1) = partition (`Set.member` passSuper) $+                                 sortOn (maybe 0 $ negate . testPriority . info) $ Set.toList $+                                 tests `Set.difference` doneSelf+               in map (length $ snd active,) $ pri1 ++ pri2++        dependencies :: (Int, Maybe Test) -> [(Int, Maybe Test)]+        dependencies (i, t) = map (i,) $ flip transitiveClosure [t] $ \t -> case t of+            Nothing -> []+            Just t -> Nothing : map Just (testDepend $ info t)++        histDone = ciTests $ clients Map.! pClient+        histStarted = Map.keysSet histDone `Set.union` Set.fromList [(qCandidate, qTest) | (_,Question{..}) <- running, qClient == pClient]+        threadsForTest = fromMaybe pMaxThreads . testThreads . info++        -- if there are not enough threads, don't do anything else, just wait for threads to become available+        enoughThreads :: Maybe (Int, Maybe Test) -> Maybe (Int, Maybe Test)+        enoughThreads (Just (i, t)) | pNowThreads >= maybe 1 threadsForTest t = Just (i, t)+        enoughThreads _ = Nothing++        unprefix i = second (take i) active++        suitable :: (Int, Maybe Test) -> Bool+        suitable (i, Nothing)+            | (unprefix i,Nothing) `Set.notMember` histStarted -- I have not done it+            = True+        suitable (i,Just t)+            | (unprefix i,Just t) `Set.notMember` histStarted -- I have not done it+            , Map.lookup (unprefix i,Nothing) histDone == Just True -- I have prepared+            , Just ts <- poTodo $ storePoint store (unprefix i)+            , t `Set.member` ts -- this test is relevant to this patch+            , all (`elem` pProvide) $ testRequire $ info t -- I can do this test+            , all (\t -> Map.lookup (unprefix i, Just t) histDone == Just True) $ testDepend $ info t -- I have done all the dependencies+            = True+        suitable _ = False++        question (i, t) = Question (second (take i) active) t (maybe 1 threadsForTest t) pClient+++-- | Given the passes, and the fails, suggest what you would like to try next+bisect :: [Int] -> [Int] -> [Int]+bisect pass fail+    | Just fail <- if null fail then Nothing else Just $ minimum fail+    , pass <- filter (< fail) pass+    , Just pass <- if null pass then Nothing else Just $ maximum pass+    = if fail - pass == 4 then [pass+2, pass+1, pass+3]+      else if fail - pass <= 3 then [pass+1 .. fail-1]+      else [(pass + fail) `div` 2]+bisect _ _ = []

@@ -1,107 +0,0 @@-{-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns #-}--module Development.Bake.Server.Brains(-    brains, Neuron(..)-    ) where--import Development.Bake.Message-import Development.Bake.Type-import Development.Bake.Server.Type-import Data.Maybe-import Control.Monad-import Data.List.Extra---data Neuron-    = Sleep -- nothing useful to do-    | Task Question-    | Update -- update to the active state-    | Reject Patch (Maybe Test) -- reject this patch-    | Broken (Maybe Test) -- the active state with zero patches has ended up broken-      deriving Show---- Given a ping from a client, figure out what work we can get them to do, if anything-brains :: (Test -> TestInfo Test) -> Server -> Ping -> Neuron-brains _ Server{active=(_, [])} _ = Sleep -- no outstanding tasks--brains info Server{..} Ping{..}-    | allTestsPass active = Update-    | t:_ <- minimumRelation dependsMay $ failingTests active = erroneous t active-    | otherwise = let next = filter (suitableTest active) $ allTests active-                  in taskMay active $ listToMaybe next-    where-        taskMay c t = maybe Sleep (\t -> Task $ Question c t (threadsForTest t) pClient) t-        dependsMay Nothing = []-        dependsMay (Just t) = Nothing : map Just (testRequire $ info t)--        erroneous t (s, o@(unsnoc -> Just (ps,p))) =-            case (stateTest (s, o) t, stateTest (s, ps) t) of-                (Just True, _) -> error "logical inconsistentcy in brains, expected erroneous test"-                (Just False, Just True) -> Reject p t-                (Just False, Just False) -> erroneous t (s,ps)-                (Nothing, _) -> taskMay (s, o ) $ scheduleTest (s, o ) t-                (_, Nothing) -> taskMay (s, ps) $ scheduleTest (s, ps) t-        erroneous t (s, []) = Broken t--        -- all the tests we know about for this candidate, may be incomplete if Nothing has not passed (yet)-        allTests c = (Nothing:) $ map Just $ concat $ take 1 $-            map (uncurry (++) . aTests . snd) $ success' $ test' Nothing $ answered' $ candidate' c it--        -- are all tests passing for this candidate-        allTestsPass c = flip all (allTests c) $ \t ->-            not $ null $ success' $ test' t $ answered' $ candidate' c it--        -- what tests are failing for this candidate-        failingTests c = map (qTest . fst) $ failure' $ answered' $ candidate' c it--        -- how many threads does this test require-        threadsForTest = maybe 1 (fromMaybe pMaxThreads . testThreads . info)--        -- can this candidate start running this test-        suitableTest c t-            | threadsForTest t > pNowThreads = False -- not enough threads-        suitableTest c Nothing-            | null $ self' $ test' Nothing $ candidate' c it -- I am not already running it-            = True-        suitableTest c t@(Just tt)-            | [clientTests] <- map (fst . aTests . snd) $ self' $ success' $ test' Nothing $ answered' $ candidate' c it-            , tt `elem` clientTests -- it is one of the tests this client is suitable for-            , null $ test' t $ self' $ candidate' c it -- I am not running it or have run it-            , clientDone <- map (qTest . fst) $ success' $ answered' $ self' $ candidate' c it-            , all (`elem` clientDone) $ map Just $ testRequire $ info tt-            = True-        suitableTest _ _ = False--        -- what is the state of this candidate/test, either Just v (aSuccess) or Nothing (not tried)-        stateTest c t = fmap aSuccess $ join $ fmap snd $ listToMaybe $ test' t $ candidate' c it--        -- given that I want to run this particular test, what test should I do next-        -- must pass suitableTest-        scheduleTest c Nothing =-            if suitableTest c Nothing then Just Nothing else Nothing-        scheduleTest c t@(Just tt)-            | [clientTests] <- map (fst . aTests . snd) $ self' $ success' $ test' Nothing $ answered' $ candidate' c it-            , tt `elem` clientTests -- the target is one of the tests this client is suitable for-            = listToMaybe $ filter (suitableTest c) $ transitiveClosure dependsMay t-        scheduleTest c t@(Just tt)-            | null $ self' $ test' Nothing $ candidate' c it -- have never prepared on this client-            = Just Nothing-        scheduleTest _ _ = Nothing--        -- query language-        it = [(q,a) | (_,q,a) <- history]-        candidate' c = filter ((==) c . qCandidate . fst)-        test' t = filter ((==) t . qTest . fst) -        self' = filter ((==) pClient . qClient . fst) -        success' = filter (aSuccess . snd)-        failure' = filter (not . aSuccess . snd)-        answered' x = [(q,a) | (q,Just a) <- x]---transitiveClosure :: Eq a => (a -> [a]) -> a -> [a]-transitiveClosure f = nub . g-    where g x = x : concatMap g (f x)--minimumRelation :: Eq a => (a -> [a]) -> [a] -> [a]-minimumRelation f (x:xs) = [x | disjoint (transitiveClosure f x) xs] ++ minimumRelation f xs-minimumRelation f [] = []

@@ -0,0 +1,123 @@+{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving #-}++-- Stuff on disk on the server+module Development.Bake.Server.Database(+    PointId, RunId, StateId, PatchId, patchIds, fromPatchIds, patchIdsSuperset,+    saTable, saId, saState, saCreate, saPoint, saDuration,+    pcTable, pcId, pcPatch, pcAuthor, pcQueue, pcStart, pcDelete, pcSupersede, pcReject, pcPlausible, pcMerge,+    rjTable, rjPatch, rjTest, rjRun,+    ptTable, ptId, ptState, ptPatches,+    skTable, skTest, skComment,+    tsTable, tsPoint, tsTest,+    rnTable, rnId, rnPoint, rnTest, rnSuccess, rnClient, rnStart, rnDuration,+    create, save+    ) where++import Development.Bake.Core.Type+import Data.String+import Control.Exception+import General.Extra+import qualified Database.SQLite3 as SQ+import Database.SQLite.Simple+import Database.SQLite.Simple.FromField+import Database.SQLite.Simple.ToField+import System.Time.Extra+import Data.Hashable+import Data.List.Extra+import Control.Monad+import Data.Maybe+import Safe+import General.Database+import Prelude+++newtype PointId = PointId Int deriving (ToField, FromField, TypeField, Eq, Hashable)+newtype RunId = RunId Int deriving (Eq, ToField, FromField, TypeField)+newtype StateId = StateId Int deriving (ToField, FromField, TypeField)+newtype PatchId = PatchId Int deriving (ToField, FromField, TypeField)++instance Show PointId where show (PointId x) = "point-" ++ show x+instance Show RunId where show (RunId x) = "run-" ++ show x+instance Show StateId where show (StateId x) = "state-" ++ show x+instance Show PatchId where show (PatchId x) = "patch-" ++ show x++instance Read RunId where readsPrec i s = [x | Just s <- [stripPrefix "run-" s], x <- readsPrec i s]++newtype PatchIds = PatchIds String deriving (ToField, FromField, TypeField)++patchIds :: [PatchId] -> PatchIds+patchIds = PatchIds . concatMap (\(PatchId x) -> "[" ++ show x ++ "]")++patchIdsSuperset :: [PatchId] -> PatchIds+patchIdsSuperset = PatchIds . ('%':) . concatMap (\(PatchId x) -> "[" ++ show x ++ "]%")++fromPatchIds :: PatchIds -> [PatchId]+fromPatchIds (PatchIds "") = []+fromPatchIds (PatchIds xs) = map (PatchId . readNote "fromPatchIds") $ splitOn "][" $ init $ tail xs+++saTable = table "state" saId saState (saState,saCreate,saPoint,saDuration)+saId = rowid saTable :: Column StateId+saState = column saTable "state" :: Column State+saCreate = column saTable "time" :: Column UTCTime+saPoint = column saTable "point" :: Column (Maybe PointId) -- both are Nothing for a setstate+saDuration = column saTable "duration" :: Column (Maybe Seconds)++pcTable = table "patch" pcId pcPatch (pcPatch, pcAuthor, pcQueue, pcStart, pcDelete, pcSupersede, pcReject, pcPlausible, pcMerge)+pcId = rowid pcTable :: Column PatchId+pcPatch = column pcTable "patch" :: Column Patch+pcAuthor = column pcTable "author" :: Column String+pcQueue = column pcTable "queue" :: Column UTCTime+pcStart = column pcTable "start" :: Column (Maybe UTCTime)+pcDelete = column pcTable "delete_" :: Column (Maybe UTCTime)+pcSupersede = column pcTable "supersede" :: Column (Maybe UTCTime)+pcReject = column pcTable "reject" :: Column (Maybe UTCTime)+pcPlausible = column pcTable "plausible" :: Column (Maybe UTCTime)+pcMerge = column pcTable "merge" :: Column (Maybe UTCTime)++rjTable = table "reject" norowid () (rjPatch, rjTest, rjRun)+rjPatch = column rjTable "patch" :: Column PatchId+rjTest = column rjTable "test" :: Column (Maybe Test)+rjRun = column rjTable "run" :: Column RunId++ptTable = table "point" ptId (ptState, ptPatches) (ptState, ptPatches)+ptId = rowid ptTable :: Column PointId+ptState = column ptTable "state" :: Column StateId+ptPatches = column ptTable "patches" :: Column PatchIds++rnTable = table "run" rnId () (rnPoint, rnTest, rnSuccess, rnClient, rnStart, rnDuration)+rnId = rowid rnTable :: Column RunId+rnPoint = column rnTable "point" :: Column PointId+rnTest = column rnTable "test" :: Column (Maybe Test)+rnSuccess = column rnTable "success" :: Column Bool+rnClient = column rnTable "client" :: Column Client+rnStart = column rnTable "start" :: Column UTCTime+rnDuration = column rnTable "duration" :: Column (Maybe Seconds) -- nothing for a skip++tsTable = table "test" norowid () (tsPoint, tsTest)+tsPoint = column tsTable "point" :: Column PointId+tsTest = column tsTable "test" :: Column (Maybe Test)++skTable = table "skip" norowid skTest (skTest, skComment)+skTest = column skTable "test" :: Column Test+skComment = column skTable "comment" :: Column String++create :: Maybe FilePath -> IO Connection+create file = do+    conn <- open $ fromMaybe ":memory:" file+    execute_ conn $ fromString "PRAGMA journal_mode = WAL;"+    execute_ conn $ fromString "PRAGMA synchronous = OFF;"+    sqlEnsureTable conn saTable+    sqlEnsureTable conn pcTable+    sqlEnsureTable conn rjTable+    sqlEnsureTable conn ptTable+    sqlEnsureTable conn rnTable+    sqlEnsureTable conn tsTable+    sqlEnsureTable conn skTable+    return conn++save :: Connection -> FilePath -> IO ()+save conn file = void $ bracket (open file) close $ \dest -> bracket+    (SQ.backupInit (connectionHandle dest) (fromString "main") (connectionHandle conn) (fromString "main"))+    SQ.backupFinish $+    \b -> SQ.backupStep b (-1)

@@ -0,0 +1,61 @@+{-# LANGUAGE RankNTypes, TupleSections, GADTs, RecordWildCards #-}++module Development.Bake.Server.Memory(+    ClientInfo(..), Memory(..),+    newMemory, stateFailure+    ) where++import Development.Bake.Server.Store+import qualified Data.Map as Map+import Development.Bake.Core.Type+import Data.Time+import Development.Bake.Core.Message+import Control.DeepSeq+import qualified Data.Set as Set+import Data.Tuple.Extra+import Data.List.Extra+import Data.Maybe++stateFailure = toState ""+++---------------------------------------------------------------------+-- THE DATA TYPE++data ClientInfo = ClientInfo+    {ciPingTime :: UTCTime+    ,ciPing :: Ping+    ,ciAlive :: Bool+    ,ciTests :: Map.Map (Point, Maybe Test) Bool -- if a single failure, set to False+    } deriving (Eq,Show)++data Memory = Memory+    {simulated :: Bool+        -- ^ Are we running in a simulation (don't spawn separate process)+    ,admins :: [Author]+        -- ^ People responsible for overall administration+    ,store :: Store+        -- ^ All the information on disk+    ,fatal :: [String]+        -- ^ A list of fatal error messages that have been raised by the server+    ,clients :: Map.Map Client ClientInfo+        -- ^ Latest time of a ping sent by each client+    ,running :: [(UTCTime, Question)]+        -- ^ Questions you have sent to clients and are waiting for.+    ,paused :: Bool+        -- ^ Pretend the queued is empty+    ,active :: Point+        -- ^ The target we are working at (some may already be rejected).+        --   Note that when restarting, we throw away the rejected ones.+    } deriving Show++newMemory :: Store -> (State, Answer) -> IO Memory+newMemory store (state, answer) = do+    store <- storeUpdate store [IUState state answer Nothing]+    let ps = map fst $ sortOn (paQueued . snd) $+             filter (isJust . paStart . snd) $+             map (id &&& storePatch store) $ Set.toList $ storeAlive store+    return $ Memory False [] store [] Map.empty [] False (state, ps)++instance NFData Memory where+    rnf Memory{..} = ()

@@ -0,0 +1,87 @@+{-# LANGUAGE RecordWildCards, TupleSections #-}++module Development.Bake.Server.Property(+    rejectable, plausible, mergeable,+    extendActive, restrictActive+    ) where++import Development.Bake.Server.Memory+import Development.Bake.Server.Store+import qualified Data.Set as Set+import qualified Data.Map as Map+import Development.Bake.Core.Type+import Data.Maybe+import General.Extra+import Data.List+++-- | I can reject the tests rejected because of the given patches+rejectable :: Memory -> [(Patch, Maybe Test)]+-- only look at failing tests in the current state+-- find tests which have a passed/failed one apart+-- assume the state passes everything+-- if a test isn't avaiable at a point, it passes+rejectable Memory{..} =+    [(last ps, t)+        | ps <- tail $ inits $ snd active+        , let me = storePoint store (fst active, ps)+        , let prev = if length ps == 1 then piState else storePoint store (fst active, init ps)+        , t <- failed+        , poTest me t == Just False && poTest prev t == Just True]+    where+        piState = PointInfo (Just Set.empty) (Set.singleton Nothing) Set.empty++        -- tests that are failing in self, interesting to consider+        failed = Set.toList $ poFail $ storePoint store active+++-- | I can mark all active patches as plausible+plausible :: Memory -> Bool+plausible Memory{..}+    | all (isNothing . paReject . storePatch store) $ snd active+    , PointInfo{..} <- storePoint store active+    , Just tests <- poTodo+    , Set.null poFail+    , tests `Set.isSubsetOf` Set.union (storeSupersetPass store active) (catMaybesSet poPass)+    = True+plausible _ = False+++-- | I can merge all active patches+mergeable :: Memory -> Bool+mergeable mem@Memory{..}+    | plausible mem+    , PointInfo{..} <- storePoint store active+    , Just tests <- poTodo+    , tests == catMaybesSet poPass+    = True+mergeable _ = False+++-- | Add in all extra patches that are queued+extendActive :: Memory -> Bool+-- either there are no patches being tested, or the ones being tested are all plausible+-- relies on throwing out the rejected ones with restrictActive first+extendActive Memory{..} = all (isJust . paPlausible . storePatch store) $ snd active+++-- | Throw out the patches that have been rejected+restrictActive :: Oven State Patch Test -> Memory -> Bool+restrictActive oven Memory{..}+    -- I can reject someone for failing preparation+    | Nothing `Set.member` rejectedTests = True++    -- if all tests either (passed on active or a superset)+    --              or     (failed on active and lead to a rejection)+    --              or     (depend on a test that failed)+    | not $ Set.null rejectedTests+    , PointInfo{..} <- storePoint store active+    , Just tests <- poTodo+    , let pass = Set.union (storeSupersetPass store active) $ catMaybesSet $ poPass `Set.difference` poFail+    , flip all (Set.toList tests) $ \t ->+        t `Set.member` pass || any (flip Set.member rejectedTests . Just) (transitiveClosure (testDepend . ovenTestInfo oven) [t]) = True++    | otherwise = False++    where+        rejectedTests = Set.unions $ mapMaybe (fmap (Map.keysSet . snd) . paReject . storePatch store) $ snd active

@@ -5,135 +5,138 @@     startServer     ) where -import Development.Bake.Type-import Development.Bake.Web-import Development.Bake.Message-import Development.Bake.Util-import Development.Bake.Server.Type+import Development.Bake.Core.Type+import General.Web+import General.HTML+import Development.Bake.Core.Message+import Development.Bake.Core.Run+import General.Extra+import Development.Bake.Server.Brain import Development.Bake.Server.Web-import Development.Bake.Server.Brains-import Development.Shake.Command-import Control.Concurrent+import Development.Bake.Server.Stats+import Development.Bake.Server.Memory+import Development.Bake.Server.Store+import Control.Applicative+import System.Time.Extra import Control.DeepSeq import Control.Exception.Extra import Data.List.Extra import Data.Maybe-import Data.Time.Clock-import System.Environment.Extra-import Control.Monad.Extra import Data.Tuple.Extra-import System.Directory.Extra+import Control.Monad.Extra import System.Console.CmdArgs.Verbosity import System.FilePath+import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Paths_bake+import Prelude  -startServer :: Port -> FilePath -> Author -> String -> Double -> Oven state patch test -> IO ()-startServer port datadir author name timeout (validate . concrete -> oven) = do-    exe <- getExecutablePath-    curdirLock <- newMVar ()-    ignore $ removeDirectoryRecursive "bake-server"-    createDirectoryIfMissing True "bake-server"-    s <- withServerDir curdirLock $ ovenUpdateState oven Nothing-    putStrLn $ "Initial state of: " ++ show s-    var <- newMVar $ (defaultServer s){authors = [(Nothing,author)]}+startServer :: (Stringy state, Stringy patch, Stringy test)+            => Port -> [Author] -> Seconds -> String -> Bool -> Oven state patch test -> IO ()+startServer port authors timeout admin fake (concrete -> (prettys, oven)) = do+    extra <- newWorker+    var <- newCVar =<< if fake then initialiseFake else initialise oven authors extra++    forkSlave $ forever $ do+        sleep timeout+        now <- getCurrentTime+        let prune = expire (addSeconds (negate timeout) now)+        modifyCVar_ var $ \s -> do+            let s2 = prune s+            s2 <- if Map.keysSet (clients s) == Map.keysSet (clients s2) then return s2 else do+                res <- try_ $ ovenNotify oven (admins s2) $ unlines+                    ["Set of clients has changed"+                    ,"Was: " ++ unwords (map fromClient $ Map.keys $ clients s)+                    ,"Now: " ++ unwords (map fromClient $ Map.keys $ clients s2)]+                return s2{fatal = ["Error when notifying, " ++ show e | Left e <- [res]] ++ fatal s2}+            return s2++    putStrLn $ "Started server on port " ++ show port     server port $ \i@Input{..} -> do         whenLoud $ print i         handle_ (fmap OutputError . showException) $ do+            now <- getCurrentTime+            let prune = expire (addSeconds (negate timeout) now)             res <--                if null inputURL then-                    web oven inputArgs =<< readMVar var-                else if ["html"] `isPrefixOf` inputURL then+                if null inputURL then do+                    -- prune but don't save, will reprune on the next ping+                    fmap OutputHTML $ web prettys admin inputArgs . prune =<< readCVar var+                else if ["html"] `isPrefixOf` inputURL then do+                    datadir <- getDataDir                     return $ OutputFile $ datadir </> "html" </> last inputURL+                else if inputURL == ["dump"] then do+                    mem <- readCVar var+                    storeSave "temp.sqlite" $ store mem+                    return $ OutputFile "temp.sqlite"                 else if ["api"] `isPrefixOf` inputURL then-                    (case messageFromInput i{inputURL = drop 1 inputURL} of+                    case messageFromInput i{inputURL = drop 1 inputURL} of                         Left e -> return $ OutputError e                         Right v -> do-                            fmap questionToOutput $ modifyMVar var $ \s -> do-                                (s,q) <- operate curdirLock timeout oven v s+                            evaluate $ rnf v+                            res <- modifyCVar var $ \s -> do                                 case v of-                                    AddPatch _ p | p `notElem` map fst (extra s) -> do-                                        forkIO $ do-                                            dir <- createDir "bake-extra" [fromState $ fst $ active s, fromPatch p]-                                            res <- try_ $ do-                                                unit $ cmd (Cwd dir) exe "runextra"-                                                    "--output=extra.txt"-                                                    ["--state=" ++ fromState (fst $ active s)]-                                                    ["--patch=" ++ fromPatch p]-                                                fmap read $ readFile $ dir </> "extra.txt"-                                            res <- either (fmap dupe . showException) return res-                                            modifyMVar_ var $ \s -> return s{extra = (p,res) : extra s}-                                        return (s{extra=(p,dupe "Calculating..."):extra s}, q)-                                    _ -> return (s,q)-                    )+                                    AddPatch _ p -> extra $ do+                                        res <- patchExtra (fst $ active s) $ Just p+                                        storeExtraAdd (store s) (Right p) res+                                    _ -> return ()+                                (s2,q) <- recordIO $ (["brain"],) <$> prod oven (prune s) v+                                when (fst (active s2) /= fst (active s)) $ extra $ do+                                    res <- patchExtra (fst $ active s2) Nothing+                                    storeExtraAdd (store s2) (Left $ fst $ active s2) res+                                s2 <- if Map.keysSet (clients s) == Map.keysSet (clients s2) then return s2 else do+                                    res <- try_ $ ovenNotify oven (admins s2) $ unlines+                                        ["Set of clients has changed"+                                        ,"Was: " ++ unwords (map fromClient $ Map.keys $ clients s)+                                        ,"Now: " ++ unwords (map fromClient $ Map.keys $ clients s2)]+                                    return s2{fatal = ["Error when notifying, " ++ show e | Left e <- [res]] ++ fatal s2}+                                when (fatal s == [] && fatal s2 /= []) $+                                    void $ try_ $ ovenNotify oven (admins s2) $ "Fatal error\n" ++ head (fatal s2)+                                return (s2,q)+                            return $ case res of+                                Just (Left e) -> OutputError e+                                Just (Right q) -> questionToOutput $ Just q+                                Nothing -> questionToOutput Nothing                 else                     return OutputMissing             evaluate $ force res  -operate :: MVar () -> Double -> Oven State Patch Test -> Message -> Server -> IO (Server, Maybe Question)-operate curdirLock timeout oven message server = case message of-    AddPatch author p | (s, ps) <- active server -> do-        whenLoud $ print ("Add patch to",s,snoc ps p)-        now <- getTimestamp-        dull server{active = (s, snoc ps p), authors = (Just p, author) : authors server, submitted = (now,p) : submitted server}-    DelPatch author p | (s, ps) <- active server -> dull server{active = (s, delete p ps)}-    Pause author -> dull server{paused = Just $ fromMaybe [] $ paused server}-    Unpause author | (s, ps) <- active server ->-        dull server{paused=Nothing, active = (s, ps ++ maybe [] (map snd) (paused server))}-    Finished q a -> do-        when (not $ aSuccess a) $ do-            putStrLn $ replicate 70 '#'-            print (active server, q, a{aStdout=""})-            putStrLn $ aStdout a-            putStrLn $ replicate 70 '#'-        server <- return server{history = [(t,qq,if q == qq then Just a else aa) | (t,qq,aa) <- history server]}-        consistent server-        dull server -    Pinged ping -> do-        limit <- getCurrentTime-        now <- getTimestamp-        server <- return $ prune (addUTCTime (fromRational $ toRational $ negate timeout) limit) $ server-            {pings = (now,ping) : filter ((/= pClient ping) . pClient . snd) (pings server)}-        flip loopM server $ \server ->-            case brains (ovenTestInfo oven) server ping of-                Sleep ->-                    return $ Right (server, Nothing)-                Task q -> do-                    when (qClient q /= pClient ping) $ error "client doesn't match the ping"-                    server <- return $ server{history = (now,q,Nothing) : history server}-                    return $ Right (server, Just q)-                Update -> do-                    dir <- createDir "bake-test" $ fromState (fst $ active server) : map fromPatch (snd $ active server)-                    s <- withServerDir curdirLock $ withCurrentDirectory (".." </> dir) $-                        ovenUpdateState oven $ Just $ active server-                    ovenNotify oven [a | (p,a) <- authors server, maybe False (`elem` snd (active server)) p] $ unlines-                        ["Your patch just made it in"]-                    return $ Left server{active=(s, []), updates=(now,s,active server):updates server}-                Reject p t -> do-                    ovenNotify oven [a | (pp,a) <- authors server, Just p == pp] $ unlines-                        ["Your patch " ++ show p ++ " got rejected","Failure in test " ++ show t]-                    return $ Left server{active=second (delete p) $ active server}-                Broken t -> do-                    ovenNotify oven [a | (p,a) <- authors server, maybe True (`elem` snd (active server)) p] $ unlines-                        ["Eek, it's all gone horribly wrong","Failure with no patches in test " ++ show t]-                    return $ Left server{active=(fst $ active server, [])}-    where-        dull s = return (s,Nothing)+initialiseFake :: IO Memory+initialiseFake = do+    store <- newStore False "bake-store"+    mem <- newMemory store (toState "", Answer (TL.pack "Initial state created by view mode") Nothing [] False)+    return mem{fatal = ["View mode, database is read-only"]} +initialise :: Oven State Patch Test -> [Author] -> Worker -> IO Memory+initialise oven admins extra = do+    now <- getCurrentTime+    putStrLn "Initialising server, computing initial state..."+    (res, answer) <- runInit+    when (isNothing res) $+        void $ try_ $ ovenNotify oven admins "Failed to initialise, pretty serious"+    let state0 = fromMaybe stateFailure res+    putStrLn $ "Initial state: " ++ maybe "!FAILURE!" fromState res+    store <- newStore False "bake-store"+    when (isJust res) $ do+        extra $ storeExtraAdd store (Left state0) =<< patchExtra state0 Nothing+    mem <- newMemory store (state0, answer) --- any question that has been asked of a client who hasn't pinged since the time is thrown away-prune :: UTCTime -> Server -> Server-prune cutoff s = s{history = filter (flip elem clients . qClient . snd3) $ history s}-    where clients = [pClient | (Timestamp t _,Ping{..}) <- pings s, t >= cutoff]+    email <- if isNothing res then return $ Right () else+        try_ $ ovenNotify oven admins "Server starting up" -consistent :: Server -> IO ()-consistent Server{..} = do-    let xs = groupSort $ map (qCandidate . snd3 &&& id) $ filter (isNothing . qTest . snd3) history-    forM_ xs $ \(c,vs) -> do-        case nub $ map (sort . uncurry (++) . aTests) $ filter aSuccess $ mapMaybe thd3 vs of-            a:b:_ -> error $ "Tests don't match for candidate: " ++ show (c,a,b,vs)-            _ -> return ()+    return $ mem+        {admins = admins+        ,fatal = ["Failed to initialise, " ++ TL.unpack (aStdout answer) | isNothing res] +++                 ["Failed to notify, " ++ show e | Left e <- [email]]+        }  -withServerDir :: MVar () -> IO a -> IO a-withServerDir curdirLock act = withMVar curdirLock $ const $ withCurrentDirectory "bake-server" act+-- | Get information about a patch+patchExtra :: State -> Maybe Patch -> IO (T.Text, TL.Text)+patchExtra s p = do+    (ex,ans) <- runExtra s p+    let failSummary = T.pack $ renderHTML $ i_ $ str_ "Error when computing patch information"+    let failDetail = TL.pack $ renderHTML $ pre_ $ str_ $ TL.unpack $ aStdout ans+    return $ fromMaybe (failSummary, failDetail) ex

@@ -0,0 +1,132 @@+{-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns, ScopedTypeVariables, TypeOperators #-}++module Development.Bake.Server.Stats(+    stats,+    record, recordIO+    ) where++import Control.DeepSeq+import Control.Applicative+import Control.Monad+import Development.Bake.Core.Type+import Development.Bake.Server.Brain+import Database.SQLite.Simple+import Data.IORef+import Data.Monoid+import Data.List.Extra+import General.HTML+import General.Extra+import Development.Bake.Server.Store+import GHC.Stats+import System.IO.Unsafe+import System.Time.Extra+import Control.Exception+import Numeric.Extra+import qualified Data.Map as Map+import Prelude+++data Stat = Stat {statHistory :: [Double], statCount :: !Int, statSum :: !Double, statMax :: !Double}++instance Monoid Stat where+    mempty = Stat [] 0 0 0+    mappend (Stat x1 x2 x3 x4) (Stat y1 y2 y3 y4) = Stat (take 10 $ x1 ++ y1) (x2+y2) (x3+y3) (x4 `max` y4)+++{-# NOINLINE recorded #-}+recorded :: IORef (Map.Map String Stat)+recorded = unsafePerformIO $ newIORef Map.empty++record :: NFData b => (a -> ([String], b)) -> a -> b+record f x = unsafePerformIO $ recordIO $ return $ f x++recordIO :: NFData a => IO ([String], a) -> IO a+recordIO x = do+    (d, (msg,x)) <- duration $ do x <- x; evaluate $ rnf x; return x+    forM_ (inits msg) $ \msg ->+        atomicModifyIORef recorded $ (,()) .  Map.insertWith mappend (unwords msg) (Stat [d] 1 d d)+    return x+++stats :: Prettys -> Memory -> (Maybe Test -> HTML) -> IO HTML+stats Prettys{..} Memory{..} showTest = do+    recorded <- readIORef recorded+    getGCStatsEnabled <- getGCStatsEnabled+    stats <- if getGCStatsEnabled then Just <$> getGCStats else return Nothing+    rel <- relativeTime++    [Only (patchCount :: Int)] <- storeSQL store "SELECT count(*) FROM patch" ()+    [Only (stateCount :: Int)] <- storeSQL store "SELECT count(*) FROM state" ()+    [Only (runCount :: Int)] <- storeSQL store "SELECT count(*) FROM run" ()++    slowest :: [Only (Maybe Test) :. (Int, Seconds, Seconds, Seconds)] <- storeSQL store "SELECT test, count(*), avg(duration) as avg, sum(duration), max(duration) FROM run WHERE test NOT IN (SELECT test FROM skip) GROUP BY test ORDER BY avg DESC LIMIT 25" ()+    [slowestAll :: (Int, Seconds, Seconds, Seconds)] <- storeSQL store "SELECT count(*), avg(duration) as avg, sum(duration), max(duration) FROM run" ()+    rejections :: [(Maybe Test, Int)] <- storeSQL store "SELECT test, count(*) AS n FROM reject WHERE test IS NULL OR test NOT IN (SELECT test FROM skip) GROUP BY test ORDER BY n DESC LIMIT 10" ()++    now <- getCurrentTime+    let periods = [addSeconds (negate x*24*60*60) now | x <- [1,7,30,365]]+    let one [Only x] = x+        one _ = 0+    plausibleCount :: [Int] <- forM periods $ \p -> one <$> storeSQL store "SELECT count(*) FROM patch WHERE plausible IS NOT NULL AND queue > ?" (Only p)+    plausibleAvg :: [Double] <- forM periods $ \p -> one <$> storeSQL store "SELECT ifnull(avg(julianday(plausible)-julianday(queue)),0.0) FROM patch WHERE plausible IS NOT NULL AND queue > ?" (Only p)+    percentiles <- forM [100,95,90,80,75,50,25,10,0] $ \perc -> (perc,) <$> do+        forM (zip periods plausibleCount) $ \(p,count) -> do+            let n = min (count - 1) $ ((count * perc) `div` 100)+            one <$> storeSQL store "SELECT julianday(plausible)-julianday(queue) AS x FROM patch WHERE plausible IS NOT NULL AND queue > ? ORDER BY x ASC LIMIT ?, 1" (p,n)++    deadSkip :: [(Test,String)] <- storeSQL store "SELECT skip.test, skip.comment FROM skip WHERE skip.test NOT IN (SELECT DISTINCT run.test FROM run WHERE run.test IS NOT NULL AND run.start > ?) ORDER BY test ASC" $ Only $ addSeconds (-7*24*60*60) now+    aliveSkip :: [(Test,String,Int, Int, Seconds)] <- storeSQL store "SELECT run.test, skip.comment, sum(run.success) AS good, count(*)-sum(run.success) AS bad, avg(run.duration) FROM run, skip WHERE run.test = skip.test AND run.duration IS NOT NULL AND run.start > ? GROUP BY skip.test ORDER BY bad ASC, good DESC" $ Only $ addSeconds (-7*24*60*60) now++    return $ do+        p_ $ str_ $ "Patches = " ++ show patchCount ++ ", states = " ++ show stateCount ++ ", runs = " ++ show runCount++        header_ "sampled" "Sampled statistics"+        let ms x = show (ceiling $ x * 1000 :: Integer)+        table ["Counter","Count","Mean (ms)","Sum (ms)","Max (ms)","Last 10 (ms)"]+            [ (if null name then i_ $ str_ "All" else str_ name) :+              map str_ [show statCount, ms $ statSum / intToDouble statCount, ms statSum+                       ,ms statMax, unwords $ map ms statHistory] +            | (name,Stat{..}) <- Map.toAscList recorded]++        header_ "slowest" "Slowest tests (max 25)"+        table ["Test","Count","Mean","Sum","Max"] $+            let f name (count, avg, sum, max) = name : map str_ [show count, showDuration avg, showDuration sum, showDuration max]+            in f (i_ $ str_ "All") slowestAll : [f (showTest test) x | (Only test :. x) <- slowest]++        header_ "rejects" "Most common rejection tests (max 10)"+        table ["Test","Rejections"] [[showTest t, str_ $ show x] | (t, x) <- rejections]++        header_ "plausible" "Speed to plausible"+        table ["Plausible","Last day","Last week","Last month","Last year"] $+            let f x = str_ $ showDuration $ x*24*60*60+                perc 100 = "Maximum"+                perc 0 = "Minimum"+                perc x = show x ++ "% within" in+            (str_ "Count" : map (str_ . show) plausibleCount) :+            (str_ "Average" : map f plausibleAvg) :+            [str_ (perc p) : map f xs | (p,xs) <- percentiles]++        header_ "skip-stale" "Stale skips (not run in a week)"+        table ["Test","Comment"]+            [[showTest $ Just t, str_ c] | (t,c) <- deadSkip]++        header_ "skip-alive" "Alive skips (last week)"+        table ["Test","Comment","Successes","Failures","Avg duration"] $+            [[showTest $ Just t, str_ c, str_ $ show s, str_ $ show f, str_ $ showDuration d] | (t,c,s,f,d) <- aliveSkip]++        header_ "ghc-stats" "GHC statistics"+        case stats of+            Nothing -> p_ $ str_ "No GHC stats, rerun with +RTS -T"+            Just x@GCStats{..} -> do+                ul_ $ do+                    li_ $ str_ $ "Uptime of: " ++ showDuration wallSeconds+                    li_ $ str_ $ "Haskell memory usage: " ++ show peakMegabytesAllocated ++ "Mb"+                    li_ $ str_ $ "CPU time: " ++ showDuration cpuSeconds +++                          " (mutator: " ++ showDuration mutatorCpuSeconds ++ ", GC: " ++ showDuration gcCpuSeconds ++ ")"+                pre_ $ str_ $ replace ", " "\n" $ takeWhile (/= '}') $ drop 1 $ dropWhile (/= '{') $ show x+++table :: [String] -> [[HTML]] -> HTML+table cols body = table_ $ do+    thead_ $ tr_ $ mconcat $ map (td_ . str_) cols+    tbody_ $ mconcat $ [tr_ $ mconcat $ map td_ x | x <- body]

@@ -0,0 +1,382 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TupleSections, TypeOperators, ViewPatterns #-}++-- Stuff on disk on the server+module Development.Bake.Server.Store(+    Store, newStore, storeSave, storeSQL,+    PatchInfo(..), paAlive, storeIsPatch, storePatch, storeAlive,+    PointInfo(..), poTest, storePoint, storeSupersetPass,+    StateInfo(..), storeStateList, storeState,+    RunId, storeRunList, storeStateFile, storeRunFile,+    storeItemsDate,+    storeSkip,+    storeExtra, storeExtraAdd,+    Update(..), storeUpdate+    ) where++import Development.Bake.Server.Database+import General.Database+import Development.Bake.Core.Type+import Development.Bake.Core.Message+import qualified Data.Set as Set+import qualified Data.Map as Map+import General.Extra+import System.Time.Extra+import Data.Char+import Data.List.Extra+import System.IO.Unsafe+import Data.Monoid+import Data.Maybe+import Control.Concurrent.Extra+import Data.Tuple.Extra+import Control.Applicative+import Control.Monad.Extra+import System.Directory+import Database.SQLite.Simple hiding (NamedParam(..))+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TL+import System.FilePath+import Control.DeepSeq+import Control.Exception+import Prelude++---------------------------------------------------------------------+-- DATA TYPES++data PointInfo = PointInfo+    {poTodo :: Maybe (Set.Set Test)+    ,poPass :: Set.Set (Maybe Test)+    ,poFail :: Set.Set (Maybe Test) -- may be in both pass and fail+    } deriving Show++instance Monoid PointInfo where+    mempty = PointInfo Nothing Set.empty Set.empty+    mappend (PointInfo x1 x2 x3) (PointInfo y1 y2 y3) = PointInfo (x1 <> y1) (x2 <> y2) (x3 <> y3)++poTest :: PointInfo -> Maybe Test -> Maybe Bool+poTest PointInfo{..} t+    | t `Set.member` poFail = Just False+    | t `Set.member` poPass = Just True+    | Just t <- t, Just todo <- poTodo, not $ t `Set.member` todo = Just True -- It's not applicable, and thus passes+    | otherwise = Nothing+++data PatchInfo = PatchInfo+    {paAuthor :: Author+    ,paQueued :: UTCTime+    ,paStart :: Maybe UTCTime+    ,paDelete :: Maybe UTCTime+    ,paSupersede :: Maybe UTCTime+    ,paReject :: Maybe (UTCTime, Map.Map (Maybe Test) (State, [Patch]))+    ,paPlausible :: Maybe UTCTime+    ,paMerge :: Maybe UTCTime+    }+    deriving Show++paAlive :: PatchInfo -> Bool+paAlive PatchInfo{..} = isNothing paDelete && isNothing paSupersede && isNothing paReject && isNothing paMerge++data StateInfo = StateInfo+    {stCreated :: UTCTime+    ,stSource :: Maybe Point+    ,stDuration :: Maybe Seconds+    }+++---------------------------------------------------------------------+-- CACHED INFORMATION++data Cache = Cache+    {cachePointId :: PointId -> IO Point+    ,cachePatch :: Patch -> IO (PatchId, PatchInfo)+    ,cacheState :: State -> IO (StateId, StateInfo)+    ,cachePoint :: Point -> IO (PointId, PointInfo)+    ,cacheSkip :: IO (Map.Map Test String)+    ,cacheAlive :: IO (Set.Set Patch)+    ,cacheSupersetPass :: Point -> IO (Set.Set Test)+    }++newCache :: Connection -> IO Cache+newCache conn = do+    cachePointId <- memoIO1 $ \pt -> do+        [(s,ps)] <- sqlSelect conn (ptState, ptPatches) [ptId %== pt]+        [Only s] <- sqlSelect conn (Only saState) [saId %== s]+        ps <- forM (fromPatchIds ps) $ \p -> do+            [Only p] <- sqlSelect conn pcPatch [pcId %== p]; return p+        return (s, ps)++    cachePatch <- memoIO1 $ \p -> do+        [(row, paAuthor, paQueue, paStart, paDelete, paSupersede, paReject, paPlausible, paMerge)] <-+            sqlSelect conn (pcId,pcAuthor,pcQueue,pcStart,pcDelete,pcSupersede,pcReject,pcPlausible,pcMerge)+            [pcPatch %== p]+        reject <- if isNothing paReject then return Nothing else unsafeInterleaveIO $ do+            ts <- sqlSelect conn (rjTest, rnPoint) [distinct rjTest, rjPatch %== row, rjRun %==% rnId]+            ts <- mapM (\(a,b) -> (a,) <$> cachePointId b) ts+            return (Just (fromJust paReject, Map.fromList ts))+        return (row, PatchInfo paAuthor paQueue paStart paDelete paSupersede reject paPlausible paMerge)++    cacheState <- memoIO1 $ \s -> do+        let checkOne msg [x] = [x]+            checkOne msg xs = error $ "checkOne, expected 1 but got " ++ show (length xs) ++ ", " ++ msg+        [(row, sCreate, sPoint, sDuration)] <- checkOne ("Loading up state " ++ show s) <$> sqlSelect conn (saId, saCreate, saPoint, saDuration) [saState %== s]+        pt <- maybe (return Nothing) (fmap Just . cachePointId) sPoint+        return (row, StateInfo sCreate pt sDuration)++    cachePoint <- memoIO1 $ \(s,ps) -> do+        s <- fst <$> cacheState s+        ps <- patchIds <$> mapM (fmap fst . cachePatch) ps+        res <- sqlSelect conn ptId [ptState %== s, ptPatches %== ps]+        pt <- case res of+            [] -> sqlInsert conn ptTable (s, ps)+            [Only x] -> return x+            _ -> error $ "ensurePoint, multiple points found"+        tests <- unsafeInterleaveIO $ sqlSelect conn tsTest [tsPoint %== pt]+        pass <- unsafeInterleaveIO $ sqlSelect conn rnTest [distinct rnTest, rnPoint %== pt, rnSuccess %== True]+        fail <- unsafeInterleaveIO $ sqlSelect conn rnTest [distinct rnTest, rnPoint %== pt, rnSuccess %== False]+        return $ (,) pt $ PointInfo+            (if null tests then Nothing else Just $ Set.fromList $ mapMaybe fromOnly tests)+            (Set.fromList $ map fromOnly pass) (Set.fromList $ map fromOnly fail)++    cacheSkip <- memoIO0 $ do+        Map.fromList <$> sqlSelect conn (skTest, skComment) []++    cacheAlive <- memoIO0 $ do+        ps <- sqlSelect conn pcPatch [nullP pcDelete, nullP pcSupersede, nullP pcReject, nullP pcMerge]+        return $ Set.fromList $ map fromOnly ps++    cacheSupersetPass <- memoIO1 $ \(s, ps) -> do+        s <- fst <$> cacheState s+        ps <- mapM (fmap fst . cachePatch) ps+        let f success = do+                xs <- sqlSelect conn rnTest [rnPoint %==% ptId, ptState %== s, likeP ptPatches $ patchIdsSuperset ps, rnSuccess %== success]+                return $ Set.fromList $ mapMaybe fromOnly xs+        liftM2 Set.difference (f True) (f False)++    return Cache{..}+++---------------------------------------------------------------------+-- STORED DATA++data Store = Store+    {conn :: Connection+    ,path :: FilePath+    ,cache :: Cache+    ,extra :: Var (Map.Map (Either State Patch) (Maybe T.Text))+    }++instance Show Store where+    show Store{..} = show path++newStore :: Bool -> FilePath -> IO Store+newStore mem path = do+    createDirectoryIfMissing True path+    conn <- create $ if mem then Nothing else Just $ path </> "bake.sqlite"+    cache <- newCache conn+    extra <- newVar Map.empty+    return $ Store conn path cache extra++storeSave :: FilePath -> Store -> IO ()+storeSave file Store{..} = do+    whenM (doesFileExist file) $ removeFile file+    save conn file++storeSQL :: (ToRow q, FromRow r) => Store -> String -> q -> IO [r]+storeSQL Store{..} = sqlUnsafe conn+++---------------------------------------------------------------------+-- QUERIES++storePoint :: Store -> Point -> PointInfo+storePoint Store{..} = snd . unsafePerformIO . cachePoint cache++storeIsPatch :: Store -> Patch -> Bool+storeIsPatch Store{..} p = unsafePerformIO $ do+    ps <- sqlSelect conn pcPatch [pcPatch %== p]+    return $ ps /= []++storePatch :: Store -> Patch -> PatchInfo+storePatch Store{..} = snd . unsafePerformIO . cachePatch cache++storeState :: Store -> State -> StateInfo+storeState Store{..} = snd . unsafePerformIO . cacheState cache++data PP = PP {ppPatch :: Patch, ppReject :: Bool, ppMx :: UTCTime}+instance FromRow PP where fromRow = PP <$> field <*> field <*> field++storeItemsDate :: Store -> (UTCTime, Maybe UTCTime) -> [Either State Patch]+storeItemsDate Store{..} (start, end) = unsafePerformIO $ do+    let ends = words "start delete_ supersede reject plausible merge"+    let str = "SELECT patch, reject IS NOT NULL, max(" ++ intercalate "," ["ifnull(" ++ x ++ ",queue)" | x <- ends] ++ ") AS mx " +++              "FROM patch WHERE mx > ?" ++ (if isJust end then " AND queue < ?" else "") ++ " ORDER BY queue ASC"+    patches :: [PP] <- sqlUnsafe conn str $ start : maybeToList end++    states <- sqlSelect conn (saState, saCreate) $ [orderAsc saCreate, saState %/= toState "", saCreate %> start] ++ [saCreate %< end | Just end <- [end]]+    return $ reverse $ merge states patches+    where+        merge (s:ss) o@(span ppReject -> (reject, p:ps))+            | snd s < ppMx p = Left (fst s) : merge ss o+            | otherwise = map (Right . ppPatch) (reject ++ [p]) ++ merge (s:ss) ps+        merge ss ps = map (Left . fst) ss ++ map (Right . ppPatch) ps+++storeSkip :: Store -> Map.Map Test String+storeSkip Store{..} = unsafePerformIO $ cacheSkip cache++storeAlive :: Store -> Set.Set Patch+storeAlive Store{..} = unsafePerformIO $ cacheAlive cache++storeSupersetPass :: Store -> (State,[Patch]) -> Set.Set Test+storeSupersetPass Store{..} = unsafePerformIO . cacheSupersetPass cache+++storeRunList :: Store -> Maybe Client -> Maybe (Maybe Test) -> Maybe State -> [Patch] -> Maybe RunId -> [(RunId, UTCTime, Question, Answer)]+storeRunList Store{..} client test state patches run = unsafePerformIO $ do+    point <- maybe (return Nothing) (fmap (Just . fst) . cachePoint cache . (, patches)) state+    patches <- if isNothing state && patches /= [] then Just <$> mapM (fmap fst . cachePatch cache) patches else return Nothing+    let filt = [rnClient %== x | Just x <- [client]] +++               [rnTest %== x | Just x <- [test]] +++               [ptId %==% rnPoint %&& likeP ptPatches (patchIdsSuperset x) | Just x <- [patches]] +++               [rnPoint %== x | Just x <- [point]] +++               [rnId %== x | Just x <- [run]]+    xs <- sqlSelect conn (rnId, rnPoint, rnTest, rnSuccess, rnClient, rnStart, rnDuration) (orderDesc rnStart : limit 1001 : filt)+    forM xs $ \(rnId, rnPoint, rnTest, rnSuccess, rnClient, rnStart, rnDuration) -> do+        pt <- cachePointId cache rnPoint+        return (rnId, rnStart, Question pt rnTest 0 rnClient, Answer mempty rnDuration [] rnSuccess)++storeStateList :: Store -> [(State, StateInfo)]+storeStateList Store{..} = unsafePerformIO $ do+    xs <- sqlSelect conn (saState, saCreate, saPoint, saDuration) [orderDesc saCreate, limit 1000]+    forM xs $ \(sState, sCreate, sPoint, sDuration) -> do+        pt <- maybe (return Nothing) (fmap Just . cachePointId cache) sPoint+        return (sState, StateInfo sCreate pt sDuration)+++---------------------------------------------------------------------+-- UPDATES++data Update+    = IUState State Answer (Maybe Point) -- assumed to be success+    | IUQueue Patch Author+    | IUStart Patch+    | IUDelete Patch+    | IUReject Patch (Maybe Test) Point+    | IUPlausible Patch+    | IUSupersede Patch+    | IUMerge Patch+    | SUAdd Test String+    | SUDel Test+    | PURun UTCTime Question Answer+      deriving Show++-- don't inline so GHC can't tell the store is returned unchanged+{-# NOINLINE storeUpdate #-}+storeUpdate :: Store -> [Update] -> IO Store+storeUpdate store xs = do+    -- important so that if the updates depend on the current store they are forced first+    -- the perils of impurity!+    evaluate $ rnf $ show xs++    now <- getCurrentTime+    (\f -> foldM f store xs) $ \store x -> do+        f now store x+        cache <- newCache $ conn store+        return store{cache=cache}+    where+        f now Store{..} x = case x of+            IUState s Answer{..} p -> do+                pt <- maybe (return Nothing) (fmap (Just . fst) . cachePoint cache) p+                prev <- sqlSelect conn saId [saState %== s]+                x <- case prev of+                    [] ->+                        sqlInsert conn saTable (s,now,pt,aDuration)+                    Only x:_ -> do+                        sqlUpdate conn [saCreate := now, saPoint := pt, saDuration := aDuration] [saId %== x]+                        return x+                createDirectoryIfMissing True (path </> show x)+                TL.writeFile (path </> show x </> "update.txt") aStdout+            IUQueue p a -> do+                void $ sqlInsert conn pcTable (p,a,now,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)+            IUStart p -> do+                sqlUpdate conn [pcStart := Just now] [pcPatch %== p]+            IUPlausible p -> do+                sqlUpdate conn [pcPlausible := Just now] [pcPatch %== p]+            IUMerge p -> do+                sqlUpdate conn [pcMerge := Just now] [pcPatch %== p]+            IUDelete p -> do+                sqlUpdate conn [pcDelete := Just now] [pcPatch %== p]+            IUSupersede p -> do+                sqlUpdate conn [pcSupersede := Just now] [pcPatch %== p]+            IUReject p t pt -> do+                pt2 <- fst <$> cachePoint cache pt+                pa <- fst <$> cachePatch cache p+                Only run:_ <- sqlSelect conn rnId [rnSuccess %== False, rnPoint %== pt2, rnTest %== t]+                sqlUpdate conn [pcReject := Just now] [pcPatch %== p]+                void $ sqlInsert conn rjTable (pa, t, run)+            SUAdd t msg -> do+                void $ sqlInsert conn skTable (t, msg)+            SUDel t -> do+                sqlDelete conn skTable [skTest %== t]+            PURun t Question{..} Answer{..} -> do+                pt <- fst <$> cachePoint cache qCandidate+                when (qTest == Nothing) $ do+                    res :: [Only (Maybe Test)] <- sqlSelect conn tsTest [tsPoint %== pt]+                    if null res then do+                        sqlInsert conn tsTable (pt, Nothing)+                        forM_ aTests $ \t -> sqlInsert conn tsTable (pt, Just t)+                    else+                        when (Set.fromList (mapMaybe fromOnly res) /= Set.fromList aTests) $+                            error "Test disagreement"+                x <- sqlInsert conn rnTable (pt,qTest,aSuccess,qClient,t,aDuration)+                createDirectoryIfMissing True $ path </> show pt+                TL.writeFile (path </> show pt </> show x ++ "-" ++ maybe "Prepare" (safely . fromTest) qTest <.> "txt") aStdout++safely :: String -> String+safely = map f . take 100+    where f x | isAlphaNum x || x `elem` (".-_" :: String) = x+          f x = '_'+++storeStateFile :: Store -> State -> Maybe String+storeStateFile Store{..} st = unsafePerformIO $ do+    st <- fst <$> cacheState cache st+    let file = path </> show st </> "update.txt"+    ifM (doesFileExist file) (Just <$> readFile file) (return Nothing)+++storeRunFile :: Store -> RunId -> Maybe String+storeRunFile Store{..} run = unsafePerformIO $ do+    [(rPoint, rTest)] <- sqlSelect conn (rnPoint, rnTest) [rnId %== run]+    let file = path </> show rPoint </> show run ++ "-" ++ maybe "Prepare" (safely . fromTest) rTest <.> "txt"+    ifM (doesFileExist file) (Just <$> readFile file) (return Nothing)+++storeExtraFile :: Store -> Either State Patch -> IO FilePath+storeExtraFile Store{..} x = (path </>) <$> either (fmap (show . fst) . cacheState cache) (fmap (show . fst) . cachePatch cache) x+++storeExtra :: Store -> Either State Patch -> Maybe (String, String)+storeExtra store@Store{..} sp = unsafePerformIO $ do+    prefix <- storeExtraFile store sp+    short <- modifyVar extra $ \mp ->+        case Map.lookup sp mp of+            Just v -> return (mp, v)+            Nothing -> do+                short <- ifM (doesFileExist $ prefix </> "extra-short.html") (fmap Just $ T.readFile $ prefix </> "extra-short.html") (return Nothing)+                return (Map.insert sp short mp, short)+    case short of+        Nothing -> return Nothing+        Just short -> do+            long <- unsafeInterleaveIO $ readFile $ prefix </> "extra-long.html"+            return $ Just (T.unpack short, long)+++storeExtraAdd :: Store -> Either State Patch -> (T.Text, TL.Text) -> IO ()+storeExtraAdd store@Store{..} sp (short, long) = do+    prefix <- storeExtraFile store sp+    createDirectoryIfMissing True prefix+    T.writeFile (prefix </> "extra-short.html") short+    TL.writeFile (prefix </> "extra-long.html") long+    modifyVar_ extra $ return . Map.insert sp (Just short)

@@ -1,34 +0,0 @@---- | Define a continuous integration system.-module Development.Bake.Server.Type(-    Server(..), defaultServer,-    Question(..), Answer(..), Ping(..),-    ) where--import Development.Bake.Type-import Development.Bake.Message-import Development.Bake.Util---defaultServer :: State -> Server-defaultServer s = Server [] [] [] (s,[]) Nothing [] [] []--data Server = Server-    {history :: [(Timestamp, Question, Maybe Answer)]-        -- ^ Questions you have sent to clients, and how they responded (if they have).-        --   The aStdout has been written to disk, and the value is a filename containing the stdout.-    ,updates :: [(Timestamp, State, (State, [Patch]))]-        -- ^ Updates that have been made-    ,pings :: [(Timestamp, Ping)]-        -- ^ Latest time of a ping sent by each client-    ,active :: (State, [Patch])-        -- ^ The candidate we are currently aiming to prove-    ,paused :: Maybe [(Timestamp, Patch)]-        -- ^ 'Just' if we are paused, and the number of people queued up-    ,submitted :: [(Timestamp, Patch)]-        -- ^ List of all patches that have been submitted over time-    ,authors :: [(Maybe Patch, Author)]-        -- ^ Authors associated with each patch (Nothing is the server author)-    ,extra :: [(Patch, (String, String))]-        -- ^ Extra information that was computed for each string (cached forever)-    } deriving Show

@@ -1,170 +1,398 @@-{-# LANGUAGE RecordWildCards, ViewPatterns #-}+{-# LANGUAGE RecordWildCards, ViewPatterns, TupleSections #-}  -- | Define a continuous integration system. module Development.Bake.Server.Web(     web     ) where -import Development.Bake.Server.Type-import Development.Bake.Type-import Development.Bake.Web-import Development.Bake.Util-import Development.Bake.Format+import Development.Bake.Server.Brain+import Development.Bake.Server.Store+import Development.Bake.Server.Stats+import Development.Bake.Core.Type+import Development.Bake.Core.Message+import General.Web+import General.Extra+import General.HTML import Data.List.Extra import Data.Tuple.Extra+import Data.Either.Extra+import System.Time.Extra import Data.Version+import Data.Maybe+import Data.Time.Calendar+import Control.Monad.Extra+import Data.Monoid import Paths_bake+import qualified Data.Map as Map+import qualified Data.Set as Set+import Safe+import Prelude  -web :: Oven State Patch Test -> [(String, String)] -> Server -> IO Output-web oven@Oven{..} args server = do-    shower <- shower oven-    return $ OutputHTML $ unlines $-        prefix ++-        (if null args then-            ["<h1>Bake Continuous Integration</h1>"-            ,"<h2>Patches</h2>"] ++-            table "No patches submitted" ["Patch","Status"] (map (patch shower server) patches) ++-            ["<h2>Clients</h2>"] ++-            table "No clients available" ["Name","Running"] (map (client shower server) clients)-         else-            let ask x = map snd $ filter ((==) x . fst) args in-            ["<h1><a href='?'>Bake Continuous Integration</a></h1>"] ++-            runs shower server (\Question{..} ->-                let or0 xs = if null xs then True else or xs in-                or0 [qClient == Client c | c <- ask "client"] &&-                or0 [qTest == if t == "" then Nothing else Just (Test t) | t <- ask "test"] &&-                case ask "state" of-                    [] -> or0 [Patch p `elem` snd qCandidate | p <- ask "patch"]-                    s:_ -> qCandidate == (State s, map Patch $ ask "patch")) ++-            (case ask "patch" of-                [p] -> ["<h2>Patch information</h2>"] ++-                       [e | (pp,(_,e)) <- extra server, Patch p == pp]-                _ -> [])-        ) ++-        suffix-    where-        patches = submitted server-        clients = sort $ nub $ map (pClient . snd) $ pings server+web :: Prettys -> String -> [(String, String)] -> Memory -> IO String+web prettys admn (args admn -> a@Args{..}) mem@Memory{..} = recordIO $ fmap (first (\x -> ["web",x])) $ do+    shower@Shower{..} <- shower store prettys argsAdmin+    stats <- if argsStats then stats prettys mem showTest else return mempty+    now <- getCurrentTime+    return $ (valueHTML &&& renderHTML . void) $ template $ do+        when (fatal /= []) $ do+            h2__ [class_ "bad"] $ str_ "Fatal error"+            p_ $ str_ "The continuous integration server has been suspeneded due to fatal errors:"+            ul_ $ mconcat $ map (li_ . str_) fatal+            hr_ +        h1_ $+            (if argsEmpty a then id else a__ [href_ $ if argsAdmin then "?admin=" else "."]) $+            str_ "Bake Continuous Integration" -data Shower = Shower-    {showPatch :: Patch -> String-    ,showTest :: Maybe Test -> String-    ,showTestPatch :: Patch -> Maybe Test -> String-    ,showTestQuestion :: Question -> String-    ,showState :: State -> String-    ,showTime :: Timestamp -> String+        if argsEmpty a{argsDate=Nothing} then do+            when (isNothing argsDate) $ do+                when paused $+                    p_ $ b_ (str_ "Paused") <> str_ ", new patches are paused until the queue is clear."+                failures shower mem+                progress shower mem++            p_ $ do+                str_ $ " Viewing " ++ maybe "yesterday and today" showDate argsDate ++ ": Goto "+                let shw d = showLink ("date=" ++ showDate d) $ str_ $ showDate d+                shw $ pred $ fromMaybe (timeToDate now) argsDate+                whenJust argsDate $ \d -> str_ ", " <> if timeToDate now == succ d then showLink "" $ str_ "today" else shw $ succ d++            table "No patches submitted" ["Submitted","Job","Status"] $+                map (\p -> rowPatch shower mem argsAdmin p) $+                map (either (Left . (id &&& storeState store)) (Right . (id &&& storePatch store))) $+                storeItemsDate store $ (dateToTime *** fmap dateToTime) $+                maybe (pred $ timeToDate now, Nothing) (\x -> (x, Just $ succ x)) argsDate++            unless (Map.null $ storeSkip store) $ do+                header_ "skipped" "Skipped tests"+                ul_ $ fmap mconcat $ forM (Map.toList $ storeSkip store) $ \(test,author) -> li_ $ do+                    showTest (Just test) <> str_ (", by " ++ author ++ ".")+                    when argsAdmin $ str_ " " <> admin (DelSkip "admin" test) (str_ "Remove")+            header_ "clients" "Clients"+            table "No clients available" ["Name","Running"]+                (map (rowClient shower mem) $ Nothing : map Just (Map.toList clients))++            when argsAdmin $ do+                h2_ $ str_ "Admin"+                ul_ $ do+                    li_ $ if Set.null $ storeAlive store+                        then str_ "Cannot delete all patches, no patches available"+                        else admin (DelAllPatches "admin") $ str_ "Delete all patches"+                    li_ $ if null (Set.toList (storeAlive store) \\ snd active)+                        then str_ "Cannot requeue, no queued patches"+                        else admin (Requeue "admin") $ str_ "Reqeue"+                    li_ $ if paused+                        then admin (Unpause "admin") $ str_ "Unpause"+                        else admin (Pause "admin") $ str_ "Pause"+            return "home"++         else if argsStats then do+            stats+            return "stats"++         else if argsRaw then do+            str_ $ show mem+            return "raw"++         else if isJust argsServer then do+            let s = fromJust argsServer+            table "No server operations" ["Time","Job","Duration"] $+                map (("",) . rowUpdate shower mem) $+                maybe (storeStateList store) (\s -> [(s, storeState store s)]) s+            whenJust s $ \s -> do+                h2_ $ str_ "Output"+                case storeStateFile store s of+                    Nothing -> p_ $ i_ $ str_ "File missing"+                    Just src -> pre_ $ str_ src+            return "server"++         else do+            let (keep,ignore) = splitAt 1000 $+                    map (\(t,q) -> (Nothing,t,q,Nothing)) (filter (argsFilter a . snd) running) +++                    map (\(a,b,c,d) -> (Just a,b,c,Just d)) (storeRunList store argsClient argsTest argsState argsPatch argsRun)+            p_ $ let n = length keep in str_ $ "Found " ++ show n ++ " run" ++ ['s' | n /= 1] ++ (if null ignore then "" else ", truncated to 1000")+            table "No runs" ["Time","Job","Status"] $+                map (rowHistory shower mem) keep++            case keep of+                _ | Just s <- argsState, argsEmpty a{argsState=Nothing} ->+                    maybe' (storeExtra store $ Left s) (return "list") $ \(_, e) -> do+                        h2_ $ str_ "State information"; raw_ e+                        return "state"+                _ | [p] <- argsPatch, argsEmpty a{argsPatch=[]} ->+                    maybe' (storeExtra store $ Right p) (return "list") $ \(_, e) -> do+                        h2_ $ str_ "Patch information"; raw_ e+                        return "patch"+                [(Just run,_,Question{..},Just Answer{..})] -> do+                    when (argsAdmin && not aSuccess) $ whenJust qTest $ \t ->+                        p_ $ admin (AddSkip "admin" t) $ str_ "Skip test"+                    h2_ $ str_ "Output"+                    pre_ $ str_ $ fromMaybe "Missing" $ storeRunFile store run+                    return "output"+                _ -> return "list"+++data Args = Args+    {argsState :: Maybe State+    ,argsDate :: Maybe Day+    ,argsPatch :: [Patch]+    ,argsClient :: Maybe Client+    ,argsTest :: Maybe (Maybe Test)+    ,argsRun :: Maybe RunId+    ,argsServer :: Maybe (Maybe State)+    ,argsAdmin :: Bool+    ,argsStats :: Bool+    ,argsRaw :: Bool     }+    deriving (Show,Eq) -showThreads i = show i ++ " thread" ++ ['s' | i /= 1]-showDuration (ceiling -> i) = show i ++ "s"+argsEmpty :: Args -> Bool+argsEmpty x = x{argsAdmin=False} == args "" [] -shower :: Oven State Patch Test -> IO Shower-shower Oven{..} = do-    showTime <- showRelativeTimestamp+args :: String -> [(String, String)] -> Args+args admn xs = Args+    (listToMaybe $ map toState $ ask "state")+    (listToMaybe $ map readDate $ ask "date")+    (map toPatch $ ask "patch")+    (listToMaybe $ map toClient $ ask "client")+    (listToMaybe $ map (\x -> if null x then Nothing else Just $ toTest x) $ ask "test")+    (listToMaybe $ map (readNote "run index") $ ask "run")+    (listToMaybe $ map (\x -> if null x then Nothing else Just $ toState x) $ ask "server")+    (any (if null admn then const True else (==) admn . encryptish) $ ask "admin")+    (not $ null $ ask "stats")+    (not $ null $ ask "raw")+    where ask x = map snd $ filter ((==) x . fst) xs++argsFilter :: Args -> Question -> Bool+argsFilter Args{..} Question{..} =+    isNothing argsRun &&+    maybe True (== qClient) argsClient &&+    maybe True (== qTest) argsTest &&+    case argsState of+        Just s -> (s,argsPatch) == qCandidate+        Nothing | null argsPatch -> True+        _ -> not $ disjoint argsPatch (snd qCandidate)+++admin :: Message -> HTML -> HTML+admin (messageToInput -> Input parts args _) body = a__ [href_ url, class_ "admin"] body+    where url = intercalate "/" parts ++ "?" ++ intercalate "&" [url_ a ++ "=" ++ url_ b | (a,b) <- args]++table :: String -> [String] -> [(String, [HTML])] -> HTML+table zero cols [] = p_ $ str_ zero+table _ cols body = table_ $ do+    thead_ $ tr_ $ mconcat $ map (td_ . str_) cols+    tbody_ $ mconcat $ [tr__ [class_ cls] $ mconcat $ map td_ x | (cls,x) <- body]+++data Shower = Shower+    {showLink :: String -> HTML -> HTML+    ,showPatch :: Patch -> HTML+    ,showExtra :: Either State Patch -> HTML+    ,showTest :: Maybe Test -> HTML+    ,showTestAt :: (State, [Patch]) -> Maybe Test -> HTML+    ,showQuestion :: Question -> HTML+    ,showClient :: Client -> HTML+    ,showState :: State -> HTML+    ,showCandidate :: (State, [Patch]) -> HTML+    ,showTime :: UTCTime -> HTML+    ,showThreads :: Int -> HTML+    }++shower :: Store -> Prettys -> Bool -> IO Shower+shower store Prettys{..} argsAdmin = do+    showRel <- showRelativeTime+    let shwState s | s == toState "" = span__ [class_ "bad" ] $ str_ $ "invalid state"+        shwState s = shwLink ("state=" ++ fromState s) $ str_ $ prettyState s+    let shwPatch p = shwLink ("patch=" ++ fromPatch p) $ str_ $ prettyPatch p     return $ Shower-        {showPatch = \p -> tag "a" ["href=?patch=" ++ fromPatch p, "class=patch"] (stringyPretty ovenStringyPatch p)-        ,showState = \s -> tag "a" ["href=?state=" ++ fromState s, "class=state"] (stringyPretty ovenStringyState s)+        {showLink = shwLink+        ,showPatch = shwPatch+        ,showState = shwState+        ,showCandidate = \(s,ps) -> do+            shwState s+            when (not $ null ps) $ str_ " plus " <> commas_ (map shwPatch ps)+        ,showExtra = \e -> raw_ $ maybe "" fst $ storeExtra store e+        ,showClient = \c -> shwLink ("client=" ++ url_ (fromClient c)) $ str_ $ fromClient c         ,showTest = f Nothing Nothing []-        ,showTestPatch = \p -> f Nothing Nothing [p]-        ,showTestQuestion = \Question{..} -> f (Just qClient) (Just $ fst qCandidate) (snd qCandidate) qTest-        ,showTime = showTime+        ,showTestAt = \(s,ps) -> f Nothing (Just s) ps+        ,showQuestion = \Question{..} -> f (Just qClient) (Just $ fst qCandidate) (snd qCandidate) qTest+        ,showTime = \x -> span__ [class_ "nobr"] $ str_ $ showUTCTime "%H:%M" x ++ " (" ++ showRel x ++ ")"+        ,showThreads = \i -> str_ $ show i ++ " thread" ++ ['s' | i /= 1]         }     where+        shwLink url = a__ [href_ $ (if argsAdmin then "?admin=&" else "?") ++ url]+         f c s ps t =-            tag "a" ["href=?" ++ intercalate "&" parts] $-            maybe "Preparing" (stringyPretty ovenStringyTest) t-            where parts = ["client=" ++ fromClient c | Just c <- [c]] ++-                          ["state=" ++ fromState s | Just s <- [s]] ++-                          ["patch=" ++ fromPatch p | p <- ps] ++-                          ["test=" ++ maybe "" fromTest t]+            shwLink (intercalate "&" parts) $ str_ $+            maybe "Preparing" prettyTest t+            where parts = ["client=" ++ url_ (fromClient c) | Just c <- [c]] +++                          ["state=" ++ url_ (fromState s) | Just s <- [s]] +++                          ["patch=" ++ url_ (fromPatch p) | p <- ps] +++                          ["test=" ++ url_ (maybe "" fromTest t)] -prefix =-    ["<!HTML>"-    ,"<html>"-    ,"<head>"-    ,"<title>Bake Continuous Integration</title>"-    ,"<link rel='shortcut icon' type='image/x-icon' href='html/favicon.ico' />"-    ,"<style type='text/css'>"-    ,"body, td {font-family: sans-serif; font-size: 10pt;}"-    ,"table {border-collapse: collapse;}"-    ,"table, td {border: 1px solid #ccc;}"-    ,"td {padding: 2px; padding-right: 15px;}"-    ,"thead {font-weight: bold;}"-    ,"a {text-decoration: none; color: #4183c4;}"-    ,"a:hover {text-decoration: underline;}"-    ,".patch, .state {font-family: Consolas, monospace; white-space:nowrap;}"-    ,".info {font-size: 75%; color: #888;}"-    ,"a.info {color: #4183c4;}" -- tie breaker-    ,".good {font-weight: bold; color: #480}"-    ,".bad {font-weight: bold; color: #800}"-    ,".nobr {white-space: nowrap;}"-    ,"#footer {margin-top: 40px; font-size: 80%;}"-    ,"</style>"-    ,"</head>"-    ,"<body>"-    ] -suffix =-    ["<p id=footer><a href='https://github.com/ndmitchell/bake'>" ++-        "Copyright Neil Mitchell 2014, version " ++ showVersion version ++ "</a></p>"-    ,"</body>"-    ,"</html>"]+template :: HTML_ a -> HTML_ a+template inner = do+    raw_ "<!HTML>"+    html_ $ do+        head_ $ do+            title_ $ str_ "Bake Continuous Integration"+            link__ [rel_ "shortcut icon", type_ "image/x-icon", href_ "html/favicon.ico"]+            style__ [type_ "text/css"] $ unlines+                ["body, td {font-family: sans-serif; font-size: 10pt;}"+                ,"table {border-collapse: collapse;}"+                ,"table, td {border: 1px solid #ccc;}"+                ,"td {padding: 2px; padding-right: 15px;}"+                ,"thead {font-weight: bold;}"+                ,"a {text-decoration: none; color: #4183c4;}"+                ,"a:hover {text-decoration: underline;}"+                ,".patch, .state {font-family: Consolas, monospace; white-space:nowrap;}"+                ,".info {font-size: 75%; color: #888;}"+                ,"a.info {color: #4183c4;}" -- tie breaker+                ,"a.self, a.self:hover {color: black; text-decoration: none;}"+                ,".good {font-weight: bold; color: darkgreen;}"+                ,".bad {font-weight: bold; color: darkred;}"+                ,".active {background-color: #ffc;}"+                ,".dull {background-color: #e6e6e6;}"+                ,".pass {background-color: #dfc;}"+                ,".fail {background-color: #fcc;}"+                ,".nobr {white-space: nowrap;}"+                ,".red {background-color: #ffdddd;}"+                ,".green {background-color: #ddffdd;}"+                ,"#footer {margin-top: 40px; font-size: 80%;}"+                ,"hr {margin-bottom: 30px;}"+                ,".admin {color: darkorange; font-weight: bold;}"+                ]+        body_ $ do+            inner+            p__ [id_ "footer"] $+                a__ [href_ "https://github.com/ndmitchell/bake"] $+                    str_ $ "Copyright Neil Mitchell 2014-2015, version " ++ showVersion version+    return $ valueHTML inner -runs :: Shower -> Server -> (Question -> Bool) -> [String]-runs Shower{..} Server{..} pred = table "No runs" ["Time","Question","Answer"]-    [[tag "span" ["class=nobr"] $ showTime t, showQuestion q, showAnswer a] | (t,q,a) <- good] ++-    (case good of-        [(_,_,Just Answer{..})] -> ["<pre>"] ++ lines aStdout ++ ["</pre>"]-        _ -> [])++failures :: Shower -> Memory -> HTML+failures Shower{..} Memory{..} = when (snd active /= [] && ts /= []) $ do+    p_ $ str_ "Tracking down failures in:"+    ul_ $ mconcat $ map (li_ . showTest) ts     where-        good = filter (pred . snd3) history-        showQuestion q@Question{..} =-            "With " ++ showState (fst qCandidate) ++-            (if null $ snd qCandidate then "" else " plus ") ++-            commas (map showPatch $ snd qCandidate) ++ "<br />" ++-            "Test " ++ showTestQuestion q ++ " on " ++-            fromClient qClient ++ " with " ++ showThreads qThreads-        showAnswer Nothing = "<i>Running...</i>"-        showAnswer (Just Answer{..}) =-            if aSuccess then tag "span" ["class=good"] ("Succeeded in " ++ showDuration aDuration)-                        else tag "span" ["class=bad"]  ("Failed in "    ++ showDuration aDuration)+        ts = Set.toList $ failed `Set.difference` reject+        failed = poFail $ storePoint store active+        reject = Set.unions $ mapMaybe (fmap (Map.keysSet . snd) . paReject . storePatch store) $ snd active  -patch :: Shower -> Server -> (Timestamp, Patch) -> [String]-patch Shower{..} Server{..} (u, p) =-    [showPatch p ++ " by " ++ commasLimit 3 [a | (pp,a) <- authors, Just p == pp] ++ "<br />" ++-     tag "span" ["class=info"] (maybe "" fst (lookup p extra))-    ,if p `elem` concatMap (snd . thd3) updates then tag "span" ["class=good"] "Merged"-     else if p `elem` snd active then-        "Testing (passed " ++ show (length $ nubOn (qTest . snd) $ filter fst done) ++ " of " ++ (if todo == 0 then "?" else show (todo+1)) ++ ")<br />" ++-        tag "span" ["class=info"]-            (if any (not . fst) done then "Retrying " ++ commasLimit 3 (nub [showTestPatch p (qTest t) | (False,t) <- done])-             else if not $ null running then "Running " ++ commasLimit 3 (map showTestQuestion running)-             else "")-     else if p `elem` maybe [] (map snd) paused then "Paused"-     else tag "span" ["class=bad"] "Rejected" ++ "<br />" ++-          tag "span" ["class=info"] (commasLimit 3 [showTestQuestion q | (False,q) <- done, [p] `isSuffixOf` snd (qCandidate q)])-    ]+progress :: Shower -> Memory -> HTML+progress Shower{..} Memory{..}+    | null (snd active), Just todo <- poTodo, Set.size done == Set.size todo + 1 = return () -- Idle on a state+    | Just t <- poTodo = p_ $ b_ (str_ "Testing") <>+        str_ (", done " ++ show (Set.size done) ++ " tests out of " ++ show (Set.size t + 1) ++ superset)+    | isRunning = p_ $ b_ (str_ "Preparing") <>+        str_ (", getting ready to test" ++ superset)+    | otherwise = return ()     where-        todo = length $ nub-            [ t-            | (_,Question{..},Just Answer{..}) <- history-            , p `elem` snd qCandidate-            , t <- uncurry (++) aTests]-        done = nub-            [ (aSuccess,q)-            | (_,q@Question{..},Just Answer{..}) <- history-            , p `elem` snd qCandidate]-        running = nub-            [ q-            | (_,q@Question{..},Nothing) <- history-            , p `elem` snd qCandidate]+        PointInfo{..} = storePoint store active+        done = Set.union poPass poFail+        superset = let x = storeSupersetPass store active `Set.difference` catMaybesSet done+                       x2 = maybe x (Set.intersection x) poTodo+                   in if Set.null x2 then "" else ", and done " ++ show (Set.size x2) ++ " in a superset"+        isRunning = any ((==) active . qCandidate . snd) running -client :: Shower -> Server -> Client -> [String]-client Shower{..} Server{..} c =-    [tag "a" ["href=?client=" ++ fromClient c] $ fromClient c-    ,if null active then "<i>None</i>"-     else commas $ map showTestQuestion active]-    where active = [q | (_,q@Question{..},Nothing) <- history, qClient == c]++showAnswer :: Maybe Answer -> HTML+showAnswer Nothing = i_ $ str_ $ "Running..."+showAnswer (Just Answer{..})+    | Just d <- aDuration = if aSuccess+                            then span__ [class_ "good"] $ str_ $ "Succeeded in " ++ showDuration d+                            else span__ [class_ "bad" ] $ str_ $ "Failed in "    ++ showDuration d+    | otherwise = str_ "Skipped"+++rowHistory :: Shower -> Memory -> (Maybe RunId, UTCTime, Question, Maybe Answer) -> (String, [HTML])+rowHistory Shower{..} Memory{..} (run, t, q@Question{..}, a) = ("", [showTime t, body, showAnswer a])+    where+        body = do+            str_ "With " <> showCandidate qCandidate+            br_+            str_ "Test " <> showQuestion q <> str_ " on " <> showClient qClient+            str_ " with " <> showThreads qThreads+++rowUpdate :: Shower -> Memory -> (State,StateInfo) -> [HTML]+rowUpdate Shower{..} Memory{..} (s,StateInfo{..}) = [showTime stCreated, body, str_ $ maybe "" showDuration stDuration]+    where+        body = do+            showLink ("server=" ++ fromState s) $ str_ $ if isNothing stSource then "Initialised" else "Updated"+            whenJust stSource $ \src -> str_ " with " <> commas_ (map showPatch $ snd src)+            br_+            whenJust stSource $ \src -> str_ "From " <> showState (fst src)+            str_ (if isJust stSource then " to " else "To ") <> showState s+++rowPatch :: Shower -> Memory -> Bool -> Either (State, StateInfo) (Patch,PatchInfo) -> (String, [HTML])+rowPatch Shower{..} mem@Memory{..} argsAdmin info = (code, [showTime time, state, body <> special])+    where+        failed = case info of+            Right (p, PatchInfo{..}) -> fmap (second Map.toList) paReject+            Left (s, StateInfo{..}) -> if Set.null x then Nothing else Just (stCreated, map (,(s, [])) $ Set.toList x)+                where x = poFail (storePoint store (s, [])) `Set.difference` Set.mapMonotonic Just (Map.keysSet $ storeSkip store)++        code | Right (p,_) <- info, any (isSuffixOf [p] . snd . qCandidate . snd) running = "active"+             | Left (s,_) <- info, (s,[]) `elem` map (qCandidate . snd) running = "active"+             | isJust failed = "fail"+             | Right (_, PatchInfo{..}) <- info, isJust paSupersede || isNothing paStart = "dull"+             | Right (_, PatchInfo{..}) <- info, isJust paMerge || isJust paPlausible  = "pass"+             | Left (s,_) <- info, fst active /= s = "pass"+             | Left (s,_) <- info, PointInfo{poTodo=Just todo,..} <- storePoint store (s,[])+                 , Set.size todo + 1 == Set.size (poPass `Set.union` poFail)  = "pass"+             | otherwise = ""++        body+            | Just (time, xs) <- failed = do+                span__ [class_ "bad"] $ str_ $ if isLeft info then "Failed" else "Rejected"+                str_ " at " <> showTime time+                when (xs /= []) br_+                span__ [class_ "info"] $ commasLimit_ 3 [showTestAt sps t | (t,sps) <- xs]+            | Right (_, p) <- info, paAlive p && isNothing (paStart p) = str_ "Queued"+            | Right (_, PatchInfo{paSupersede=Just t}) <- info = str_ "Superseded at " <> showTime t+            | Right (_, PatchInfo{paMerge=Just t}) <- info = do+                span__ [class_ "good"] $ str_ "Merged"+                str_ " at " <> showTime t+            | Right (_, PatchInfo{paPlausible=Just t}) <- info = do+                span__ [class_ "good"] $ str_ "Plausible"+                str_ " at " <> showTime t+            | Left (s,_) <- info, fst active /= s = span__ [class_ "good"] $ str_ "Passed"+            | Left (s,_) <- info, PointInfo{poTodo=Just todo,..} <- storePoint store (s,[])+                , Set.size todo + 1 == Set.size (poPass `Set.union` poFail)  = span__ [class_ "good"] $ str_ "Passed"+            | otherwise = str_ "Active"++        special+            | argsAdmin, Right (p, pi) <- info =+                if paAlive pi then+                    do br_; admin (DelPatch "admin" p) $ str_ "Delete"+                else if isNothing $ paMerge pi then+                    do br_; admin (AddPatch "admin" $ toPatch $ '\'' : fromPatch p) $ str_ "Retry"+                else+                    mempty+            | otherwise = mempty++        state = do+            either ((str_ "State " <>) . showState . fst) ((str_ "Patch " <>) . showPatch . fst) info+            whenRight info $ \(pa, PatchInfo{..}) -> str_ $ " by " ++ paAuthor+            br_+            span__ [class_ "info"] $ showExtra $ either (Left . fst) (Right . fst) info++        time = either (stCreated . snd) (paQueued . snd) info+++rowClient :: Shower -> Memory -> Maybe (Client, ClientInfo) -> (String, [HTML])+rowClient Shower{..} Memory{..} (Just (c, ClientInfo{..})) = ((if ciAlive then "" else "dull"),) $+    [showLink ("client=" ++ url_ (fromClient c)) $ str_ $ fromClient c+    ,if null xs then i_ $ str_ "None" else mconcat $ intersperse br_ xs]+    where xs = reverse [showQuestion q <> str_ " started " <> showTime t | (t,q) <- running, qClient q == c]+rowClient Shower{..} Memory{..} Nothing = ("",) $+    [showLink "server=" $ i_ $ str_ "Server"+    ,showLink ("server=" ++ fromState (fst active)) (str_ $ if isNothing stSource then "Initialised" else "Updated") <>+        str_ " finished " <> showTime stCreated]+    where StateInfo{..} = storeState store $ fst active

@@ -0,0 +1,108 @@+{-# LANGUAGE RecordWildCards, ViewPatterns #-}++module Development.Bake.StepGit(+    ovenStepGit+    ) where++import Development.Bake.Core.Type+import Development.Bake.Git+import Development.Shake.Command+import Development.Shake.FilePath+import Control.Exception.Extra+import Control.Monad.Extra+import System.Directory.Extra+import General.Extra+import Data.Maybe+import Data.List.Extra+import System.IO.Extra+import System.IO.Unsafe+++-- | Oven creation for modules using git with the step strategy.+ovenStepGit+    :: IO [FilePath] -- ^ Function that does a compile and returns the pieces that should be available at test time+    -> String -- ^ Git repo you are using+    -> String -- ^ Branch used as the initial starting point+    -> Maybe FilePath -- ^ Path under which the git will be checked out+    -> Oven () () test -- ^ Normal oven+    -> Oven SHA1 SHA1 test+ovenStepGit act repo branch path o = o+    {ovenInit = gitInit repo branch+    ,ovenUpdate = stepUpdate+    ,ovenPrepare = \s ps -> do stepPrepare s ps; ovenPrepare o () $ map (const ()) ps+    ,ovenSupersede = \_ _ -> False+    ,ovenPatchExtra = stepExtra+    }+    where+        -- use a different failure name each run, so failures don't get persisted+        failure = unsafePerformIO $ do+            t <- getCurrentTime+            return $ "failure-" ++ showUTCTime "%Y-%m-%dT%H-%M-%S%Q" t <.> "txt"+        root = createDir "../bake-step-git" [repo,branch]++        gitEnsure = do+            root <- root+            let git = root </> fromMaybe "repo" path+            createDirectoryIfMissing True git+            withFileLock (root </> ".bake-lock") $ do+                ready <- doesFileExist $ git </> ".git/HEAD"+                if ready then do+                    -- for some reason git sometimes times out, not sure why+                    -- hopefully this will help track it down+                    time_ $ cmd (Cwd git) (Timeout $ 15*60) "git fetch"+                    -- stops us creating lots of garbage in the reflog, which slows everything down+                    -- time_ $ cmd (Cwd git) "git reflog expire --all --expire=all --expire-unreachable=all"+                 else do+                    time_ $ cmd (Cwd git) "git clone" [repo] "."+                    time_ $ cmd (Cwd git) "git config user.email" ["https://github.com/ndmitchell/bake"]+                    time_ $ cmd (Cwd git) "git config user.name" ["Bake Continuous Integration"]+            return git++        gitSetState git s = do+            time_ $ cmd (Cwd git) "git checkout --force -B" [branch] [fromSHA1 s]++        gitApplyPatch git p = do+            time_ $ cmd (Cwd git) "git merge" [fromSHA1 p]++        stepExtra s p = do+            root <- root+            let (sh,a1) = splitAt 2 $ fromSHA1 $ fromMaybe s p+            unlessM (doesFileExist $ root </> fromMaybe "repo" path </> ".git/objects" </> sh </> a1) $ do+                void gitEnsure+            gitPatchExtra s p $ root </> fromMaybe "repo" path++        stepUpdate s ps = do+            root <- root+            git <- gitEnsure+            withFileLock (root </> ".bake-lock") $ do+                gitSetState git s+                forM_ ps $ gitApplyPatch git+                Stdout x <- time $ cmd (Cwd git) "git rev-parse" [branch]+                -- the branch may not already exist, or the update may not be a fast-forward+                -- since we support SetState+                Exit _ <- time $ cmd (Cwd git) "git push" [repo] [":" ++ branch]+                time_ $ cmd (Cwd git) "git push" [repo] [branch ++ ":" ++ branch]+                return $ sha1 $ trim x++        stepPrepare s ps = do+            root <- root+            dir <- createDir (root </> "../bake-step-point") $ map fromSHA1 $ s : ps+            unlessM (doesFileExist $ dir </> "result.tar") $ do+                git <- gitEnsure+                withFileLock (root </> ".bake-lock") $ do+                    gitSetState git s+                    forM_ (inits ps) $ \ps -> do+                        when (ps /= []) $ do+                            gitApplyPatch git $ last ps+                        dir <- createDir (root </> "../bake-step-point") $ map fromSHA1 $ s : ps+                        unlessM (doesFileExist $ dir </> "result.tar") $ do+                            whenM (doesFileExist $ dir </> failure) $ do+                                hPutStrLn stderr "failure found"+                                fail =<< readFile' (dir </> failure)+                            res <- withCurrentDirectory git (timed "stepPrepare user action" act) `catch_` \e -> do+                                writeFile (dir </> failure) =<< showException e+                                throwIO e+                            time_ $ cmd "tar -cf" [toStandard $ dir </> "result.tar"] "-C" [toStandard git] res++            createDirectoryIfMissing True $ fromMaybe "." path+            time_ $ cmd "tar -xf" [toStandard $ dir </> "result.tar"] "-C" [toStandard $ fromMaybe "." path]

@@ -0,0 +1,265 @@+{-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns #-}++module Development.Bake.Test.Simulate(+    simulate+    ) where++import Development.Bake.Core.Message+import Development.Bake.Core.Type+import Development.Bake.Server.Brain+import Development.Bake.Server.Memory+import Development.Bake.Server.Store+import Control.Monad.Extra+import Data.List.Extra+import Data.Tuple.Extra+import Data.Monoid+import Data.Maybe+import Numeric.Extra+import General.Extra+import System.Random+import System.IO.Extra+import System.Time.Extra+import qualified Data.Set as Set+import qualified Data.Map as Map+import Control.Applicative+import Prelude+++simulate :: IO ()+simulate = withBuffering stdout NoBuffering $ do+    performance 200+    basic+    bisect+    newTest+    quickPlausible+    replicateM_ 20 randomSimple++---------------------------------------------------------------------+-- GENERIC SIMULATION ENGINE+++-- Properties!+-- * By the time you finish, every patch must be propertly rejected or accepted+-- * Clients must not be executing too much at one time++data S s = S+    {user :: s+    ,memory :: Memory+    ,wait :: Int+    ,asked :: Set.Set Question+    ,patch :: [(Patch, Bool, Maybe Test -> Bool)]+    }++unstate :: State -> [Patch]+unstate = map toPatch . words . fromState++restate :: [Patch] -> State+restate = toState . unwords . map fromPatch++data Step = Submit Patch Bool (Maybe Test -> Bool) -- are you OK for it to pass, are you OK for it to fail+          | Reply Question Bool [Test]+          | Request Client+          | Paused Bool++simulation+    :: (Test -> TestInfo Test)                  -- ^ Static test information+    -> [(Client, Int)]                          -- ^ Clients, plus their maximum thread count+    -> s                                        -- ^ initial seed+    -> ([Question] -> s -> IO (s, Bool, Step))  -- ^ step function+    -> IO s+simulation testInfo workers u step = withTempDir $ \dir -> do+    t <- getCurrentTime+    s <- newStore True dir+    mem <- newMemory s (restate [], Answer mempty (Just 0) [] True)+    mem <- return mem+        {active = (restate [], [])+        ,simulated = True}+    let s = S u mem 20 Set.empty []++    let count s c = sum [qThreads | (_, Question{..}) <- running $ memory s, qClient == c]+    let oven = defaultOven+            {ovenUpdate = \s ps -> return $ restate $ unstate s ++ ps+            ,ovenTestInfo = testInfo+            ,ovenSupersede = \_ _ -> False+            ,ovenInit = undefined+            ,ovenPrepare = undefined+            ,ovenPatchExtra = undefined+            }+    s@S{..} <- flip loopM s $ \s -> do+        -- print $ clients $ memory s+        -- print $ storePoint (store $ memory s) (active $ memory s)+        putChar '.'+        (u, cont, res) <- step (map snd $ running $ memory s) (user s)+        s <- return s{user = u}+        (msg,s) <- return $ case res of+            Submit p pass fail -> (AddPatch "" p, s{patch = (p,pass,fail) : patch s})+            Reply q good tests ->+                let ans = Answer mempty (Just 0) (if good && isNothing (qTest q) then tests else []) good+                in (Finished q ans, s)+            Request c ->+                let Just mx = lookup c workers+                in (Pinged $ Ping c (fromClient c) [] mx $ mx - count s c, s)+            Paused b ->+                (if b then Pause "" else Unpause "", s)+        (mem, q) <- prod oven (memory s) msg+        q <- return $ either error id <$> q+        -- print q+        when (fatal mem /= []) $ error $ "Fatal error, " ++ unlines (fatal mem)+        s <- return s{memory = mem}+        s <- return $ case q of+            Just q | q `Set.member` asked s -> error "asking a duplicate question"+                   | otherwise -> s{asked = Set.insert q $ asked s}+            Nothing | not cont -> s{wait = wait s - 1}+            _ -> s+        return $ if wait s == 0 then Right s else Left s++    putStrLn ""+    let S{memory=Memory{..},..} = s++--    putStrLn $ unlines $ map show $ Map.toList $ storePoints store++    unless (null running) $ error "Running should have been empty"+    unless (null $ snd active) $ error "Active should have been empty"+    unless (Set.null $ storeAlive store) $ error "Alive should have been empty"+    forM_ workers $ \(c,_) -> do+        (_, q) <- prod oven Memory{..} $ Pinged $ Ping c (fromClient c) [] maxBound maxBound+        when (isJust q) $ error "Brains should have returned sleep"++    forM_ patch $ \(p, pass, fail) ->+        case () of+            _ | pass -> unless (p `elem` unstate (fst active)) $ error $ show ("expected pass but not",p)+              | PatchInfo{paReject=Just (_,t)} <- storePatch store p -> unless (all fail $ Map.keys t) $ error "incorrect test failure"+              | otherwise -> error "missing patch"+    return user+++---------------------------------------------------------------------+-- SPECIFIC SIMULATIONS++randomSimple :: IO ()+randomSimple = do+    let info t = mempty{testDepend = [toTest "1" | t /= toTest "1"]}++    i <- randomRIO (0::Int,10)+    patches <- forM [0..i] $ \i -> do+        j <- randomRIO (0::Int,9)+        return $ toPatch $ show i ++ show j+    let failure t p = maybe "0" fromTest t `isSuffixOf` fromPatch p++    let client = toClient "c"+    simulation info [(client,2)] patches $ \active patches -> do+        i <- randomRIO (0::Int, 20)+        let cont = not $ null active && null patches+        case i of+            0 | p:patches <- patches -> do+                let pass = last (fromPatch p) > '3'+                return (patches, cont, Submit p pass (`failure` p))++            i | i <= 2, not $ null active -> do+                i <- randomRIO (0, length active - 1)+                let q = active !! i+                let good = not $ any (failure $ qTest q) $ unstate (fst $ qCandidate q) ++ snd (qCandidate q)+                return (patches, cont, Reply q good $ map toTest ["1","2","3"])++            _ -> return (patches, cont, Request client)+    putStrLn "Success at randomSimple"+++quickPlausible :: IO ()+quickPlausible = do+    let info t = mempty{testPriority = if t == toTest "3" then 1 else if t == toTest "1" then -1 else 0}+    let client = toClient "c"+    let tests = map toTest ["1","2","3","4","5"]+    -- start, process 2 tests, add a patch, then process the rest+    -- expect to see 1, X, 1, rest, X++    let todo = [Paused True+               ,Submit (toPatch "0") True (const False)+               ,Submit (toPatch "1") False (== Just (toTest "3"))+               ,Submit (toPatch "2") True (const False)+               ,Paused False+               ,Submit (toPatch "3") True (const False)]++    simulation info [(client,1)] todo $ \active todo -> return $ case () of+        _ | t:odo <- todo -> (odo, True, t)+          | q@Question{..}:_ <- active ->+              if snd qCandidate == [toPatch "0",toPatch "2"] && qTest `notElem` [Nothing, Just $ toTest "3"] then error "bad quickPlausible"+              else (todo, True, Reply q (not $ qTest == Just (toTest "3") && toPatch "1" `elem` unstate (fst qCandidate) ++ snd qCandidate) tests)+          | otherwise -> (todo, False, Request client)+    putStrLn $ "Success at quickPlausible"+++bisect :: IO ()+bisect = do+    let info t = mempty+    let tests = map (toTest . show) [1 .. 3 :: Int]+    let client = toClient "c"+    (done,_) <- simulation info [(client,1)] (0, map (toPatch . show) [1 .. 1024 :: Int]) $ \active (done,patches) -> return $ case () of+        _ | p:patches <- patches -> ((done,patches), True, Submit p (p /= toPatch "26") (\t -> p == toPatch "26" && t == Just (toTest "2")))+          | q:_ <- active -> ((done+1,[]), True, Reply q (qTest q /= Just (toTest "2") || toPatch "26" `notElem` (unstate (fst $ qCandidate q) ++ snd (qCandidate q))) tests)+          | otherwise -> ((done,[]), False, Request client)+    when (done > 50) $ error "Did too many tests to bisect"+    putStrLn "Success at bisect"+++basic :: IO ()+basic = do+    -- have test x, fails in patch 4 of 5+    let info t = mempty+    let client = toClient "c"+    simulation info [(client,1)] (map (toPatch . show) [1..5 :: Int]) $ \active patches -> return $ case () of+        _ | p:patches <- patches -> (patches, True, Submit p (p /= toPatch "4") (\t -> p == toPatch "4" && t == Just (toTest "x")))+          | q:_ <- active, let isX = qTest q == Just (toTest "x"), let has12 = toPatch "4" `elem` snd (qCandidate q) ->+                ([], True, Reply q (not $ isX && has12) (map toTest ["x"]))+          | otherwise -> ([], False, Request client)+    putStrLn "Success at basic"+++newTest :: IO ()+newTest = do+    -- had test x,y all along. Introduce z/q at newPatch, and z either always fails or always passes+    let info t = mempty+    let client = toClient "c"+    let tests = map toTest ["x","y"]+    let patches = map (toPatch . show) [1..20 :: Int]+    let newTest = toTest "z"+    let newPatch = toPatch "12"++    forM_ [False,True] $ \pass -> do+        simulation info [(client,1)] patches $ \active patches -> return $ case () of+            _ | p:patches <- patches -> (patches, True, Submit p (p /= newPatch || pass) (\t -> not pass && p == newPatch && t == Just newTest))+              | q:_ <- active, let isTest = qTest q == Just newTest, let isPatch = newPatch `elem` snd (qCandidate q) ->+                    if isTest && not isPatch then error $ "Running a test that doesn't exist, " ++ show q+                    else ([], True, Reply q (not isTest || pass) (tests ++ [newTest | isPatch] ++ [toTest "q" | isPatch]))+              | otherwise -> ([], False, Request client)+        putStrLn "Success at newtest"++performance :: Int -> IO ()+performance nTests = timed $ do+    -- TODO: ping the website regularly+    -- 1000 tests, 50 submissions, 7 failing, spawn about every 200 tests+    let nPatches = 50+    let f x = min (nTests-1) $ max 0 $ round $ intToDouble nTests * x +    let fails = [(3,f 0.2),(4,f 0),(10,f 0.1),(22,f 0.6),(40,f 0.6),(48,f 0.9),(49,f 0.9)]++    let pri = toTest $ show $ f 0.1+    let npri = length $ fromTest pri+    let info t = mempty{testPriority = case compare (length $ fromTest t) npri of+                                            LT -> 1; GT -> 0; EQ -> if t < pri then 1 else 0}+    let client = toClient "c"+    let tests = map (toTest . show) [0 :: Int .. nTests - 1]+    simulation info [(client,3)] (0::Int, 0::Int) $ \active (patch,tick) -> return $ case () of+        _ | tick >= f 0.2, patch < nPatches ->+                let pass = patch `notElem` map fst fails+                    fail t = (patch,maybe (-1) (read . fromTest) t) `elem` fails+                in  ((patch+1, 0), True, Submit (toPatch $ show patch) pass fail)+          | q:_ <- active ->+                let pass = and [ (read $ fromPatch p, maybe (-1) (read . fromTest) $ qTest q) `notElem` fails+                               | p <- unstate (fst $ qCandidate q) ++ snd (qCandidate q)]+                in ((patch, tick+1), True, Reply q pass tests)+          | otherwise -> ((patch, tick), patch /= nPatches, Request client)+    putStrLn $ "Success at performance"+    where+        timed act = do+            (t, _) <- duration act+            putStrLn $ "Performance test took " ++ showDuration t

@@ -1,188 +0,0 @@-{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving #-}---- | Define a continuous integration system.-module Development.Bake.Type(-    Host, Port,-    Stringy(..), readShowStringy,-    Oven(..), TestInfo(..), defaultOven, ovenTest, ovenNotifyStdout,-    threads, threadsAll, require, run, suitable,-    State(..), Patch(..), Test(..), Client(..), concrete, validate,-    Author-    ) where--import Development.Bake.Format-import Control.Monad.Extra-import Data.Monoid-import Data.Aeson-import Data.Hashable-import Control.Arrow---type Author = String--type Host = String--type Port = Int---- | The central type defining a continuous integration system.---   Usually constructed with 'defaultOven' then filled out with other---   'Oven' modifiers such as 'ovenGit' and 'ovenTest'.------   The types are: @state@ is the base state of the system (think HEAD on the master branch);---   @patch@ is a change that is proposed (think a diff); @test@ is the type of tests that---   are run.------   All IO operations will be called in a direct subdirectory of the directory you start---   'bake' from. In particular:---   'ovenUpdateState' will always be called single-threaded from @bake-server@;---   'ovenPatchExtra' will always be called from @bake-patch-/hash/@;---   'ovenPrepare' and 'run' will always be called from @bake-test-/hash/@.-data Oven state patch test = Oven-    {ovenUpdateState :: Maybe (state, [patch]) -> IO state-        -- ^ Given a state, and a set of candiates that have passed,-        --   merge to create a new state.-    ,ovenPrepare :: state -> [patch] -> IO [test]-        -- ^ Prepare a candidate to be run, produces the tests that must pass-    ,ovenTestInfo :: test -> TestInfo test-        -- ^ Produce information about a test-    ,ovenNotify :: [Author] -> String -> IO ()-        -- ^ Tell an author some information contained in the string (usually an email)-    ,ovenPatchExtra :: state -> Maybe patch -> IO (String, String)-        -- ^ Extra information about a patch, a single line (HTML span),-        --   and a longer chunk (HTML block)-    ,ovenServer :: (Host, Port)-        -- ^ Default server to use-    ,ovenStringyState :: Stringy state-    ,ovenStringyPatch :: Stringy patch-    ,ovenStringyTest :: Stringy test-    }---- | Given a 'Stringy' for @test@, and a function that when run on a code base---   returns the list of tests that need running, and a function to populate---   a 'TestInfo', modify the 'Oven' with a test type.-ovenTest :: Stringy test -> IO [test] -> (test -> TestInfo test)-         -> Oven state patch () -> Oven state patch test-ovenTest stringy prepare info o = o{ovenStringyTest=stringy, ovenPrepare= \_ _ -> prepare, ovenTestInfo=info}---- | Produce notifications on 'stdout' when users should be notified about success/failure.-ovenNotifyStdout :: Oven state patch test -> Oven state patch test-ovenNotifyStdout o = o{ovenNotify = \a s -> f a s >> ovenNotify o a s}-    where f a s = putStr $ unlines-                    [replicate 70 '-'-                    ,"To: " ++ commas a-                    ,s-                    ,replicate 70 '-'-                    ]---- | A type representing a translation between a value and a string, which can be---   produced by 'readShowStringy' if the type has both 'Read' and 'Show' instances.---   The functions 'stringyTo' and 'stringyFrom' should be inverses of each other.---   The function 'stringyPretty' shows a value in a way suitable for humans, and can---   discard uninteresting information.-data Stringy s = Stringy-    {stringyTo :: s -> String-    ,stringyFrom :: String -> s-    ,stringyPretty :: s -> String-    }---- | Produce a 'Stringy' for a type with 'Read' and 'Show'.-readShowStringy :: (Show s, Read s) => Stringy s-readShowStringy = Stringy show read show---- | The default oven, which doesn't do anything interesting. Usually the starting point.-defaultOven :: Oven () () ()-defaultOven = Oven-    {ovenUpdateState = \_ -> return ()-    ,ovenNotify = \_ _ -> return ()-    ,ovenPrepare = \_ _ -> return []-    ,ovenTestInfo = \_ -> mempty-    ,ovenPatchExtra = \_ _ -> return ("","")-    ,ovenServer = ("127.0.0.1",80)-    ,ovenStringyState = readShowStringy-    ,ovenStringyPatch = readShowStringy-    ,ovenStringyTest = readShowStringy-    }---- | Information about a test.-data TestInfo test = TestInfo-    {testThreads :: Maybe Int -- number of threads, defaults to 1, Nothing for use all-    ,testAction :: IO ()-    ,testSuitable :: IO Bool -- can this test be run on this machine (e.g. Linux only tests)-    ,testRequire :: [test]-    }--instance Functor TestInfo where-    fmap f t = t{testRequire = map f $ testRequire t}--instance Monoid (TestInfo test) where-    mempty = TestInfo (Just 1) (return ()) (return True) []-    mappend (TestInfo x1 x2 x3 x4) (TestInfo y1 y2 y3 y4) =-        TestInfo (liftM2 (+) x1 y1) (x2 >> y2) (x3 &&^ y3) (x4 ++ y4)---- | Change the number of threads a test requires, defaults to 1.-threads :: Int -> TestInfo test -> TestInfo test-threads j t = t{testThreads=Just j}---- | Record that a test requires all available threads on a machine,---   typically used for the build step.---   Use 'getNumCapabilities' to find out how many threads you were allocated.-threadsAll :: TestInfo test -> TestInfo test-threadsAll t = t{testThreads=Nothing}----- | Require the following tests have been evaluated on this machine---   before this test is run. Typically used to require compilation---   before running most tests.-require :: [test] -> TestInfo test -> TestInfo test-require xs t = t{testRequire=testRequire t++xs}---- | The action associated with a @test@.-run :: IO () -> TestInfo test-run act = mempty{testAction=act}---- | Is a particular client capable of running a test.---   Usually an OS check.-suitable :: IO Bool -> TestInfo test -> TestInfo test-suitable query t = t{testSuitable = query &&^ testSuitable t}---newtype State = State {fromState :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable)-newtype Patch = Patch {fromPatch :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable)-newtype Test = Test {fromTest :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable)-newtype Client = Client {fromClient :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable)--concrete :: Oven state patch test -> Oven State Patch Test-concrete o@Oven{..} = o-    {ovenUpdateState = fmap restate . ovenUpdateState . fmap (unstate *** map unpatch)-    ,ovenPrepare = \s ps -> fmap (map retest) $ ovenPrepare (unstate s) (map unpatch ps)-    ,ovenTestInfo = fmap retest . ovenTestInfo . untest-    ,ovenPatchExtra = \s p -> ovenPatchExtra (unstate s) (fmap unpatch p)-    ,ovenStringyState = state-    ,ovenStringyPatch = patch-    ,ovenStringyTest  = test-    }-    where-        (patch,unpatch,_      ) = f Patch fromPatch ovenStringyPatch-        (state,unstate,restate) = f State fromState ovenStringyState-        (test ,untest ,retest ) = f Test  fromTest  ovenStringyTest--        f :: (String -> s) -> (s -> String) -> Stringy o -> (Stringy s, s -> o, o -> s)-        f inj proj Stringy{..} =-            (Stringy proj inj (stringyPretty . stringyFrom . proj)-            ,stringyFrom . proj-            ,inj . stringyTo)--validate :: Oven state patch test -> Oven state patch test-validate o@Oven{..} = o-    {ovenStringyState = f ovenStringyState-    ,ovenStringyPatch = f ovenStringyPatch-    ,ovenStringyTest = f ovenStringyTest-    }-    where-        f :: Stringy a -> Stringy a-        f s@Stringy{..} = s-            {stringyTo = check . stringyTo-            ,stringyFrom = stringyFrom . check-            }-            where check s | s == stringyTo (stringyFrom s) = s-                          | otherwise = error $ "Problem with stringyTo/stringyFrom on " ++ show s

@@ -1,51 +0,0 @@-{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving #-}--module Development.Bake.Util(-    Timestamp(..), getTimestamp, showRelativeTimestamp,-    createDir-    ) where--import Data.Time.Clock-import Data.Time.Calendar-import System.Time.Extra-import System.IO.Unsafe-import Data.IORef-import Data.Tuple.Extra-import System.Directory-import Data.Hashable-import System.FilePath---data Timestamp = Timestamp UTCTime Int deriving (Show,Eq)--{-# NOINLINE timestamp #-}-timestamp :: IORef Int-timestamp = unsafePerformIO $ newIORef 0--getTimestamp :: IO Timestamp-getTimestamp = do-    t <- getCurrentTime-    i <- atomicModifyIORef timestamp $ dupe . (+1)-    return $ Timestamp t i--showRelativeTimestamp :: IO (Timestamp -> String)-showRelativeTimestamp = do-    now <- getCurrentTime-    return $ \(Timestamp old _) ->-        let secs = subtractTime now old-            days = toModifiedJulianDay . utctDay-            poss = [(days now - days old, "day")-                   ,(floor $ secs / (60*60), "hour")-                   ,(floor $ secs / 60, "min")-                   ,(max 1 $ floor secs, "sec")-                   ]-            (i,s) = head $ dropWhile ((==) 0 . fst) poss-        in show i ++ " " ++ s ++ ['s' | i /= 1] ++ " ago"--createDir :: String -> [String] -> IO FilePath-createDir prefix info = do-    let name = prefix ++ "-" ++ show (abs $ hash info)-    writeFile (name <.> "txt") $ unlines info-    createDirectoryIfMissing True name-    return name-

@@ -1,77 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, RecordWildCards, OverloadedStrings #-}--module Development.Bake.Web(-    Input(..), Output(..), send, server-    ) where--import Development.Bake.Type hiding (run)-import Network.Wai.Handler.Warp hiding (Port)-import Network.Wai-import Control.DeepSeq-import Control.Exception-import Network.HTTP.Types.Status-import Network.HTTP hiding (Request)-import qualified Data.Text as Text-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as LBS-import System.Console.CmdArgs.Verbosity---data Input = Input-    {inputURL :: [String]-    ,inputArgs :: [(String, String)]-    ,inputBody :: String-    } deriving Show--data Output-    = OutputString String-    | OutputHTML String-    | OutputFile FilePath-    | OutputError String-    | OutputMissing-      deriving Show--instance NFData Output where-    rnf (OutputString x) = rnf x-    rnf (OutputHTML x) = rnf x-    rnf (OutputFile x) = rnf x-    rnf (OutputError x) = rnf x-    rnf OutputMissing = ()---send :: (Host,Port) -> Input -> IO String-send (host,port) Input{..} = do-    let url = "http://" ++ host ++ ":" ++ show port ++ concatMap ('/':) inputURL ++-              concat (zipWith (++) ("?":repeat "&") [a ++ "=" ++ b | (a,b) <- inputArgs])-    whenLoud $ print ("sending",inputBody,host,port)-    res <- simpleHTTP (getRequest url)-        {rqBody=inputBody-        ,rqHeaders=[Header HdrContentType "application/x-www-form-urlencoded", Header HdrContentLength $ show $ length inputBody]}-    case res of-        Left err -> error $ show err-        Right r | rspCode r /= (2,0,0) -> error $-                    "Incorrect code: " ++ show (rspCode r,rspReason r,url) ++ "\n" ++ rspBody r-                | otherwise -> return $ rspBody r---server :: Port -> (Input -> IO Output) -> IO ()-server port act = runSettings (setOnException exception $ setPort port defaultSettings) $ \req reply -> do-    bod <- strictRequestBody req-    whenLoud $ print ("receiving",bod,requestHeaders req,port)-    let pay = Input-            (map Text.unpack $ pathInfo req)-            [(BS.unpack a, maybe "" BS.unpack b) | (a,b) <- queryString req]-            (LBS.unpack bod)-    res <- act pay-    reply $ case res of-        OutputFile file -> responseFile status200 [] file Nothing-        OutputString msg -> responseLBS status200 [] $ LBS.pack msg-        OutputHTML msg -> responseLBS status200 [("content-type","text/html")] $ LBS.pack msg-        OutputError msg -> responseLBS status500 [] $ LBS.pack msg-        OutputMissing -> responseLBS status404 [] $ LBS.pack "Resource not found"--exception :: Maybe Request -> SomeException -> IO ()-exception r e-    | Just (_ :: InvalidRequest) <- fromException e = return ()-    | otherwise = putStrLn $ "Error when processing " ++ maybe "Nothing" (show . rawPathInfo) r ++-                             "\n    " ++ show e

@@ -1,20 +1,26 @@+{-# LANGUAGE FlexibleInstances #-}  module Example(main, platforms) where  import Development.Bake import Development.Shake.Command-import System.Environment+import System.Environment.Extra import System.FilePath import Data.List.Extra+import Data.Tuple.Extra import System.Directory-import Control.Arrow-import Control.Monad+import Control.Monad.Extra import Data.Maybe-+import System.Time.Extra  data Platform = Linux | Windows deriving (Show,Read) data Action = Compile | Run Int deriving (Show,Read) +instance Stringy (Platform, Action) where+    stringyTo (a,b) = show a ++ " " ++ show b+    stringyFrom = (read *** read) . word1++ platforms = [Linux,Windows]  main :: IO ()@@ -22,33 +28,27 @@     let err = "You need to set an environment variable named $REPO for the Git repo"     repo <- fromMaybe (error err) `fmap` lookupEnv "REPO"     bake $-        ovenIncremental $-        ovenPretty "=" $-        ovenGit repo "master" Nothing $+        ovenPretty $+        ovenStepGit compile repo "master" Nothing $         ovenNotifyStdout $-        ovenTest testStringy (return allTests) execute+        ovenTest (return allTests) execute         defaultOven{ovenServer=("127.0.0.1",5000)} -testStringy = Stringy shw rd shw-    where shw (a,b) = show a ++ " " ++ show b-          rd x = (read *** read) $ word1 x- allTests = [(p,t) | p <- platforms, t <- Compile : map Run [1,10,0]] +compile :: IO [FilePath]+compile = do+    createDirectoryIfMissing True "dist"+    unit $ cmd "ghc --make Main.hs -o dist/Main"+    sleep 1+    return ["dist"]+ execute :: (Platform,Action) -> TestInfo (Platform,Action)-execute (p,Compile) = matchOS p $ run $ do-    -- ghc --make isn't a good citizen of incremental-    -- so we remove the Main.hi file to force the rebuild-    Exit _ <- cmd "rm Main.hi"-    copyFile "Main.hs" "Main.bup"+execute (p,Compile) = require [show p] $ run $ when False $ do     () <- cmd "ghc --make Main.hs"-    incrementalDone-execute (p,Run i) = require [(p,Compile)] $ matchOS p $ run $ do-    when (i == 10) $ print =<< readFile "Main.hs"-    when (i == 10) $ print =<< readFile "Main.bup"-    cmd ("." </> "Main") (show i)---- So we can run both clients on one platform we use an environment variable--- to fake changing OS-matchOS :: Platform -> TestInfo t -> TestInfo t-matchOS p = suitable (fmap (== show p) $ getEnv "PLATFORM")+    -- ghc --make only has 1 second timestamp resolution+    -- so sleep for a second to make sure we work with incremental+    sleep 1+--    incrementalDone+execute (p,Run i) = depend [(p,Compile)] $ require [show p] $ run $+    cmd ("dist" </> "Main") (show i)

@@ -0,0 +1,245 @@+{-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns, RankNTypes, TypeOperators, TypeFamilies, ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}++module General.Database(+    Pred, (%==), (%==%), (%>), (%<), (%/=), (%&&), nullP, likeP,+    orderDesc, orderAsc, distinct, limit,+    Upd(..),+    TypeField(..),+    Table, table, Column, column, rowid, norowid,+    sqlInsert, sqlUpdate, sqlSelect, sqlDelete, sqlEnsureTable, sqlUnsafe+    ) where++import Data.List.Extra+import Data.String+import Data.Maybe+import Data.Time.Clock+import Data.Tuple.Extra+import Database.SQLite.Simple hiding ((:=))+import Database.SQLite.Simple.FromField+import Database.SQLite.Simple.ToField+++type family Uncolumns cs+type instance Uncolumns () = ()+type instance Uncolumns (Column a) = Only a+type instance Uncolumns (Only (Column a)) = Only a+type instance Uncolumns (Column a, Column b) = (a, b)+type instance Uncolumns (Column a, Column b, Column c) = (a, b, c)+type instance Uncolumns (Column a, Column b, Column c, Column d) = (a, b, c, d)+type instance Uncolumns (Column a, Column b, Column c, Column d, Column e) = (a, b, c, d, e)+type instance Uncolumns (Column a, Column b, Column c, Column d, Column e, Column f) = (a, b, c, d, e, f)+type instance Uncolumns (Column a, Column b, Column c, Column d, Column e, Column f, Column g) = (a, b, c, d, e, f, g)+type instance Uncolumns (Column a, Column b, Column c, Column d, Column e, Column f, Column g, Column h) = (a, b, c, d, e, f, g, h)+type instance Uncolumns (Column a, Column b, Column c, Column d, Column e, Column f, Column g, Column h, Column i) = (a, b, c, d, e, f, g, h, i)++data Table rowid cs = Table {tblName :: String, tblKeys :: [Column_], tblCols :: [Column_]}++data Column c = Column {colTable :: String, colName :: String, colSqlType :: String} deriving (Eq,Show)++type Column_ = Column ()++column_ :: Column c -> Column_+column_ Column{..} = Column{..}++class TypeField field where+    typeField :: field -> String++instance TypeField String where typeField _ = "TEXT NOT NULL"+instance TypeField Int where typeField _ = "INTEGER NOT NULL"+instance TypeField Double where typeField _ = "REAL NOT NULL"+instance TypeField UTCTime where typeField _ = "TEXT NOT NULL"+instance TypeField Bool where typeField _ = "INTEGER NOT NULL"+instance TypeField a => TypeField (Maybe a) where+    typeField x | Just s <- stripSuffix " NOT NULL" s = s+                | otherwise = error "Can't remove the NULL constraint"+        where s = typeField $ fromJust x++class Columns cs where columns :: cs -> [Column_]+instance Columns () where columns () = []+instance Columns (Column c1) where columns c1 = [column_ c1]+instance Columns (Only (Column c1)) where columns (Only c1) = [column_ c1]+instance Columns (Column c1, Column c2) where columns (c1, c2) = [column_ c1, column_ c2]+instance Columns (Column c1, Column c2, Column c3) where columns (c1, c2, c3) = [column_ c1, column_ c2, column_ c3]+instance Columns (Column c1, Column c2, Column c3, Column c4) where columns (c1, c2, c3, c4) = [column_ c1, column_ c2, column_ c3, column_ c4]+instance Columns (Column c1, Column c2, Column c3, Column c4, Column c5) where columns (c1, c2, c3, c4, c5) = [column_ c1, column_ c2, column_ c3, column_ c4, column_ c5]+instance Columns (Column c1, Column c2, Column c3, Column c4, Column c5, Column c6) where columns (c1, c2, c3, c4, c5, c6) = [column_ c1, column_ c2, column_ c3, column_ c4, column_ c5, column_ c6]+instance Columns (Column c1, Column c2, Column c3, Column c4, Column c5, Column c6, Column c7) where columns (c1, c2, c3, c4, c5, c6, c7) = [column_ c1, column_ c2, column_ c3, column_ c4, column_ c5, column_ c6, column_ c7]+instance Columns (Column c1, Column c2, Column c3, Column c4, Column c5, Column c6, Column c7, Column c8) where columns (c1, c2, c3, c4, c5, c6, c7, c8) = [column_ c1, column_ c2, column_ c3, column_ c4, column_ c5, column_ c6, column_ c7, column_ c8]+instance Columns (Column c1, Column c2, Column c3, Column c4, Column c5, Column c6, Column c7, Column c8, Column c9) where columns (c1, c2, c3, c4, c5, c6, c7, c8, c9) = [column_ c1, column_ c2, column_ c3, column_ c4, column_ c5, column_ c6, column_ c7, column_ c8, column_ c9]++table :: (Columns keys, Columns cols) => String -> Column rowid -> keys -> cols -> Table rowid (Uncolumns cols)+-- important to produce name before looking at columns+table name rowid (columns -> keys) (columns -> cols) = Table name (check keys) (check cols)+    where+        check x | nubOrd (map colTable $ keys ++ cols) /= [name] = error "Column with the wrong table"+                | not $ null $ map colName keys \\ map colName cols = error "Key column which is not one of the normal columns"+                | colName rowid `notElem` ["","rowid"] = error "Rowid column must have name rowid"+                | otherwise = x++column :: forall c rowid cs . TypeField c => Table rowid cs -> String -> Column c+column tbl row = Column (tblName tbl) row (typeField (undefined :: c))++rowid :: Table rowid cs -> Column rowid+rowid tbl = Column (tblName tbl) "rowid" ""++norowid :: Column ()+norowid = Column "" "" ""++sqlInsert :: (ToRow cs, FromField rowid) => Connection -> Table rowid cs -> cs -> IO rowid+sqlInsert conn tbl val = do+    let vs = toRow val+    -- FIXME: Should combine the last_insert_rowid with the INSERT INTO+    let str = "INSERT INTO " ++ tblName tbl ++ " VALUES (" ++ intercalate "," (replicate (length vs) "?") ++ ")"+    execute conn (fromString str) vs+    [Only row] <- query_ conn (fromString "SELECT last_insert_rowid()")+    return row+++sqlUpdate :: Connection -> [Upd] -> [Pred] -> IO ()+sqlUpdate conn upd pred = do+    let (updCs, updVs) = unzip $ map unupdate upd+    let (prdStr, _, prdCs, prdVs) = unpred pred+    let tbl = nubOrd $ map colTable $ updCs ++ prdCs+    case tbl of+        _ | null upd -> fail "Must update at least one column"+        [t] -> do+            let str = "UPDATE " ++ t ++ " SET " ++ intercalate ", " (map ((++ "=?") . colName) updCs) ++ " WHERE " ++ prdStr+            execute conn (fromString str) (updVs ++ prdVs)+        _ -> fail "Must update all in the same column"+++sqlDelete :: Connection -> Table rowid cs -> [Pred] -> IO ()+sqlDelete conn tbl pred = do+    let (prdStr, _, prdCs, prdVs) = unpred pred+    case nubOrd $ tblName tbl : map colTable prdCs of+        [t] -> do+            let str = "DELETE FROM " ++ t ++ " WHERE " ++ prdStr+            execute conn (fromString str) prdVs+        ts -> fail $ "sqlDelete, can only delete from one table but you are touching: " ++ unwords ts+++sqlSelect :: (FromRow (Uncolumns cs), Columns cs) => Connection -> cs -> [Pred] -> IO [Uncolumns cs]+sqlSelect conn cols pred = do+    let outCs = columns cols+    let (prdStr, prdDs, prdCs, prdVs) = unpred pred+    let str = "SELECT " ++ intercalate ", " [(if c `elem` prdDs then "DISTINCT " else "") ++ colTable ++ "." ++ colName | c@Column{..} <- outCs] ++ " " +++              "FROM " ++ intercalate ", " (nubOrd $ map colTable $ outCs ++ prdCs) ++ " WHERE " ++ prdStr+    query conn (fromString str) prdVs+++sqlEnsureTable :: Connection -> Table rowid cs -> IO ()+sqlEnsureTable conn Table{..} = do+    let fields = intercalate ", " $+            [colName ++ " " ++ colSqlType | Column{..} <- tblCols] +++            ["PRIMARY KEY (" ++ intercalate ", " (map colName tblKeys) ++ ")" | not $ null tblKeys]+    let str = "CREATE TABLE " ++ tblName ++ " (" ++ fields ++ ")"+    existing <- query conn (fromString "SELECT sql FROM sqlite_master WHERE type = ? AND name = ?") ("table", tblName)+    case existing of+        [Only s] | str == s -> return ()+        [] -> execute_ conn $ fromString str+        _ -> error $ "Trying to ensure table " ++ tblName ++ " but mismatch" +++                     "\nCreating:\n" ++ str ++ "\nGot:\n" ++ unlines (map fromOnly existing)+++sqlUnsafe :: (ToRow q, FromRow r) => Connection -> String -> q -> IO [r]+sqlUnsafe conn str q = query conn (fromString str) q+++data Upd = forall a . ToField a => Column a := a++unupdate :: Upd -> (Column_, SQLData)+unupdate (c := v) = (column_ c, toField v)++data Pred+    = PNull Column_+    | PNotNull Column_+    | PEq Column_ SQLData+    | PNEq Column_ SQLData+    | PGt Column_ SQLData+    | PLt Column_ SQLData+    | PEqP Column_ Column_+    | PLike Column_ SQLData+    | PAnd [Pred]+    | PDistinct Column_+    | POrder Column_ String+    | PLimit Int++distinct :: Column c -> Pred+distinct c = PDistinct (column_ c)++limit :: Int -> Pred+limit = PLimit++orderDesc :: Column UTCTime -> Pred+orderDesc c = POrder (column_ c) $ colTable c ++ "." ++ colName c ++ " DESC"++orderAsc :: Column UTCTime -> Pred+orderAsc c = POrder (column_ c) $ colTable c ++ "." ++ colName c ++ " ASC"++nullP :: Column (Maybe c) -> Pred+nullP c = PNull (column_ c)++likeP :: ToField c => Column c -> c -> Pred+likeP (column_ -> c) (toField -> v) = PLike c v++(%&&) :: Pred -> Pred -> Pred+(%&&) a b = PAnd [a,b]++(%==) :: ToField c => Column c -> c -> Pred+(%==) (column_ -> c) (toField -> v)+    | v == SQLNull = PNull c+    | otherwise = PEq c v++(%>) :: ToField c => Column c -> c -> Pred+(%>) (column_ -> c) (toField -> v)+    | v == SQLNull = error $ "Can't %> on a NULL"+    | otherwise = PGt c v++(%<) :: ToField c => Column c -> c -> Pred+(%<) (column_ -> c) (toField -> v)+    | v == SQLNull = error $ "Can't %> on a NULL"+    | otherwise = PLt c v++(%/=) :: ToField c => Column c -> c -> Pred+(%/=) (column_ -> c) (toField -> v)+    | v == SQLNull = PNotNull c+    | otherwise = PNEq c v++(%==%) :: ToField c => Column c -> Column c -> Pred+(%==%) c1 c2+    | isNull c1 || isNull c2 = error $ show ("Column must be NOT NULL to do %==%", show c1, show c2)+    | otherwise = PEqP (column_ c1) (column_ c2)+    where isNull c = not $ colSqlType c == "" || " NOT NULL" `isSuffixOf` colSqlType c++unpred :: [Pred] -> (String, [Column_], [Column_], [SQLData])+unpred ps =+    let (a,b,c) = f $ PAnd pred+    in (a ++ (if null order then "" else " ORDER BY " ++ unwords [x | POrder _ x <- order]) +++             (if null limit then "" else " LIMIT " ++ head [show x | PLimit x <- limit])+                ,+       [x | PDistinct x <- dist], b ++ [x | POrder x _ <- order], c)+    where+        isDistinct PDistinct{} = True; isDistinct _ = False+        isOrder POrder{} = True; isOrder _ = False+        isLimit PLimit{} = True; isLimit _ = False+        (dist, (order, (limit, pred))) = second (second (partition isLimit) . partition isOrder) $ partition isDistinct ps++        g Column{..} = colTable ++ "." ++ colName++        f (PNull c) = (g c ++ " IS NULL", [c], [])+        f (PNotNull c) = (g c ++ " IS NOT NULL", [c], [])+        f (PEq c v) = (g c ++ " == ?", [c], [v]) -- IS always works, but is a LOT slower+        f (PNEq c v) = (g c ++ " != ?", [c], [v]) -- IS always works, but is a LOT slower+        f (PGt c v) = (g c ++ " > ?", [c], [v]) -- IS always works, but is a LOT slower+        f (PLt c v) = (g c ++ " < ?", [c], [v]) -- IS always works, but is a LOT slower+        f (PEqP c1 c2) = (g c1 ++ " = " ++ g c2, [c1,c2], [])+        f (PLike c v) = (g c ++ " LIKE ?", [c], [v])+        f (PAnd []) = ("NULL IS NULL", [], [])+        f (PAnd [x]) = f x+        f (PAnd xs) = (intercalate " AND " ["(" ++ s ++ ")" | s <- ss], concat cs, concat vs)+            where (ss,cs,vs) = unzip3 $ map f xs+        f _ = error "Unrecognised Pred"++instance FromField () where+    fromField _ = return ()

@@ -0,0 +1,319 @@+{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, TupleSections, CPP #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+-- time changed incompatibly, use the functions that work everywhere++module General.Extra(+    UTCTime, getCurrentTime, addSeconds, showRelativeTime, relativeTime, showUTCTime,+    readDate, showDate, timeToDate, dateToTime,+    createDir,+    withFileLock,+    pick,+    memoIO0, memoIO1,+    encryptish,+    catMaybesSet,+    whenLeft, whenRight,+    timeInit, timed, time, time_,+    eitherToMaybe,+    newCVar, readCVar, modifyCVar, modifyCVar_,+    registerMaster, forkSlave,+    Worker, newWorker,+    makeRelativeEx,+    transitiveClosure, findCycle,+    putBlock,+    maybe',+    commas, commasLimit, unwordsLimit+    ) where++import Data.Time.Clock+import Data.Time.Calendar+import System.Time.Extra+import System.IO.Unsafe+import System.IO.Extra+import Data.IORef+import Data.List.Extra+import System.Directory.Extra+import Data.Hashable+import Numeric+import System.FilePath+import Control.Exception.Extra+import Control.Applicative+import Control.Monad.Extra+import Control.Concurrent.Extra+import Development.Shake.Command+import Data.Maybe+import System.Random+import Data.Either.Extra+import Data.Time.Format+#if __GLASGOW_HASKELL__< 710+import System.Locale+#endif+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Set as Set+import Prelude+++addSeconds :: Seconds -> UTCTime -> UTCTime+addSeconds x = addUTCTime (fromRational $ toRational x)++relativeTime :: IO (UTCTime -> Seconds)+relativeTime = do+    now <- getCurrentTime+    return $ \old -> subtractTime now old++showRelativeTime :: IO (UTCTime -> String)+showRelativeTime = do+    now <- getCurrentTime+    return $ \old ->+        let secs = subtractTime now old+            mins = secs / 60+            hours = mins / 60+        in if timeToDate now /= timeToDate old then showDate (timeToDate old)+        else if hours > 5 then show (round hours) ++ " hours ago"+        else if mins > 2 then show (round mins) ++ " mins ago"+        else show (max 2 $ round secs) ++ " secs ago"++showUTCTime :: String -> UTCTime -> String+showUTCTime = formatTime defaultTimeLocale++timeToDate :: UTCTime -> Day+timeToDate = utctDay++dateToTime :: Day -> UTCTime+dateToTime = flip UTCTime 0++readDate :: String -> Day+readDate = readTime defaultTimeLocale (iso8601DateFormat Nothing)++showDate :: Day -> String+showDate = formatTime defaultTimeLocale (iso8601DateFormat Nothing)++-- | One way function used for encrypting+encryptish :: String -> String+encryptish x = upper $ showHex (abs $ hash x) ""+++{-# NOINLINE logTime #-}+logTime :: IO Seconds+logTime = unsafePerformIO offsetTime++timeInit :: IO ()+timeInit = void $ evaluate =<< logTime+++{-# NOINLINE createDirLock #-}+createDirLock :: Lock+createDirLock = unsafePerformIO newLock++createDir :: String -> [String] -> IO FilePath+createDir prefix info = do+    let name = prefix ++ (if null info then "" else "-" ++ show (abs $ hash info))+    createDirectoryIfMissing True name+    withLock createDirLock $ writeFile (name </> ".bake.name") $ unlines info+    return name+++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe = either (const Nothing) Just++pick :: [a] -> IO a+pick xs = randomRIO (0, (length xs - 1)) >>= return . (xs !!)+++timed :: String -> IO a -> IO a+timed msg act = do+    (tim,res) <- duration act+    tot <- logTime+    putStrLn $ "[BAKE-TIME] " ++ showDuration tim ++ " (total of " ++ showDuration tot ++ "): " ++ msg+    return res++time_ :: IO (CmdLine, CmdTime) -> IO ()+time_ act = time $ do (a,b) <- act; return (a,b,())++time :: IO (CmdLine, CmdTime, a) -> IO a+time act = do+    (CmdLine msg, CmdTime tim, res) <- act+    tot <- logTime+    putStrLn $ "[BAKE-TIME] " ++ showDuration tim ++ " (total of " ++ showDuration tot ++ "): " ++ msg+    return res++makeRelativeEx :: FilePath -> FilePath -> IO FilePath+makeRelativeEx x y = do+    x <- splitDirectories <$> canonicalizePath x+    y <- splitDirectories <$> canonicalizePath y+    return $ joinPath $ if take 1 x /= take 1 y then y else f x y+    where+        f (x:xs) (y:ys)+            | x == y = f xs ys+            | otherwise = ".." : f xs (y:ys)+        f _ ys = ys+++-- Might be better off using the 'filelock' package+withFileLock :: FilePath -> IO a -> IO a+withFileLock lock act = do+    -- important to canonicalize everything as the act might change the current directory+    createDirectoryIfMissing True $ takeDirectory lock+    lock <- (</> takeFileName lock) <$> canonicalizePath (takeDirectory lock)++    let stamp = lock <.> "stamp"+    let touch = do t <- show <$> getCurrentTime; ignore $ writeFile stamp t; return t+    unlessM (doesFileExist stamp) $ void touch++    (t,_) <- duration $ whileM $ do+        b <- try_ $ createDirectory lock+        if isRight b then do+            return False+         else do+            sleep 10+            now <- getCurrentTime+            mtime <- try_ $ getModificationTime stamp+            case mtime of+                Right x | addSeconds 30 x > now -> return True+                _ -> do+                    -- try and take ownership of the stamp+                    me <- touch+                    sleep 10 -- wait for the stamp to settle down+                    src <- try_ $ readFile' stamp+                    return $ either (const True) (/= me) src+    putStrLn $ "Waited " ++ showDuration t ++ " to acquire the file lock " ++ lock++    active <- newVar True+    touch+    thread <- forkSlave $ forever $ do+        sleep 10+        withVar active $ \b -> when b $ void touch+    act `finally` do+        modifyVar_ active $ const $ return False+        killThread thread+        ignore $ removeDirectory lock++{-+tester :: IO ()+tester = do+    forM_ [1..2] $ \i -> do+        forkIO $ withFileLock "mylock" $ do+                print ("start", i)+                sleep 60+                print ("stop",i)+    sleep 1000+-}++---------------------------------------------------------------------+-- CVAR++-- | A Var, but where readCVar returns the last cached value+data CVar a = CVar {cvarCache :: Var a, cvarReal :: Var a}++newCVar :: a -> IO (CVar a)+newCVar x = liftM2 CVar (newVar x) (newVar x)++readCVar :: CVar a -> IO a+readCVar = readVar . cvarCache++modifyCVar :: CVar a -> (a -> IO (a, b)) -> IO b+modifyCVar CVar{..} f =+    modifyVar cvarReal $ \a -> do+        (a,b) <- f a+        modifyVar_ cvarCache $ const $ return a+        return (a,b)++modifyCVar_ :: CVar a -> (a -> IO a) -> IO ()+modifyCVar_ cvar f = modifyCVar cvar $ fmap (,()) . f+++---------------------------------------------------------------------+-- SLAVE/MASTER++{-# NOINLINE master #-}+master :: IORef (Maybe ThreadId)+master = unsafePerformIO $ newIORef Nothing++registerMaster :: IO ()+registerMaster = writeIORef master . Just =<< myThreadId++forkSlave :: IO () -> IO ThreadId+forkSlave act = forkFinally act $ \v -> case v of+    Left e | fromException e /= Just ThreadKilled -> do+        m <- readIORef master+        whenJust m $ flip throwTo e+    _ -> return ()++type Worker = IO () -> IO ()++newWorker :: IO Worker+newWorker = do+    lock <- newLock+    return $ \act -> void $ forkIO $ withLock lock act+++---------------------------------------------------------------------+-- UTILITIES++-- | Given a relation and a starting value, find the transitive closure.+--   The resulting list will be a set.+transitiveClosure :: Ord a => (a -> [a]) -> [a] -> [a]+transitiveClosure follow xs = f Set.empty xs+    where+        f seen [] = []+        f seen (t:odo) | t `Set.member` seen = f seen odo+                       | otherwise = t : f (Set.insert t seen) (follow t ++ odo)+++-- | Given a relation and a starting list, find a cycle if there is one.+--   The resulting list will be a set, and will contain a cycle (but not necessarily be minimal).+findCycle :: Ord a => (a -> [a]) -> [a] -> Maybe [a]+findCycle follow = firstJust $ \x ->+    let children = transitiveClosure follow (follow x)+    -- if there is a cycle, make the element we know is cyclic first, so its easier to debug+    in if x `elem` children then Just (x : delete x children) else Nothing+++memoIO0 :: IO b -> IO (IO b)+memoIO0 act = return $ unsafeInterleaveIO act++memoIO1 :: (Hashable a, Eq a) => (a -> IO b) -> IO (a -> IO b)+memoIO1 op = do+    var <- newVar HashMap.empty+    return $ \k -> modifyVar var $ \mp ->+        case HashMap.lookup k mp of+            Just v -> return (mp, v)+            Nothing -> do+                v <- op k+                return (HashMap.insert k v mp, v)+++catMaybesSet :: Ord a => Set.Set (Maybe a) -> Set.Set a+catMaybesSet = Set.mapMonotonic fromJust . Set.delete Nothing++whenLeft :: Applicative m => Either a b -> (a -> m ()) -> m ()+whenLeft x f = either f (const $ pure ()) x++whenRight :: Applicative m => Either a b -> (b -> m ()) -> m ()+whenRight x f = either (const $ pure ()) f x+++---------------------------------------------------------------------+-- FORMATTING++putBlock :: String -> [String] -> IO ()+putBlock title body = putStrLn $ unlines $+    let s = "-- " ++ title ++ " --" in+    (s ++ replicate (70 - length s) '-') :+    body +++    [replicate 70 '-']++commas :: [String] -> String+commas = intercalate ", "++commasLimit :: Int -> [String] -> String+commasLimit = limit commas++unwordsLimit :: Int -> [String] -> String+unwordsLimit = limit unwords++limit :: ([String] -> String) -> Int -> [String] -> String+limit rejoin i xs = rejoin a ++ (if null b then "" else "...")+    where (a,b) = splitAt i xs++maybe' :: Maybe a -> b -> (a -> b) -> b+maybe' x nothing just = maybe nothing just x

@@ -0,0 +1,180 @@+{-# LANGUAGE ViewPatterns #-}++module General.HTML(+    -- * Library+    url_,+    HTML, HTML_, renderHTML, valueHTML, str_, raw_,+    Attribute, attribute_,+    tag_, tag__,+    (<>),+    -- * Tags+    br_, style__, link__, hr_,+    pre_, b_, html_, head_, title_, body_, h1_, h2_, ul_, li_, p_, table_, thead_, tr_, td_, tbody_, i_,+    a__, span__, p__, h2__, tr__,+    href_, class_, name_, rel_, type_, style_, id_,+    -- * Functions+    unlines_, commas_, commasLimit_, header_+    ) where++import Control.Applicative+import Data.Monoid+import Data.List+import Control.Monad+import Data.Char+import Numeric+import Prelude+++---------------------------------------------------------------------+-- LIBRARY++data Rope = Branch [Rope] | Leaf String++renderRope :: Rope -> String+renderRope x = f x ""+    where f (Branch []) k = k+          f (Branch (x:xs)) k = f x $ f (Branch xs) k+          f (Leaf x) k = x ++ k++nullRope :: Rope -> Bool+nullRope (Branch xs) = all nullRope xs+nullRope (Leaf x) = null x++instance Monoid Rope where+    mempty = Branch []+    mappend a b = Branch [a,b]+    mconcat = Branch+++url_ :: String -> String+url_ = concatMap f+    where+        f x | (x >= 'A' && x <= 'Z') || (x >= 'a' && x <= 'z') || (x >= '0' && x <= '9') || x `elem` "-_.~" = [x]+        f (ord -> x) = "%" ++ ['0' | x < 16] ++ showHex x ""+++data HTML_ a = HTML_ Rope a++type HTML = HTML_ ()++valueHTML :: HTML_ a -> a+valueHTML (HTML_ _ x) = x++renderHTML :: HTML -> String+renderHTML (HTML_ x _) = renderRope x++nullHTML :: HTML -> Bool+nullHTML (HTML_ x _) = nullRope x++instance Monoid a => Monoid (HTML_ a) where+    mempty = HTML_ mempty mempty+    mappend (HTML_ x1 x2) (HTML_ y1 y2) = HTML_ (x1 `mappend` y1) (x2 `mappend` y2)++instance Functor HTML_ where+    fmap f (HTML_ a b) = HTML_ a $ f b++instance Applicative HTML_ where+    pure = HTML_ mempty+    HTML_ x1 x2 <*> HTML_ y1 y2 = HTML_ (x1 `mappend` y1) (x2 y2)++instance Monad HTML_ where+    return = pure+    HTML_ x1 x2 >>= f = let HTML_ y1 y2 = f x2 in HTML_ (x1 `mappend` y1) y2+++str_ :: String -> HTML+str_ = raw_ . escapeHTML++raw_ :: String -> HTML+raw_ x = HTML_ (Leaf x) ()++escapeHTML :: String -> String+escapeHTML = concatMap $ \c -> case c of+    '<'  -> "&lt;"+    '>'  -> "&gt;"+    '&'  -> "&amp;"+    '\"' -> "&quot;"+    '\'' -> "&#39;"+    x    -> [x]+++data Attribute = Attribute {fromAttribute :: String}++valid (x:xs) | isAlpha x && all isAlphaNum xs = True+valid x = error $ "Not a valid HTML name, " ++ show x++attribute_ :: String -> String -> Attribute+attribute_ a b | valid a = Attribute $ a ++ "=\"" ++ escapeHTML b ++ "\""+               | otherwise = error $ "Invalid attribute name, " ++ a+++tag__ :: String -> [Attribute] -> HTML -> HTML+tag__ name at inner | not $ valid name = error $ "Invalid tag name, " ++ name+                    | otherwise = do+    -- if you collapse an "a", it goes wrong+    -- if you don't collapse a "br", it goes wrong+    let zero = nullHTML inner && name `elem` ["br","link"]+    raw_ $+        "<" +++        unwords (name : map fromAttribute at) +++        (if zero then " /" else "") ++ ">"+    unless zero $ do+        inner+        raw_ $ "</" ++ name ++ ">"++tag_ :: String -> HTML -> HTML+tag_ name = tag__ name []+++---------------------------------------------------------------------+-- TAGS++br_ = tag_ "br" mempty+hr_ = tag_ "hr" mempty+link__ at = tag__ "link" at mempty+style__ at body = tag__ "style" at $ raw_ body++pre_ = tag_ "pre"+b_ = tag_ "b"+i_ = tag_ "i"+html_ = tag_ "html"+head_ = tag_ "head"+title_ = tag_ "title"+body_ = tag_ "body"+h1_ = tag_ "h1"+h2_ = tag_ "h2"+ul_ = tag_ "ul"+li_ = tag_ "li"+p_ = tag_ "p"+table_ = tag_ "table"+thead_ = tag_ "thead"+tr_ = tag_ "tr"+td_ = tag_ "td"+tbody_ = tag_ "tbody"++a__ = tag__ "a"+span__ = tag__ "span"+p__ = tag__ "p"+h2__ = tag__ "h2"+tr__ = tag__ "tr"++href_ = attribute_ "href"+class_ = attribute_ "class"+name_ = attribute_ "name"+rel_ = attribute_ "rel"+type_ = attribute_ "type"+style_ = attribute_ "style"+id_ = attribute_ "id"++unlines_ = mconcat . map (<> str_ "\n")+commas_ = mconcat . intersperse (str_ ", ")+commasLimit_ = limit_ commas_++limit_ :: ([HTML] -> HTML) -> Int -> [HTML] -> HTML+limit_ rejoin i xs = rejoin a <> str_ (if null b then "" else "...")+    where (a,b) = splitAt i xs+++-- FIXME: hack, very much app-specific+header_ :: String -> String -> HTML+header_ tag x = a__ [id_ tag,href_ $ "#" ++ tag,class_ "self"] $ h2_ $ str_ x

@@ -0,0 +1,92 @@+{-# LANGUAGE ScopedTypeVariables, RecordWildCards, OverloadedStrings, CPP #-}++module General.Web(+    Input(..), Output(..), send, server+    ) where++-- #define PROFILE++-- For some reason, profiling stops working if I import warp+-- Tracked as https://github.com/yesodweb/wai/issues/311+#ifndef PROFILE+import Network.Wai.Handler.Warp hiding (Port)+#endif++import Development.Bake.Core.Type hiding (run)+import Network.Wai+import Control.DeepSeq+import Control.Exception+import Network.HTTP.Types.Status+import Network.HTTP hiding (Request)+import qualified Data.Text as Text+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import System.Console.CmdArgs.Verbosity+++data Input = Input+    {inputURL :: [String]+    ,inputArgs :: [(String, String)]+    ,inputBody :: LBS.ByteString+    } deriving Show++data Output+    = OutputString String+    | OutputHTML String+    | OutputFile FilePath+    | OutputError String+    | OutputMissing+      deriving Show++instance NFData Output where+    rnf (OutputString x) = rnf x+    rnf (OutputHTML x) = rnf x+    rnf (OutputFile x) = rnf x+    rnf (OutputError x) = rnf x+    rnf OutputMissing = ()+++send :: (Host,Port) -> Input -> IO LBS.ByteString+send (host,port) Input{..} = do+    let url = "http://" ++ host ++ ":" ++ show port ++ concatMap ('/':) inputURL +++              concat (zipWith (++) ("?":repeat "&") [a ++ "=" ++ b | (a,b) <- inputArgs])+    whenLoud $ print ("sending",inputBody,host,port)+    res <- simpleHTTP (getRequest url)+        {rqBody=inputBody+        ,rqHeaders=[Header HdrContentType "application/x-www-form-urlencoded", Header HdrContentLength $ show $ LBS.length inputBody]}+    case res of+        Left err -> error $ show err+        Right r | rspCode r /= (2,0,0) -> error $+                    "Incorrect code: " ++ show (rspCode r,rspReason r,url) ++ "\n" ++ show (rspBody r)+                | otherwise -> return $ rspBody r+++server :: Port -> (Input -> IO Output) -> IO ()+#ifdef PROFILE+server port act = return ()+#else+server port act = runSettings (setOnException exception $ setPort port defaultSettings) $ \req reply -> do+    bod <- strictRequestBody req+    whenLoud $ print ("receiving",bod,requestHeaders req,port)+    let pay = Input+            (map Text.unpack $ pathInfo req)+            [(BS.unpack a, maybe "" BS.unpack b) | (a,b) <- queryString req]+            bod+    res <- act pay+    -- from http://stackoverflow.com/questions/49547/making-sure-a-web-page-is-not-cached-across-all-browsers+    let nocache = [("Cache-Control","no-cache, no-store, must-revalidate")+                  ,("Pragma","no-cache")+                  ,("Expires","0")]+    reply $ case res of+        OutputFile file -> responseFile status200 nocache file Nothing+        OutputString msg -> responseLBS status200 nocache $ LBS.pack msg+        OutputHTML msg -> responseLBS status200 (("content-type","text/html"):nocache) $ LBS.pack msg+        OutputError msg -> responseLBS status500 nocache $ LBS.pack msg+        OutputMissing -> responseLBS status404 nocache $ LBS.pack "Resource not found"++exception :: Maybe Request -> SomeException -> IO ()+exception r e+    | Just (_ :: InvalidRequest) <- fromException e = return ()+    | otherwise = putStrLn $ "Error when processing " ++ maybe "Nothing" (show . rawPathInfo) r +++                             "\n    " ++ show e+#endif

@@ -5,7 +5,7 @@ import System.Directory.Extra import System.IO.Extra import System.Time.Extra-import System.Environment+import System.Environment.Extra import System.FilePath import Control.Monad.Extra import Control.Exception.Extra@@ -14,19 +14,24 @@ import Data.List.Extra import Data.IORef import Data.Char+import Control.Applicative import qualified Example+import Prelude +import Development.Bake.Test.Simulate + main :: IO () main = do     args <- getArgs     if args /= [] then Example.main else do+        simulate         dir <- getCurrentDirectory         test $ dir ++ "/.bake-test"  test :: FilePath -> IO () test dir = do-    let repo = "file://" ++ replace "\\" "/" dir ++ "/repo"+    let repo = "file:///" ++ dropWhile (== '/') (replace "\\" "/" dir) ++ "/repo"     b <- doesDirectoryExist dir     when b $ do         () <- cmd "chmod -R 755 .bake-test"@@ -36,8 +41,8 @@     createDirectoryIfMissing True (dir </> "repo")     withCurrentDirectory (dir </> "repo") $ do         () <- cmd "git init"-        () <- cmd "git config user.email" ["master@example.com"]-        () <- cmd "git config user.name" ["The Master"]+        () <- cmd "git config user.email" ["gwen@example.com"]+        () <- cmd "git config user.name" ["Ms Gwen"]         writeFile "Main.hs" "module Main where\n\n-- Entry point\nmain = print 1\n"         () <- cmd "git add Main.hs"         () <- cmd "git commit -m" ["Initial version"]@@ -67,14 +72,17 @@             return pid     exe <- getExecutablePath     createDirectoryIfMissing True $ dir </> "server"-    environment <- fmap (("REPO",repo):) $ getEnvironment-    p0 <- createProcessAlive (proc exe ["server","--datadir=../.."])+    curdir <- getCurrentDirectory+    environment <- (\env -> ("REPO",repo):("bake_datadir",curdir):env) <$> getEnvironment+    p0 <- createProcessAlive (proc exe ["server"])         {cwd=Just $ dir </> "server", env=Just environment}-    ps <- forM Example.platforms $ \p -> do+    sleep 5+    ps <- forM (zip [1..] Example.platforms) $ \(i,p) -> do         sleep 0.5 -- so they don't ping at the same time         createDirectoryIfMissing True $ dir </> "client-" ++ show p-        createProcessAlive (proc exe ["client","--ping=1","--name=" ++ show p])-            {cwd=Just $ dir </> "client-" ++ show p,env=Just $ ("PLATFORM",show p) : environment}+        createProcessAlive (proc exe $+            ["client","--ping=1","--name=" ++ show p,"--threads=" ++ show i,"--provide=" ++ show p])+            {cwd=Just $ dir </> "client-" ++ show p,env=Just environment}     flip finally (do writeIORef aborting True; mapM_ terminateProcess $ p0 : ps) $ do         let edit name act = withCurrentDirectory (dir </> "repo-" ++ name) $ do                 act@@ -94,7 +102,7 @@         edit "tony" $             writeFile "Main.hs" "module Main where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n" -        retry 5 $ do+        retry 10 $ do             sleep 10             withTempDir $ \d -> withCurrentDirectory d $ do                 unit $ cmd "git clone" repo "."@@ -104,6 +112,7 @@                 when (src /= expect) $ do                     error $ "Expected to have updated Main, but got:\n" ++ src +        () <- cmd exe "pause" "--author=bake"         putStrLn "% MAKING A GOOD EDIT AS BOB"         edit "bob" $ do             unit $ cmd "git fetch origin"@@ -117,8 +126,9 @@             unit $ cmd "git fetch origin"             unit $ cmd "git merge origin/master"             writeFile "Main.hs" "-- Tony waz ere\nmodule Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n"+        () <- cmd exe "unpause" "--author=bake" -        retry 10 $ do+        retry 15 $ do             sleep 10             withTempDir $ \d -> withCurrentDirectory d $ do                 unit $ cmd "git clone" repo "."@@ -129,3 +139,4 @@                     error $ "Expected to have updated Main, but got:\n" ++ src          putStrLn "Completed successfully!"+        -- putStrLn "Waiting (time to view webpage)..." >> sleep 120