bake 0.3 → 0.4

raw patch · 27 files changed

+500/−293 lines, 27 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES.txt +3/−0
• README.md +8/−1
• bake.cabal +3/−2
• src/Development/Bake.hs +2/−0
• src/Development/Bake/Build.hs +45/−0
• src/Development/Bake/Core/Args.hs +8/−11
• src/Development/Bake/Core/Message.hs +22/−30
• src/Development/Bake/Core/Run.hs +2/−2
• src/Development/Bake/Core/Send.hs +13/−17
• src/Development/Bake/Core/Type.hs +7/−6
• src/Development/Bake/Email.hs +8/−9
• src/Development/Bake/Git.hs +1/−0
• src/Development/Bake/Pretty.hs +5/−0
• src/Development/Bake/Server/Brain.hs +66/−55
• src/Development/Bake/Server/Database.hs +47/−1
• src/Development/Bake/Server/Memory.hs +83/−5
• src/Development/Bake/Server/Property.hs +2/−2
• src/Development/Bake/Server/Start.hs +51/−36
• src/Development/Bake/Server/Stats.hs +2/−2
• src/Development/Bake/Server/Store.hs +30/−3
• src/Development/Bake/Server/Web.hs +22/−60
• src/Development/Bake/StepGit.hs +10/−4
• src/Development/Bake/Test/Simulate.hs +10/−10
• src/Example.hs +11/−7
• src/General/HTML.hs +4/−1
• src/General/Web.hs +10/−5
• src/Test.hs +25/−24

@@ -1,5 +1,8 @@ Changelog for Bake +0.4+    Remove the --author parameter from many operations+    Rewrite notifications 0.3     Add persistence to an SQLite db     Add ping expiration

@@ -80,4 +80,11 @@  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.+To add a patch we can run `bake addpatch --name=d088cc3c677a867185f083aca200cb421c27b984`, using the SHA1 of the commit, which will try and integrate that patch into the `master` branch, after all the tests have passed. Alternatively, we can run `bake addpatch --name=$(git rev-parse HEAD)` to try and integrate our working tree into `master`.++When viewing the server, there are a few additional URL's that may be of use:++* `?stats=` will show stats about which tests take longest, how long a test run takes, which test fails most often.+* `?raw=` will give internal details of the implementation.+* `/dump` will download an SQLite database containing all of the persistent state.+* `?admin=` will give you an admin control panel on any page, letting you retry/delete patches and skip tests. If you want to restrict access to this panel, run `bake admin myPassword` which says that running `bake server --admin=3A18885C` will then require `?admin=myPassword`.

@@ -1,7 +1,7 @@ cabal-version:      >= 1.10 build-type:         Simple name:               bake-version:            0.3+version:            0.4 license:            BSD3 license-file:       LICENSE category:           Development@@ -21,7 +21,7 @@ bug-reports:        https://github.com/ndmitchell/bake/issues tested-with:        GHC==7.10.1, GHC==7.8.4, GHC==7.6.3 -extra-source-files:+extra-doc-files:     CHANGES.txt     README.md @@ -67,6 +67,7 @@         Development.Bake      other-modules:+        Development.Bake.Build         Development.Bake.Core.Args         Development.Bake.Core.Client         Development.Bake.Core.GC

@@ -12,6 +12,7 @@     SHA1, ovenGit, ovenStepGit,     ovenNotifyAdd, ovenNotifyStdout, ovenNotifyEmail,     ovenPretty, ovenPrettyMerge,+    ovenIncremental, incrementalStart, incrementalDone,     -- ** TestInfo members     TestInfo, run, threads, threadsAll, depend, require, priority,     -- * Operations@@ -27,6 +28,7 @@ import Development.Bake.Core.Args import Development.Bake.Core.GC import Development.Bake.Core.Send+import Development.Bake.Build import Development.Bake.Git import Development.Bake.StepGit import Development.Bake.Pretty

@@ -0,0 +1,45 @@+{-# LANGUAGE RecordWildCards, ViewPatterns #-}++module Development.Bake.Build(+    ovenIncremental, incrementalDone, incrementalStart+    ) where++import Development.Bake.Core.Type+import Development.Shake.Command+import Control.Monad.Extra+import Control.Applicative+import System.FilePath+import Control.Exception.Extra+import System.Directory+import General.Extra+import Prelude+++-- Files involved:+-- ../bake-incremental.txt, stores the directory name of the most recent successful increment+-- .bake.incremental exists if you have done an increment yourself, or copied from someone who has+-- we always use the most recent increment to build onwards from++-- | 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{ovenPrepare = \s ps -> do incPrepare s ps; ovenPrepare s ps}+    where+        incPrepare s ps = ignore $ do+            -- if i have already been incremental'd (via copy, or via completion) don't do anything+            unlessM (doesFileExist ".bake.incremental") $ do+                src <- takeWhile (/= '\n') <$> readFile "../bake-incremental.txt"+                whenM (doesFileExist $ ".." </> src </> ".bake.incremental") $ do+                    putStrLn $ "Preparing by copying from " ++ src+                    timed "copying for ovenIncremental" $+                        unit $ cmd "cp --preserve=timestamps --recursive --no-target-directory" ("../" ++ src) "."++incrementalStart :: IO ()+incrementalStart =+    writeFile ".bake.incremental" ""++incrementalDone :: IO ()+incrementalDone = do+    incrementalStart+    x <- getCurrentDirectory+    writeFile "../bake-incremental.txt" $ unlines [takeFileName x]

@@ -32,12 +32,11 @@     = 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]}+    | DelPatch {host :: Host, port :: Port, name :: String}+    | Requeue {host :: Host, port :: Port}     | SetState {host :: Host, port :: Port, author :: [Author], state :: String}-    | Pause {host :: Host, port :: Port, author :: [Author]}-    | Unpause {host :: Host, port :: Port, author :: [Author]}+    | Pause {host :: Host, port :: Port}+    | Unpause {host :: Host, port :: Port}     | GC {bytes :: Integer, ratio :: Double, days :: Double, dirs :: [FilePath]}     | Admin {password :: [String]}     | View {port :: Port, file :: FilePath}@@ -54,7 +53,6 @@     ,Client{host = "", threads = 1, name = "", ping = 60, provide = []}     ,AddPatch{}     ,DelPatch{}-    ,DelPatches{}     ,Requeue{}     ,SetState{state = ""}     ,Pause{}@@ -98,12 +96,11 @@             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+        DelPatch{..} -> sendDelPatch (getHostPort host port) =<< check "patch" (undefined :: patch) name+        Requeue{..} -> sendRequeue (getHostPort host port)         SetState{..} -> sendSetState (getHostPort host port) author1 state-        Pause{..} -> sendPause (getHostPort host port) author1-        Unpause{..} -> sendUnpause (getHostPort host port) author1+        Pause{..} -> sendPause (getHostPort host port)+        Unpause{..} -> sendUnpause (getHostPort host port)         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'"

@@ -20,16 +20,14 @@  data Message     -- Send by the user-    = AddPatch Author Patch-    | DelPatch Author Patch-    | DelAllPatches Author-    | Requeue Author-    | SetState Author State-    | Pause Author-    | Unpause Author+    = SetState Author State+    | AddPatch Author Patch+    | DelPatch Patch+    | Requeue+    | Pause+    | Unpause     | AddSkip Author Test-    | DelSkip Author Test-    | ClearSkip Author+    | DelSkip Test     -- Sent by the client     | Pinged Ping     | Finished {question :: Question, answer :: Answer}@@ -37,15 +35,13 @@  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 (DelPatch x) = rnf x+    rnf Requeue = ()     rnf (SetState x y) = rnf x `seq` rnf y-    rnf (Pause x) = rnf x-    rnf (Unpause x) = rnf x+    rnf Pause = ()+    rnf Unpause = ()     rnf (AddSkip x y) = rnf x `seq` rnf y-    rnf (DelSkip x y) = rnf x `seq` rnf y-    rnf (ClearSkip x) = rnf x+    rnf (DelSkip x) = rnf x     rnf (Pinged x) = rnf x     rnf (Finished x y) = rnf x `seq` rnf y @@ -125,15 +121,13 @@  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 (DelPatch patch) = Input ["api","del"] [("patch",fromPatch patch)] ""+messageToInput Requeue = Input ["api","requeue"] [] "" 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 Pause = Input ["api","pause"] [] ""+messageToInput Unpause = Input ["api","unpause"] [] "" 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 (DelSkip test) = Input ["api","delskip"] [("test",fromTest test)] "" messageToInput (Pinged Ping{..}) = Input ["api","ping"]      ([("client",fromClient pClient),("author",pAuthor)] ++      [("provide",x) | x <- pProvide] ++@@ -145,15 +139,13 @@ 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 == "del" = DelPatch <$> (toPatch <$> str "patch")     | 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 == "delskip" = DelSkip <$> (toTest <$> str "test")+    | msg == "requeue" = pure Requeue     | msg == "set" = SetState <$> str "author" <*> (toState <$> str "state")-    | msg == "pause" = Pause <$> str "author"-    | msg == "unpause" = Unpause <$> str "author"+    | msg == "pause" = pure Pause+    | msg == "unpause" = pure Unpause     | msg == "ping" = Pinged <$> (Ping <$> (toClient <$> str "client") <*>         str "author" <*> strs "provide" <*> int "maxthreads" <*> int "nowthreads")     | msg == "finish" = eitherDecode body

@@ -48,12 +48,12 @@      (time, res) <- duration $ try_ $ do         exe <- getExecutablePath-        (exit, Stdout sout, Stderr serr) <- cmd (Cwd dir) exe ("run" ++ name) args1 args2+        (exit, Stdouterr out) <- 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))+        return (ex, Answer (TL.pack out) (Just 0) [] (exit == ExitSuccess))     case res of         Left e -> do             e <- showException e

@@ -1,39 +1,35 @@ {-# LANGUAGE RecordWildCards #-}  module Development.Bake.Core.Send(-    sendPause, sendUnpause,-    sendAddPatch, sendDelPatch, sendDelAllPatches, sendRequeue,-    sendAddSkip, sendDelSkip,-    sendSetState+    sendAddPatch, sendDelPatch, sendSetState,+    sendPause, sendUnpause, sendRequeue,+    sendAddSkip, sendDelSkip     ) 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+sendPause :: (Host,Port) -> IO ()+sendPause hp = void $ sendMessage hp Pause -sendUnpause :: (Host,Port) -> Author -> IO ()-sendUnpause hp author = void $ sendMessage hp $ Unpause author+sendUnpause :: (Host,Port) -> IO ()+sendUnpause hp = void $ sendMessage hp Unpause  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+sendDelPatch :: (Host,Port) -> String -> IO ()+sendDelPatch hp x = void $ sendMessage hp $ DelPatch $ toPatch x -sendRequeue :: (Host,Port) -> Author -> IO ()-sendRequeue hp author = void $ sendMessage hp $ Requeue author+sendRequeue :: (Host,Port) -> IO ()+sendRequeue hp = void $ sendMessage hp Requeue  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+sendDelSkip :: (Host,Port) -> String -> IO ()+sendDelSkip hp x = void $ sendMessage hp $ DelSkip $ toTest x  sendSetState :: (Host,Port) -> Author -> String -> IO () sendSetState hp author x = void $ sendMessage hp $ SetState author $ toState x

@@ -61,8 +61,8 @@         -- ^ 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)+    ,ovenNotify :: Author -> String -> String -> IO ()+        -- ^ Tell an author some information. The first 'String' is a subject line, the second an HTML fragment.     ,ovenPatchExtra :: state -> Maybe patch -> IO (String, String)         -- ^ Extra information about a patch, a single line (HTML span),         --   and a longer chunk (HTML block)@@ -80,12 +80,13 @@ 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}+ovenNotifyAdd :: (Author -> String -> String -> IO ()) -> Oven state patch test -> Oven state patch test+ovenNotifyAdd f o = o{ovenNotify = \a s b -> f a s b >> ovenNotify o a s b}  -- | 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]+ovenNotifyStdout = ovenNotifyAdd $ \author subject body ->+    putBlock "Email" ["To: " ++ author, "Subject: " ++ subject, body]  -- | 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.@@ -118,7 +119,7 @@ defaultOven = Oven     {ovenInit = return ()     ,ovenUpdate = \_ _ -> return ()-    ,ovenNotify = \_ _ -> return ()+    ,ovenNotify = \_ _ _ -> return ()     ,ovenPrepare = \_ _ -> return []     ,ovenTestInfo = \_ -> mempty     ,ovenPatchExtra = \_ _ -> return ("","")

@@ -1,17 +1,16 @@+{-# LANGUAGE RecordWildCards #-}  module Development.Bake.Email(ovenNotifyEmail) where  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.-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) -> [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)+-- | Send notifications using the given SMTP host/port.+ovenNotifyEmail :: (Host, Port) -> Oven state patch test -> Oven state patch test+ovenNotifyEmail (h,p) = ovenNotifyAdd $ \author subject body -> do+    sendMail' h (fromIntegral p) $ simpleMail+        (addr "bake@example.com") [addr author] [] []+        (fromString $ "[Bake] " ++ subject) [htmlPart $ fromString body]+    where addr x = Address Nothing (fromString x)

@@ -79,6 +79,7 @@                 gitSafe path                 time_ $ cmd (Cwd path) "git remote add origin" [(if path == "." then "" else "../") ++ mirror]             time_ $ cmd (Cwd path) "git fetch"+            time_ $ cmd (Cwd path) "git reset" -- to unwedge a previous merge conflict             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"

@@ -16,6 +16,9 @@     stringyPretty (Pretty a b) = a ++ "=" ++ stringyPretty b  +-- | Define an oven that allows @foo=...@ annotations to be added to the strings.+--   These can be used to annotate important information, e.g. instead of talking about+--   Git SHA1's, you can talk about @person=SHA1@ or @branch=SHA1@. ovenPretty :: Oven state patch test -> Oven state (Pretty patch) test ovenPretty oven@Oven{..} = oven     {ovenUpdate = \s ps -> ovenUpdate s (map unpretty ps)@@ -27,6 +30,8 @@         unpretty :: Pretty a -> a         unpretty (Pretty _ x) = x +-- | An oven suitable for use with 'ovenPretty' that supersedes patches which have the same+--   pretty name. ovenPrettyMerge :: Oven state (Pretty patch) test -> Oven state (Pretty patch) test ovenPrettyMerge oven = oven     {ovenSupersede = \(Pretty p1 _) (Pretty p2 _) -> p1 == p2

@@ -15,13 +15,14 @@ import Data.Tuple.Extra import Data.Maybe import Data.Monoid-import Control.Monad+import Control.Monad.Extra 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 General.HTML import Prelude  import Development.Bake.Server.Memory@@ -37,19 +38,19 @@     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+prod :: Memory -> Message -> IO (Memory, Maybe (Either String Question))+prod mem msg = safely $ do+    res <- update mem msg     case res of         Left err -> return (mem, Just $ Left err)         Right mem -> do-            mem <- reacts oven mem+            mem <- reacts mem             case msg of-                Pinged p | null $ fatal mem, Just q <- output (ovenTestInfo oven) mem p ->+                Pinged p | null $ fatal mem, Just q <- output (ovenTestInfo $ oven mem) 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+                            prod 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)@@ -62,36 +63,53 @@                 Right v -> return v  -reacts :: Oven State Patch Test -> Memory -> IO Memory-reacts oven = f 10+reacts :: Memory -> IO Memory+reacts = 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+        f i mem | null $ fatal mem, Just mem <- react mem = f (i-1) =<< mem                 | otherwise = return mem  -react :: Oven State Patch Test -> Memory -> Maybe (IO Memory)-react oven mem@Memory{..}+failingTestOutput :: Store -> Point -> Maybe Test -> Maybe String+failingTestOutput store (state, patch) test = listToMaybe $ catMaybes+    [ storeRunFile store runid+    | (runid, _, _, Answer{aSuccess=False}) <- storeRunList store Nothing (Just test) (Just state) patch Nothing]+++react :: Memory -> Maybe (IO Memory)+react 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+        let point p = (fst active, takeWhile (/= p) (snd active) ++ [p])+        bad <- if fresh == [] then return id 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]+            Shower{..} <- shower mem False+            notify mem "Rejected"+                [ (paAuthor,) $ do+                    showPatch p <> str_ " submitted at " <> showTime paQueued+                    str_ " rejected due to " <> showTestAt (point p) t+                    whenJust (failingTestOutput store (point p) t) $ \s ->+                        br_ <> br_ <> pre_ (summary s)+                | (p,t) <- nubOrdOn fst xs, let PatchInfo{..} = storePatch store p]+         store <- storeUpdate store-            [IUReject p t (fst active, takeWhile (/= p) (snd active) ++ [p]) | (p,t) <- xs]-        return mem{store = store, fatal = bad ++ fatal}+            [IUReject p t (point p) | (p,t) <- xs]+        return $ bad mem{store = store}      | 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)+        Shower{..} <- shower mem False+        -- don't notify people twice in quick succession+        bad <- if mergeable mem then return id else+            notify mem "Plausible"+                [ (paAuthor, showPatch p <> str_ " submitted at " <> showTime paQueued <> str_ " is now plausible")+                | p <- xs, let PatchInfo{..} = storePatch store p]         store <- storeUpdate store $ map IUPlausible xs-        return mem{store = store, fatal = bad ++ fatal}+        return $ bad mem{store = store}      | mergeable mem     , not $ null $ snd active@@ -100,16 +118,18 @@             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)+                Shower{..} <- shower mem False+                bad <- notify mem "Merged"+                    [ (paAuthor, showPatch p <> str_ " submitted at " <> showTime paQueued <> str_ " is now merged")+                    | p <- snd active, let PatchInfo{..} = storePatch store p]                 store <- storeUpdate store $ IUState s answer (Just active) : map IUMerge (snd active)-                return mem{active = (s, []), store = store, fatal = bad ++ fatal}+                return $ bad mem{active = (s, []), store = store} -    | restrictActive oven mem+    | restrictActive mem     , (reject@(_:_), keep) <- partition (isJust . paReject . storePatch store) $ snd active     = Just $ do         return mem{active = (fst active, keep)}@@ -124,17 +144,12 @@             ,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 :: Memory -> Message -> IO (Either String Memory)+update mem _ | fatal mem /= [] = return $ Right mem -update oven mem@Memory{..} (AddPatch author p) =+update mem@Memory{..} (AddPatch author p) =     if storeIsPatch store p then         return $ Left "patch has already been submitted"      else do@@ -143,77 +158,73 @@         store <- storeUpdate store $ IUQueue p author : map IUSupersede supersede         return $ Right mem{store = store} -update oven mem@Memory{..} (DelPatch _ p) =+update 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) = +update 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+update mem@Memory{..} Requeue = 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 _)+update mem@Memory{..} Pause     | paused = return $ Left "already paused"     | otherwise = return $ Right mem{paused = True} -update oven mem@Memory{..} (Unpause _)+update mem@Memory{..} Unpause     | not paused = return $ Left "already unpaused"     | otherwise = return $ Right mem{paused = False} -update oven mem@Memory{..} (Pinged ping) = do+update 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)+update 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)+update mem@Memory{..} (DelSkip 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+update mem@Memory{..} (Finished q@Question{..} a@Answer{..}) = do+    bad <- 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 ()+          -> do+            Shower{..} <- shower mem False+            notifyAdmins mem "State failure" $ do+                str_ "State " <> showState (fst qCandidate)+                str_ " failed due to " <> showTestAt qCandidate qTest <> br_ <> br_+                pre_ $ summary $ TL.unpack aStdout+        _ -> return id      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+    return $ Right $ bad mem         {store = store         ,clients = Map.adjust add qClient clients         ,running = neq}

@@ -1,9 +1,13 @@-{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, CPP #-}  -- Stuff on disk on the server module Development.Bake.Server.Database(     PointId, RunId, StateId, PatchId, patchIds, fromPatchIds, patchIdsSuperset,     saTable, saId, saState, saCreate, saPoint, saDuration,+#if OPALEYE+    SATable(..), SATableVal, SATableCol, saTable__,+    PCTable(..), PCTableVal, PCTableCol, pcTable__,+#endif     pcTable, pcId, pcPatch, pcAuthor, pcQueue, pcStart, pcDelete, pcSupersede, pcReject, pcPlausible, pcMerge,     rjTable, rjPatch, rjTest, rjRun,     ptTable, ptId, ptState, ptPatches,@@ -30,7 +34,14 @@ import General.Database import Prelude +#if OPALEYE+import Opaleye hiding (Column)+import Data.Profunctor.Product.TH(makeAdaptorAndInstance)+import qualified Opaleye as O+import qualified Opaleye.Internal.RunQuery as O+#endif + 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)@@ -56,12 +67,47 @@ fromPatchIds (PatchIds xs) = map (PatchId . readNote "fromPatchIds") $ splitOn "][" $ init $ tail xs  +#if OPALEYE+data SATable a b c d e = SATable {saId_ :: a, saState_ :: b, saCreate_ :: c, saPoint_ :: d, saDuration_ :: e}+type SATableVal = SATable StateId State UTCTime (Maybe PointId) (Maybe Seconds)+type SATableCol = SATable (O.Column StateId) (O.Column State) (O.Column PGTimestamptz) (O.Column (Nullable Int)) (O.Column (Nullable PGFloat8))+type SATableColW = SATable (Maybe (O.Column StateId)) (O.Column State) (O.Column PGTimestamptz) (O.Column (Nullable Int)) (O.Column (Nullable PGFloat8))++$(makeAdaptorAndInstance "pSATable" ''SATable)++saTable__ :: O.Table SATableColW SATableCol+saTable__ = O.Table "state" $ pSATable $+    SATable (optional "rowid") (required "state") (required "time") (required "point") (required "duration")++instance O.QueryRunnerColumnDefault Patch Patch where+    queryRunnerColumnDefault = O.fieldQueryRunnerColumn+instance O.QueryRunnerColumnDefault State State where+    queryRunnerColumnDefault = O.fieldQueryRunnerColumn+#endif++ 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)+++#if OPALEYE+data PCTable a b c d e f g h i j = PCTable {pcId_ :: a, pcPatch_ :: b, pcAuthor_ :: c, pcQueue_ :: d, pcStart_ :: e, pcDelete_ :: f, pcSupersede_ :: g, pcReject_ :: h, pcPlausible_ :: i, pcMerge_ :: j}+type PCTableVal = PCTable PatchId Patch String UTCTime (Maybe UTCTime) (Maybe UTCTime) (Maybe UTCTime) (Maybe UTCTime) (Maybe UTCTime) (Maybe UTCTime)+type PCTableColW = PCTable (Maybe (O.Column PatchId)) (O.Column Patch) (O.Column PGText) (O.Column PGTimestamptz) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz))+type PCTableCol = PCTable (O.Column PatchId) (O.Column Patch) (O.Column PGText) (O.Column PGTimestamptz) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz))++$(makeAdaptorAndInstance "pPCTable" ''PCTable)++pcTable__ :: O.Table PCTableColW PCTableCol+pcTable__ = O.Table "patch" $ pPCTable $+    PCTable (optional "rowid") (required "patch") (required "author") (required "queue") (required "start")+            (required "delete_") (required "supersede") (required "reject") (required "plausible") (required "merge")+#endif+  pcTable = table "patch" pcId pcPatch (pcPatch, pcAuthor, pcQueue, pcStart, pcDelete, pcSupersede, pcReject, pcPlausible, pcMerge) pcId = rowid pcTable :: Column PatchId

@@ -2,7 +2,9 @@  module Development.Bake.Server.Memory(     ClientInfo(..), Memory(..),-    newMemory, stateFailure+    newMemory, stateFailure,+    notify, notifyAdmins, summary,+    Shower(..), shower,     ) where  import Development.Bake.Server.Store@@ -12,10 +14,17 @@ import Development.Bake.Core.Message import Control.DeepSeq import qualified Data.Set as Set+import Control.Exception.Extra import Data.Tuple.Extra import Data.List.Extra import Data.Maybe+import General.HTML+import Control.Monad+import General.Extra+import Data.Monoid+import Prelude + stateFailure = toState ""  @@ -30,8 +39,15 @@     } deriving (Eq,Show)  data Memory = Memory+    -- READER     {simulated :: Bool         -- ^ Are we running in a simulation (don't spawn separate process)+    ,oven :: Oven State Patch Test+        -- ^ The oven under test+    ,prettys :: Prettys+        -- ^ The pretty functions++    -- STATE     ,admins :: [Author]         -- ^ People responsible for overall administration     ,store :: Store@@ -47,15 +63,77 @@     ,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+newMemory :: Oven State Patch Test -> Prettys -> Store -> (State, Answer) -> IO Memory+newMemory oven prettys 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)+    return $ Memory False oven prettys [] store [] Map.empty [] False (state, ps)  instance NFData Memory where     rnf Memory{..} = ()+++notify :: Memory -> String -> [(Author, HTML)] -> IO (Memory -> Memory)+notify mem subject messages = do+    messages <- return $ concat [(a,b) : map (,b) (admins mem) | (a,b) <- messages]+    res <- try_ $ forM_ (groupSort messages) $ \(author, body) -> do+        let nl = br_ <> str_ "\n" -- important to include lots of lines or Outlook gets upset+        ovenNotify (oven mem) author subject $ renderHTML $ mconcat $ intersperse (nl <> nl) $ nubOrd body+    return $ \mem -> mem{fatal = ["Notification failure: " ++ show e | Left e <- [res]] ++ fatal mem}++notifyAdmins :: Memory -> String -> HTML -> IO (Memory -> Memory)+notifyAdmins mem subject message = notify mem subject $ map (,message) $ admins mem++summary :: String -> HTML+summary x | length x < 10000 = str_ x+          | otherwise = str_ (take 5000 x) <> br_ <> str_ "..." <> br_ <> str_ (takeEnd 5000 x)++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 :: Memory -> Bool -> IO Shower+shower Memory{prettys=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+        {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 []+        ,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 =+            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)]

@@ -66,8 +66,8 @@   -- | Throw out the patches that have been rejected-restrictActive :: Oven State Patch Test -> Memory -> Bool-restrictActive oven Memory{..}+restrictActive :: Memory -> Bool+restrictActive Memory{..}     -- I can reject someone for failing preparation     | Nothing `Set.member` rejectedTests = True 

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections, ViewPatterns #-}  -- | Define a continuous integration system. module Development.Bake.Server.Start(@@ -27,6 +27,7 @@ import System.Console.CmdArgs.Verbosity import System.FilePath import qualified Data.Map as Map+import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Paths_bake@@ -37,7 +38,7 @@             => 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+    var <- newCVar =<< if fake then initialiseFake oven prettys else initialise oven prettys authors extra      forkSlave $ forever $ do         sleep timeout@@ -45,13 +46,8 @@         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+            bad <- clientChange s s2+            return $ bad s2      putStrLn $ "Started server on port " ++ show port     server port $ \i@Input{..} -> do@@ -62,14 +58,33 @@             res <-                 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+                    fmap OutputHTML $ web 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 inputURL == ["alive"] then do+                    Memory{store} <- readCVar var+                    let xs = sortOn (paQueued . storePatch store) $ Set.toList $ storeAlive store+                    return $ OutputString $ unlines $ map fromPatch xs++                else if inputURL == ["active"] then do+                    Memory{active} <- readCVar var+                    return $ OutputString $ unlines $ map fromPatch $ snd active++                else if inputURL == ["state"] then do+                    Memory{active} <- readCVar var+                    return $ OutputString $ unlines [fromState $ fst active]++                else if inputURL == ["skip"] then do+                    Memory{store} <- readCVar var+                    return $ OutputString $ unlines $ map fromTest $ Map.keys $ storeSkip store+                 else if ["api"] `isPrefixOf` inputURL then                     case messageFromInput i{inputURL = drop 1 inputURL} of                         Left e -> return $ OutputError e@@ -81,19 +96,14 @@                                         res <- patchExtra (fst $ active s) $ Just p                                         storeExtraAdd (store s) (Right p) res                                     _ -> return ()-                                (s2,q) <- recordIO $ (["brain"],) <$> prod oven (prune s) v+                                (s2,q) <- recordIO $ (["brain"],) <$> prod (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)+                                bad <- clientChange s s2+                                when (fatal s == [] && fatal s2 /= []) $ do+                                    void $ notifyAdmins s2 "Fatal error" $ pre_ $ summary $ head $ fatal s2+                                return (bad s2,q)                             return $ case res of                                 Just (Left e) -> OutputError e                                 Just (Right q) -> questionToOutput $ Just q@@ -103,34 +113,39 @@             evaluate $ force res  -initialiseFake :: IO Memory-initialiseFake = do+clientChange :: Memory -> Memory -> IO (Memory -> Memory)+clientChange s1 s2 = do+    let before = Map.keysSet $ clients s1+    let after  = Map.keysSet $ clients s2+    let f msg xs = sequence [notifyAdmins s2 (msg ++ ": " ++ fromClient x) $ str_ "" | x <- Set.toList xs]+    a <- f "Client added" $ after `Set.difference` before+    b <- f "Client timed out" $ before `Set.difference` after+    return $ foldr (.) id $ a ++ b+++initialiseFake :: Oven State Patch Test -> Prettys -> IO Memory+initialiseFake oven prettys = do     store <- newStore False "bake-store"-    mem <- newMemory store (toState "", Answer (TL.pack "Initial state created by view mode") Nothing [] False)+    mem <- newMemory oven prettys store (stateFailure, 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+initialise :: Oven State Patch Test -> Prettys -> [Author] -> Worker -> IO Memory+initialise oven prettys 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)--    email <- if isNothing res then return $ Right () else-        try_ $ ovenNotify oven admins "Server starting up"+    mem <- newMemory oven prettys store (state0, answer)+    mem <- return mem{admins = admins ,fatal = ["Failed to initialise, " ++ TL.unpack (aStdout answer) | isNothing res]} -    return $ mem-        {admins = admins-        ,fatal = ["Failed to initialise, " ++ TL.unpack (aStdout answer) | isNothing res] ++-                 ["Failed to notify, " ++ show e | Left e <- [email]]-        }+    bad <- if isJust res then notifyAdmins mem "Starting" $ str_ "Server starting" else+        notifyAdmins mem "Fatal error during initialise" $+            str_ "Failed to initialise" <> br_ <> pre_ (summary $ TL.unpack $ aStdout answer)+    return $ bad mem   -- | Get information about a patch

@@ -88,12 +88,12 @@                        ,ms statMax, unwords $ map ms statHistory]              | (name,Stat{..}) <- Map.toAscList recorded] -        header_ "slowest" "Slowest tests (max 25)"+        header_ "slowest" "Slowest tests (top 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)"+        header_ "rejects" "Most common rejection tests (top 10)"         table ["Test","Rejections"] [[showTest t, str_ $ show x] | (t, x) <- rejections]          header_ "plausible" "Speed to plausible"

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TupleSections, TypeOperators, ViewPatterns #-}+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TupleSections, TypeOperators, ViewPatterns, Arrows, CPP #-}  -- Stuff on disk on the server module Development.Bake.Server.Store(@@ -41,6 +41,12 @@ import Control.Exception import Prelude +#if OPALEYE+import qualified Opaleye as O+import Control.Arrow+#endif++ --------------------------------------------------------------------- -- DATA TYPES @@ -208,11 +214,32 @@  storeItemsDate :: Store -> (UTCTime, Maybe UTCTime) -> [Either State Patch] storeItemsDate Store{..} (start, end) = unsafePerformIO $ do++#if OPALEYE+    let q :: O.Query (O.Column Patch, O.Column O.PGBool, O.Column O.PGTimestamptz) = proc () -> do+            PCTable{..} <- O.queryTable pcTable__ -< ()+            returnA -< (pcPatch_, O.pgBool True, pcQueue_)+    O.runQuery conn q :: IO [(Patch, Bool, UTCTime)]+#endif+     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"+              "FROM patch WHERE mx > ?" +++                    (if isJust end then " AND queue < ?"+                     else " OR (delete_ IS NULL AND supersede IS NULL AND reject IS NULL AND merge IS NULL)") +++              " ORDER BY queue ASC"     patches :: [PP] <- sqlUnsafe conn str $ start : maybeToList end +#if OPALEYE+    let q :: O.Query (O.Column State, O.Column O.PGTimestamptz) = O.orderBy (O.asc snd) $ proc () -> do+            SATable{..} <- O.queryTable saTable__ -< ()+            O.restrict -< saState_ O../= O.unsafeCoerce (O.pgString "")+            O.restrict -< saCreate_ O..> O.pgUTCTime start+            O.restrict -< maybe (O.pgBool True) (\x -> saCreate_ O..< O.pgUTCTime x) end+            returnA -< (saState_, saCreate_)+    O.runQuery conn q :: IO [(State, UTCTime)]+#endif+     states <- sqlSelect conn (saState, saCreate) $ [orderAsc saCreate, saState %/= toState "", saCreate %> start] ++ [saCreate %< end | Just end <- [end]]     return $ reverse $ merge states patches     where@@ -328,7 +355,7 @@                         forM_ aTests $ \t -> sqlInsert conn tsTable (pt, Just t)                     else                         when (Set.fromList (mapMaybe fromOnly res) /= Set.fromList aTests) $-                            error "Test disagreement"+                            putStrLn $ "Warning: Test disagreement at " ++ show pt ++ ", maybe a changed generator?"                 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

@@ -7,6 +7,7 @@  import Development.Bake.Server.Brain import Development.Bake.Server.Store+import Development.Bake.Server.Memory import Development.Bake.Server.Stats import Development.Bake.Core.Type import Development.Bake.Core.Message@@ -29,9 +30,9 @@ import Prelude  -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+web :: String -> [(String, String)] -> Memory -> IO String+web admn (args admn -> a@Args{..}) mem@Memory{..} = recordIO $ fmap (first (\x -> ["web",x])) $ do+    shower@Shower{..} <- shower mem argsAdmin     stats <- if argsStats then stats prettys mem showTest else return mempty     now <- getCurrentTime     return $ (valueHTML &&& renderHTML . void) $ template $ do@@ -68,7 +69,7 @@                 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")+                    when argsAdmin $ str_ " " <> admin (DelSkip test) (str_ "Remove")             header_ "clients" "Clients"             table "No clients available" ["Name","Running"]                 (map (rowClient shower mem) $ Nothing : map Just (Map.toList clients))@@ -76,15 +77,12 @@             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"+                        else admin Requeue $ str_ "Reqeue"                     li_ $ if paused-                        then admin (Unpause "admin") $ str_ "Unpause"-                        else admin (Pause "admin") $ str_ "Pause"+                        then admin Unpause $ str_ "Unpause"+                        else admin Pause $ str_ "Pause"             return "home"           else if argsStats then do@@ -92,7 +90,16 @@             return "stats"           else if argsRaw then do-            str_ $ show mem+            let indent = (++) "  "+            pre_ $ str_ $ unlines $+                ["simulated = " ++ show simulated+                ,"store = " ++ show store+                ,"admins = " ++ show admins+                ,"fatal = " ++ show fatal+                ,"paused = " ++ show paused+                ,"active =", indent $ fromState $ fst active] ++ map (indent . fromPatch) (snd active) +++                ["clients = "] ++ [indent $ fromClient a ++ " = " ++ show b{ciTests=mempty} | (a,b) <- Map.toList clients] +++                ["running ="] ++ map (indent . show) running             return "raw"           else if isJust argsServer then do@@ -186,53 +193,6 @@     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-        {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 []-        ,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 =-            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)]-- template :: HTML_ a -> HTML_ a template inner = do     raw_ "<!HTML>"@@ -341,6 +301,7 @@         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 paDelete= "fail"              | Right (_, PatchInfo{..}) <- info, isJust paSupersede || isNothing paStart = "dull"              | Right (_, PatchInfo{..}) <- info, isJust paMerge || isJust paPlausible  = "pass"              | Left (s,_) <- info, fst active /= s = "pass"@@ -355,6 +316,7 @@                 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{paDelete=Just t}) <- info = span__ [class_ "bad"] (str_ "Deleted") <> str_ " at " <> showTime t             | Right (_, PatchInfo{paSupersede=Just t}) <- info = str_ "Superseded at " <> showTime t             | Right (_, PatchInfo{paMerge=Just t}) <- info = do                 span__ [class_ "good"] $ str_ "Merged"@@ -370,9 +332,9 @@         special             | argsAdmin, Right (p, pi) <- info =                 if paAlive pi then-                    do br_; admin (DelPatch "admin" p) $ str_ "Delete"+                    do br_; admin (DelPatch p) $ str_ "Delete"                 else if isNothing $ paMerge pi then-                    do br_; admin (AddPatch "admin" $ toPatch $ '\'' : fromPatch p) $ str_ "Retry"+                    do br_; admin (AddPatch (paAuthor pi) $ toPatch $ '\'' : fromPatch p) $ str_ "Retry"                 else                     mempty             | otherwise = mempty

@@ -19,14 +19,17 @@   -- | Oven creation for modules using git with the step strategy.+--   Note that any files not in .gitignore will be removed at each step, so make sure your incremental build-products+--   are properly ignored. 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+    -> [String] -- ^ .gitignore patterns where build products live     -> Oven () () test -- ^ Normal oven     -> Oven SHA1 SHA1 test-ovenStepGit act repo branch path o = o+ovenStepGit act repo branch path keep o = o     {ovenInit = gitInit repo branch     ,ovenUpdate = stepUpdate     ,ovenPrepare = \s ps -> do stepPrepare s ps; ovenPrepare o () $ map (const ()) ps@@ -52,6 +55,8 @@                     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"+                    time_ $ cmd (Cwd git) "git reset" -- to unwedge a previous merge conflict+                    time_ $ cmd (Cwd git) "git clean -dfx" ["-e" ++ x | x <- keep] -- to remove files left over from a previous merge conflict                  else do                     time_ $ cmd (Cwd git) "git clone" [repo] "."                     time_ $ cmd (Cwd git) "git config user.email" ["https://github.com/ndmitchell/bake"]@@ -62,7 +67,7 @@             time_ $ cmd (Cwd git) "git checkout --force -B" [branch] [fromSHA1 s]          gitApplyPatch git p = do-            time_ $ cmd (Cwd git) "git merge" [fromSHA1 p]+            time_ $ cmd (Cwd git) (WithStdout True) "git merge" [fromSHA1 p]          stepExtra s p = do             root <- root@@ -90,9 +95,10 @@             unlessM (doesFileExist $ dir </> "result.tar") $ do                 git <- gitEnsure                 withFileLock (root </> ".bake-lock") $ do-                    gitSetState git s                     forM_ (inits ps) $ \ps -> do-                        when (ps /= []) $ do+                        if null ps then+                            gitSetState git s+                        else                             gitApplyPatch git $ last ps                         dir <- createDir (root </> "../bake-step-point") $ map fromSHA1 $ s : ps                         unlessM (doesFileExist $ dir </> "result.tar") $ do

@@ -70,13 +70,6 @@ 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@@ -85,6 +78,13 @@             ,ovenPrepare = undefined             ,ovenPatchExtra = undefined             }+    mem <- newMemory oven (Prettys fromState fromPatch fromTest) 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]     s@S{..} <- flip loopM s $ \s -> do         -- print $ clients $ memory s         -- print $ storePoint (store $ memory s) (active $ memory s)@@ -100,8 +100,8 @@                 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+                (if b then Pause else Unpause, s)+        (mem, q) <- prod (memory s) msg         q <- return $ either error id <$> q         -- print q         when (fatal mem /= []) $ error $ "Fatal error, " ++ unlines (fatal mem)@@ -122,7 +122,7 @@     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+        (_, q) <- prod Memory{..} $ Pinged $ Ping c (fromClient c) [] maxBound maxBound         when (isJust q) $ error "Brains should have returned sleep"      forM_ patch $ \(p, pass, fail) ->

@@ -13,6 +13,8 @@ import Data.Maybe import System.Time.Extra +useStep = True+ data Platform = Linux | Windows deriving (Show,Read) data Action = Compile | Run Int deriving (Show,Read) @@ -29,7 +31,9 @@     repo <- fromMaybe (error err) `fmap` lookupEnv "REPO"     bake $         ovenPretty $-        ovenStepGit compile repo "master" Nothing $+        (if useStep+            then ovenStepGit compile repo "master" Nothing ["dist"]+            else ovenIncremental . ovenGit repo "master" Nothing) $         ovenNotifyStdout $         ovenTest (return allTests) execute         defaultOven{ovenServer=("127.0.0.1",5000)}@@ -40,15 +44,15 @@ compile = do     createDirectoryIfMissing True "dist"     unit $ cmd "ghc --make Main.hs -o dist/Main"+    -- ghc --make only has 1 second timestamp resolution+    -- so sleep for a second to make sure we work with incremental compilation     sleep 1     return ["dist"]  execute :: (Platform,Action) -> TestInfo (Platform,Action)-execute (p,Compile) = require [show p] $ run $ when False $ do-    () <- cmd "ghc --make Main.hs"-    -- 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,Compile) = require [show p] $ run $ unless useStep $ do+    incrementalStart+    compile+    incrementalDone execute (p,Run i) = depend [(p,Compile)] $ require [show p] $ run $     cmd ("dist" </> "Main") (show i)

@@ -30,6 +30,9 @@  data Rope = Branch [Rope] | Leaf String +instance Eq Rope where a == b = renderRope a == renderRope b+instance Ord Rope where compare a b = compare (renderRope a) (renderRope b)+ renderRope :: Rope -> String renderRope x = f x ""     where f (Branch []) k = k@@ -53,7 +56,7 @@         f (ord -> x) = "%" ++ ['0' | x < 16] ++ showHex x ""  -data HTML_ a = HTML_ Rope a+data HTML_ a = HTML_ Rope a deriving (Eq,Ord)  type HTML = HTML_ () 

@@ -16,6 +16,8 @@ import Network.Wai import Control.DeepSeq import Control.Exception+import Control.Monad+import System.IO import Network.HTTP.Types.Status import Network.HTTP hiding (Request) import qualified Data.Text as Text@@ -65,7 +67,7 @@ #ifdef PROFILE server port act = return () #else-server port act = runSettings (setOnException exception $ setPort port defaultSettings) $ \req reply -> do+server port act = runSettings settings $ \req reply -> do     bod <- strictRequestBody req     whenLoud $ print ("receiving",bod,requestHeaders req,port)     let pay = Input@@ -83,10 +85,13 @@         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"+    where+        settings = setOnExceptionResponse exceptionResponseForDebug $+                   setOnException exception $+                   setPort port defaultSettings + 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+exception r e = when (defaultShouldDisplayException e) $+    hPutStrLn stderr $ "Error when processing " ++ maybe "Nothing" (show . rawPathInfo) r ++ "\n    " ++ show e #endif

@@ -34,31 +34,28 @@     let repo = "file:///" ++ dropWhile (== '/') (replace "\\" "/" dir) ++ "/repo"     b <- doesDirectoryExist dir     when b $ do-        () <- cmd "chmod -R 755 .bake-test"-        () <- cmd "rm -rf .bake-test"+        unit $ cmd "chmod -R 755 .bake-test"+        unit $ cmd "rm -rf .bake-test"         return ()      createDirectoryIfMissing True (dir </> "repo")     withCurrentDirectory (dir </> "repo") $ do-        () <- cmd "git init"-        () <- cmd "git config user.email" ["gwen@example.com"]-        () <- cmd "git config user.name" ["Ms Gwen"]+        unit $ cmd "git init"+        unit $ cmd "git config user.email" ["gwen@example.com"]+        unit $ 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"]-        () <- cmd "git checkout -b none" -- so I can git push to master-        return ()+        unit $ cmd "git add Main.hs"+        unit $ cmd "git commit -m" ["Initial version"]+        unit $ cmd "git checkout -b none" -- so I can git push to master      forM_ ["bob","tony"] $ \s -> do         createDirectoryIfMissing True (dir </> "repo-" ++ s)         withCurrentDirectory (dir </> "repo-" ++ s) $ do             print "clone"-            () <- cmd "git clone" repo "."-            () <- cmd "git config user.email" [s ++ "@example.com"]-            () <- cmd "git config user.name" ["Mr " ++ toUpper (head s) : map toLower (tail s)]-            print "checkout"-            () <- cmd "git checkout -b" s-            return ()+            unit $ cmd "git clone" repo "."+            unit $ cmd "git config user.email" [s ++ "@example.com"]+            unit $ cmd "git config user.name" ["Mr " ++ toUpper (head s) : map toLower (tail s)]+            unit $ cmd "git checkout -b" s      aborting <- newIORef False     let createProcessAlive p = do@@ -86,13 +83,11 @@     flip finally (do writeIORef aborting True; mapM_ terminateProcess $ p0 : ps) $ do         let edit name act = withCurrentDirectory (dir </> "repo-" ++ name) $ do                 act-                () <- cmd "git add *"-                () <- cmd "git commit -m" ["Update from " ++ name]-                () <- cmd "git push origin" name+                unit $ cmd "git add *"+                unit $ cmd "git commit -m" ["Update from " ++ name]+                unit $ cmd "git push origin" name                 Stdout sha1 <- cmd "git rev-parse HEAD"-                print "adding patch"-                () <- cmd exe "addpatch" ("--name=" ++ name ++ "=" ++ sha1) ("--author=" ++ name)-                return ()+                unit $ cmd exe "addpatch" ("--name=" ++ name ++ "=" ++ sha1) ("--author=" ++ name)          putStrLn "% MAKING EDIT AS BOB"         edit "bob" $@@ -112,7 +107,7 @@                 when (src /= expect) $ do                     error $ "Expected to have updated Main, but got:\n" ++ src -        () <- cmd exe "pause" "--author=bake"+        unit $ cmd exe "pause"         putStrLn "% MAKING A GOOD EDIT AS BOB"         edit "bob" $ do             unit $ cmd "git fetch origin"@@ -126,7 +121,13 @@             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"+        putStrLn "% MAKING A MERGE CONFLICT AS BOB"+        edit "bob" $+            writeFile "Main.hs" "-- Bob waz ere\nmodule Main(main) where\nimport System.Environment\n-- Entry point\nmain :: IO ()\nmain = do [[_]] <- getArgs; print 1\n\n"+        putStrLn "% MAKING ANOTHER GOOD EDIT AS TONY"+        edit "tony" $ do+            writeFile "Main.hs" "-- Tony waz ere 1981\nmodule Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n"+        unit $ cmd exe "unpause"          retry 15 $ do             sleep 10@@ -134,7 +135,7 @@                 unit $ cmd "git clone" repo "."                 unit $ cmd "git checkout master"                 src <- readFile "Main.hs"-                let expect = "-- Tony waz ere\nmodule Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n\n"+                let expect = "-- Tony waz ere 1981\nmodule Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n\n"                 when (src /= expect) $ do                     error $ "Expected to have updated Main, but got:\n" ++ src