bake 0.1 → 0.2
raw patch · 23 files changed
+1573/−1294 lines, 23 filesdep +hashabledep ~extrabinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: hashable
Dependency ranges changed: extra
API changes (from Hackage documentation)
+ Development.Bake: incrementalDone :: IO ()
+ Development.Bake: ovenIncremental :: Oven state patch test -> Oven state patch test
+ Development.Bake: ovenPretty :: Show patch => String -> Oven state patch test -> Oven state (Pretty patch) test
- Development.Bake: Oven :: (Maybe (state, [patch]) -> IO state) -> (state -> [patch] -> IO [test]) -> (test -> TestInfo test) -> ([Author] -> String -> IO ()) -> (patch -> IO (String, String)) -> (Host, Port) -> Stringy state -> Stringy patch -> Stringy test -> Oven state patch test
+ Development.Bake: Oven :: (Maybe (state, [patch]) -> IO state) -> (state -> [patch] -> IO [test]) -> (test -> TestInfo test) -> ([Author] -> String -> IO ()) -> (state -> Maybe patch -> IO (String, String)) -> (Host, Port) -> Stringy state -> Stringy patch -> Stringy test -> Oven state patch test
- Development.Bake: ovenGit :: String -> String -> Oven () () test -> Oven SHA1 SHA1 test
+ Development.Bake: ovenGit :: String -> String -> Maybe FilePath -> Oven () () test -> Oven SHA1 SHA1 test
- Development.Bake: ovenPatchExtra :: Oven state patch test -> patch -> IO (String, String)
+ Development.Bake: ovenPatchExtra :: Oven state patch test -> state -> Maybe patch -> IO (String, String)
- Development.Bake: startServer :: Port -> Author -> String -> Double -> Oven state patch test -> IO ()
+ Development.Bake: startServer :: Port -> FilePath -> Author -> String -> Double -> Oven state patch test -> IO ()
Files
- CHANGES.txt +8/−0
- LICENSE +3/−0
- bake.cabal +12/−2
- html/favicon.ico binary
- src/Development/Bake.hs +30/−27
- src/Development/Bake/Args.hs +101/−86
- src/Development/Bake/Build.hs +68/−0
- src/Development/Bake/Client.hs +58/−71
- src/Development/Bake/Email.hs +13/−13
- src/Development/Bake/Format.hs +39/−39
- src/Development/Bake/Git.hs +107/−65
- src/Development/Bake/Message.hs +129/−129
- src/Development/Bake/Pretty.hs +29/−0
- src/Development/Bake/Send.hs +25/−25
- src/Development/Bake/Server/Brains.hs +107/−146
- src/Development/Bake/Server/Start.hs +139/−121
- src/Development/Bake/Server/Type.hs +34/−34
- src/Development/Bake/Server/Web.hs +170/−125
- src/Development/Bake/Type.hs +188/−164
- src/Development/Bake/Util.hs +51/−0
- src/Development/Bake/Web.hs +77/−77
- src/Example.hs +54/−43
- src/Test.hs +131/−127
CHANGES.txt view
@@ -1,5 +1,13 @@ Changelog for Bake +0.2+ Require extra-0.3+ Lots of work on lots of things+ #1, add incremental building+ #1, mirror the Git repo+ Require a name for the client+ Sort out which directory things are run from+ Change to a separate --host and --port flag 0.1 Works to some level 0.0
LICENSE view
@@ -28,3 +28,6 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++The icon in resources/ is the "Microwave" icon by "FatCow"+http://www.softicons.com/toolbar-icons/fatcow-hosting-extra-icons-2-by-fatcow/microwave-icon
bake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: bake-version: 0.1+version: 0.2 license: BSD3 license-file: LICENSE category: Development@@ -24,6 +24,9 @@ extra-source-files: CHANGES.txt +data-files:+ html/favicon.ico+ source-repository head type: git location: https://github.com/ndmitchell/bake.git@@ -40,11 +43,13 @@ text, time, random,+ hashable, HTTP, http-types, deepseq,+ filepath, aeson,- extra >= 0.2,+ extra >= 0.3, wai >= 3.0.1, warp >= 3.0 @@ -53,18 +58,22 @@ other-modules: Development.Bake.Args+ Development.Bake.Build Development.Bake.Client Development.Bake.Email Development.Bake.Format Development.Bake.Git Development.Bake.Message+ Development.Bake.Pretty Development.Bake.Send Development.Bake.Server.Brains Development.Bake.Server.Start Development.Bake.Server.Type Development.Bake.Server.Web Development.Bake.Type+ Development.Bake.Util Development.Bake.Web+ Paths_bake -- don't use 'cabal test' since that loses the child stdout executable bake-test@@ -82,6 +91,7 @@ text, time, random,+ hashable, HTTP, http-types, deepseq,
+ html/favicon.ico view
binary file changed (absent → 5430 bytes)
src/Development/Bake.hs view
@@ -1,27 +1,30 @@- --- | A continuous integration system. For an example of how to get started --- see <https://github.com/ndmitchell/bake#readme>. -module Development.Bake( - -- * Execute - bake, - -- * Central types - Oven(..), defaultOven, - Stringy(..), readShowStringy, - -- ** Oven modifiers - ovenTest, ovenGit, ovenNotifyStdout, ovenNotifyEmail, - -- ** TestInfo members - TestInfo, run, threads, threadsAll, require, suitable, - -- * Operations - startServer, startClient, - module Development.Bake.Send, - -- * Utility types - Host, Port, Author - ) where - -import Development.Bake.Type -import Development.Bake.Server.Start -import Development.Bake.Client -import Development.Bake.Args -import Development.Bake.Send -import Development.Bake.Git -import Development.Bake.Email ++-- | A continuous integration system. For an example of how to get started+-- see <https://github.com/ndmitchell/bake#readme>.+module Development.Bake(+ -- * Execute+ bake,+ -- * Central types+ Oven(..), defaultOven,+ Stringy(..), readShowStringy,+ -- ** Oven modifiers+ ovenTest, ovenGit, ovenNotifyStdout, ovenNotifyEmail, ovenPretty,+ ovenIncremental, incrementalDone,+ -- ** TestInfo members+ TestInfo, run, threads, threadsAll, require, suitable,+ -- * Operations+ startServer, startClient,+ module Development.Bake.Send,+ -- * Utility types+ Host, Port, Author+ ) where++import Development.Bake.Type+import Development.Bake.Server.Start+import Development.Bake.Client+import Development.Bake.Args+import Development.Bake.Send+import Development.Bake.Git+import Development.Bake.Build+import Development.Bake.Pretty+import Development.Bake.Email
src/Development/Bake/Args.hs view
@@ -1,86 +1,101 @@-{-# 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 Data.Maybe -import Control.Monad.Extra - - -type HostPort = String - -data Bake - = Server {port :: Maybe Port, author :: Author, name :: String, timeout :: Double} - | Client {server :: HostPort, author :: Author, name :: String, threads :: Int, ping :: Double} - | AddPatch {server :: HostPort, author :: Author, name :: String} - | DelPatch {server :: HostPort, author :: Author, name :: String} - | DelPatches {server :: HostPort, author :: Author} - | Pause {server :: HostPort, author :: Author} - | Unpause {server :: HostPort, author :: Author} - | Run {output :: FilePath, test :: Maybe String, state :: String, patch :: [String]} - deriving (Typeable,Data) - - -bakeMode = cmdArgsMode $ modes - [Server{port = Nothing, author = "unknown", name = "", timeout = 5*60} - ,Client{server = "", threads = 1, ping = 60} - ,AddPatch{} - ,DelPatch{} - ,DelPatches{} - ,Pause{} - ,Unpause{} - ,Run "" Nothing "" [] - ] &= 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{..} -> startServer (fromMaybe (snd ovenServer) port) author name timeout oven - Client{..} -> startClient (hp server) author name threads ping oven - AddPatch{..} -> sendAddPatch (hp server) author =<< check "patch" ovenStringyPatch name - DelPatch{..} -> sendDelPatch (hp server) author =<< check "patch" ovenStringyPatch name - DelPatches{..} -> sendDelAllPatches (hp server) author - Pause{..} -> sendPause (hp server) author - Unpause{..} -> sendUnpause (hp server) author - Run{..} -> 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 - where - hp "" = ovenServer - hp s = (h, read $ drop 1 p) - where (h,p) = break (== ':') s - - -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 - - +{-# 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 !!)
+ src/Development/Bake/Build.hs view
@@ -0,0 +1,68 @@+{-# 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") ""
src/Development/Bake/Client.hs view
@@ -1,71 +1,58 @@-{-# LANGUAGE RecordWildCards, ViewPatterns, ScopedTypeVariables #-} - -module Development.Bake.Client( - startClient - ) where - -import Development.Bake.Type -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 Data.IORef -import Data.Maybe -import System.Environment -import System.Directory - - --- given server, name, threads -startClient :: (Host,Port) -> Author -> String -> Int -> Double -> Oven state patch test -> IO () -startClient hp author (Client -> client) maxThreads ping (concrete -> oven) = do - 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 <- candidateDir qCandidate - (time, (exit, Stdout sout, Stderr serr)) <- duration $ - cmd (Cwd dir) exe "run" - "--output=../tests.txt" - ["--test=" ++ fromTest t | Just t <- [qTest]] - ("--state=" ++ fromState (fst qCandidate)) - ["--patch=" ++ fromPatch p | p <- snd qCandidate] - tests <- if isJust qTest || exit /= ExitSuccess then return ([],[]) else do - src :: ([String],[String]) <- fmap read $ readFile "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 - - --- | Find a directory for this patch -candidateDir :: (State, [Patch]) -> IO FilePath -candidateDir (s, ps) = do - let file = "candidates.txt" - let c_ = (fromState s, map fromPatch ps) - b <- doesFileExist file - src :: [((String, [String]), FilePath)] <- if b then fmap read $ readFile file else return [] - case lookup c_ src of - Just p -> return p - Nothing -> do - let res = show $ length src - createDirectoryIfMissing True res - writeFile "candidates.txt" $ show $ (c_,res):src - return res +{-# 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
src/Development/Bake/Email.hs view
@@ -1,13 +1,13 @@- -module Development.Bake.Email(ovenNotifyEmail) where - -import Development.Bake.Type - - --- | 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} - -sendEmail :: (Host,Port) -> [Author] -> String -> IO () -sendEmail = error "Bake.sendEmail not yet implemented" ++module Development.Bake.Email(ovenNotifyEmail) where++import Development.Bake.Type+++-- | 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}++sendEmail :: (Host,Port) -> [Author] -> String -> IO ()+sendEmail = error "Bake.sendEmail not yet implemented"
src/Development/Bake/Format.hs view
@@ -1,39 +1,39 @@- -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 ++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
src/Development/Bake/Git.hs view
@@ -1,65 +1,107 @@- -module Development.Bake.Git(SHA1, ovenGit) where - -import Development.Bake.Type -import Development.Shake.Command -import Control.Monad.Extra -import Data.List.Extra -import Development.Bake.Format - - -newtype SHA1 = SHA1 {fromSHA1 :: String} deriving (Show,Eq) - -sha1 :: String -> SHA1 -sha1 x | length x /= 40 = error $ "SHA1 for Git must be 40 characters long, got " ++ show x - | 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 = \(SHA1 x) -> x - ,stringyFrom = sha1 - ,stringyPretty = \(SHA1 x) -> take 7 x - } - - --- | Modify an 'Oven' to work with the Git version control system. --- Requires the name of the repo (e.g. @https:\/\/github.com\/ndmitchell\/bake.git@) --- and the name of a branch (e.g. @master@). -ovenGit :: String -> String -> Oven () () test -> Oven SHA1 SHA1 test -ovenGit repo branch o = o - {ovenUpdateState = gitUpdateState - ,ovenPrepare = \s ps -> do gitCheckout s ps; ovenPrepare o () $ map (const ()) ps - ,ovenPatchExtra = gitPatchExtra - ,ovenStringyState = stringySHA1 - ,ovenStringyPatch = stringySHA1 - } - where - gitUpdateState Nothing = do - Stdout hash <- cmd "git ls-remote" repo ("refs/heads/" ++ branch) - case words hash of - [] -> error "Couldn't find branch" - x:xs -> return $ sha1 $ strip x - - gitUpdateState (Just (s, ps)) = do - gitCheckout s ps - Stdout x <- cmd "git rev-parse HEAD" - unit $ cmd "git checkout -b temp" - unit $ cmd "git checkout -B master temp" - unit $ cmd "git push origin master --force" - return $ sha1 $ strip x - - gitCheckout s ps = do - unit $ cmd "git clone" repo "." - unit $ cmd "git config user.email" ["https://github.com/ndmitchell/bake"] - unit $ cmd "git config user.name" ["Bake Continuous Integration"] - unit $ cmd "git checkout" (fromSHA1 s) - forM_ ps $ \p -> - unit $ cmd "git merge" (fromSHA1 p) - - gitPatchExtra p = do - unit $ cmd "git clone" repo "." - Stdout full <- cmd "git diff" ("origin/" ++ branch ++ ".." ++ fromSHA1 p) - Stdout numstat <- cmd "git diff --numstat" ("origin/" ++ branch ++ ".." ++ fromSHA1 p) - let xs = [x | [_,_,x] <- map words $ lines numstat] - return (unwordsLimit 3 xs, tag_ "pre" full) +{-# LANGUAGE ViewPatterns #-}++module Development.Bake.Git(+ SHA1, ovenGit,+ ) where++import Development.Bake.Type+import Development.Bake.Util+import Development.Shake.Command+import Control.Monad.Extra+import Data.List.Extra+import Development.Bake.Format+import System.Directory.Extra+import System.FilePath+import Data.Maybe+++newtype SHA1 = SHA1 {fromSHA1 :: String} deriving (Show,Eq)++sha1 :: String -> SHA1+sha1 x | length x /= 40 = error $ "SHA1 for Git must be 40 characters long, got " ++ show x+ | 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+ }+++-- | Modify an 'Oven' to work with the Git version control system.+-- Requires the name of the repo (e.g. @https:\/\/github.com\/ndmitchell\/bake.git@)+-- and the name of a branch (e.g. @master@). You can optionally give a path fragment+-- 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+ ,ovenPrepare = \s ps -> do gitCheckout s ps; ovenPrepare o () $ map (const ()) ps+ ,ovenPatchExtra = gitPatchExtra+ ,ovenStringyState = stringySHA1+ ,ovenStringyPatch = stringySHA1+ }+ 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"]++ -- initialise the mirror, or make it up to date+ gitInitMirror = traced "gitInitMirror" $ do+ mirror <- createDir "../bake-git" [repo]+ -- 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"+ else do+ unit $ 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+ gitCheckout s ps+ Stdout x <- cmd (Cwd path) "git rev-parse" [branch]+ unit $ 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]+ 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"+ forM_ ps $ \p ->+ unit $ 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)
src/Development/Bake/Message.hs view
@@ -1,129 +1,129 @@-{-# 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 +{-# 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
+ src/Development/Bake/Pretty.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE RecordWildCards, ViewPatterns #-}++module Development.Bake.Pretty(ovenPretty, Pretty(..)) where++import Development.Bake.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+ }++ovenPretty :: Show patch => String -> Oven state patch test -> Oven state (Pretty patch) test+ovenPretty sep oven@Oven{..} = oven+ {ovenUpdateState = ovenUpdateState . fmap (second $ map unpretty)+ ,ovenPrepare = \s ps -> ovenPrepare s (map unpretty ps)+ ,ovenPatchExtra = \s p -> ovenPatchExtra s (fmap unpretty p)+ ,ovenStringyPatch = prettyStringy sep ovenStringyPatch+ }+ where+ unpretty :: Pretty a -> a+ unpretty (Pretty _ x) = x
src/Development/Bake/Send.hs view
@@ -1,25 +1,25 @@-{-# 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 +{-# 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
src/Development/Bake/Server/Brains.hs view
@@ -1,146 +1,107 @@-{-# 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 -> [Test]) -> Server -> Ping -> Neuron -brains _ Server{active=(_, [])} _ = Sleep -- no outstanding tasks - -brains depends 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 1 pClient) t - dependsMay Nothing = [] - dependsMay (Just t) = Nothing : map Just (depends 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 - - -- can this candidate start running this test - suitableTest c t - | pNowThreads <= 0 = False -- need 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 $ depends 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] - -{- -brains depends Server{..} Ping{..} - | null failingTests && setupStep == Nothing = (Just $ Question active Nothing 1 pClient, Nothing, False) - | null failingTests && setupStep == Just Nothing = (Nothing, Nothing, False) - | null failingTests && null testsTodo = (Nothing, Nothing, True) - | null failingTests = (fmap (\t -> Question active (Just t) 1 pClient) $ listToMaybe $ filter suitableTest testsTodo, Nothing, False) - | otherwise = case dropWhile ((== Just False) . snd) $ reverse failingOn of - [] -> (Nothing, Just $ head patches, False) - (_,Just True):rest -> (Nothing, Just $ patches !! (length rest + 1), False) - (ps,Nothing):_ -> error $ "brains, need to attempt with " ++ show ps - where - -- history for those who match the active candidate - historyActive = filter ((==) active . qCandidate . snd3) history - - -- tests that have failed for the current candidate - failingTests = [qTest | (_,Question{..},Just Answer{aSuccess=False}) <- historyActive] - - -- Nothing = never run, Just Nothing = in progress, Just (Just t) = completed - setupStep = listToMaybe [fmap aTests a - | (_,Question{qTest=Nothing,..},a) <- historyActive, qClient == pClient] - - testsDone = [t | (_,Question{qTest=Just t},Just Answer{aSuccess=True}) <- historyActive] - testsNeed = let (a,b) = fromJust (fromJust setupStep) in a ++ b - testsTodo = testsDone \\ testsNeed - testsDoneMe = [t | (_,Question{qTest=Just t,..},Just Answer{aSuccess=True}) <- historyActive, qClient == pClient] - - -- a test is suitable to run if: - -- 1) there are enough threads outstanding - -- 2) this client is capable of running the test - -- 3) it's dependencies have all been run by this client - suitableTest t = - pNowThreads >= 1 && - t `elem` fst (fromJust $ fromJust setupStep) && - all (`elem` testsDoneMe) (depends t) - - Candidate state patches = active - - -- for each patch in the candidate state, does the first failing test fail or not (or unknown) - failingOn = [ (p,) $ listToMaybe [aSuccess | (_,Question{..},Just Answer{..}) <- history, qCandidate == Candidate state p, qTest == head failingTests] - | p <- tail $ inits patches] --} - - -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 [] = [] +{-# 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 [] = []
src/Development/Bake/Server/Start.hs view
@@ -1,121 +1,139 @@-{-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns #-} - --- | Define a continuous integration system. -module Development.Bake.Server.Start( - startServer - ) where - -import Development.Bake.Type -import Development.Bake.Web -import Development.Bake.Message -import Development.Bake.Server.Type -import Development.Bake.Server.Web -import Development.Bake.Server.Brains -import Control.Concurrent -import Control.DeepSeq -import Control.Arrow -import Control.Exception.Extra -import Data.List.Extra -import Data.Maybe -import Data.Time.Clock -import Control.Monad.Extra -import Data.Tuple.Extra -import System.Directory.Extra -import System.IO.Extra -import System.Console.CmdArgs.Verbosity - - -startServer :: Port -> Author -> String -> Double -> Oven state patch test -> IO () -startServer port author name timeout (concrete -> oven) = do - curdirLock <- newMVar () - s <- withTempDirCurrent curdirLock $ ovenUpdateState oven Nothing - putStrLn $ "Initial state of: " ++ show s - var <- newMVar $ (defaultServer s){authors = [(Nothing,author)]} - server port $ \i@Input{..} -> do - whenLoud $ print i - handle_ (fmap OutputError . showException) $ do - res <- - if null inputURL || ["ui"] `isPrefixOf` inputURL then - web oven i{inputURL = drop 1 inputURL} =<< readMVar var - else if ["api"] `isPrefixOf` inputURL then - (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 - case v of - AddPatch _ p | p `notElem` map fst (extra s) -> do - forkIO $ do - res <- try_ $ withTempDirCurrent curdirLock $ - evaluate . force =<< ovenPatchExtra oven p - res <- either (fmap dupe . showException) return res - modifyMVar_ var $ \s -> return s{extra = (p,res) : extra s} - return (s{extra=(p,("","")):extra s}, q) - _ -> return (s,q) - ) - 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 <- getCurrentTime - 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 - whenLoud $ when (not $ aSuccess a) $ print ("Test failed",qCandidate q == active server,q,a) - 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 - now <- getCurrentTime - server <- return $ prune (addUTCTime (fromRational $ toRational $ negate timeout) now) $ server - {pings = (now,ping) : filter ((/= pClient ping) . pClient . snd) (pings server)} - let depends = testRequire . ovenTestInfo oven - flip loopM server $ \server -> - case brains depends 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 - s <- withTempDirCurrent curdirLock $ 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) - - --- 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 | (t,Ping{..}) <- pings s, t >= cutoff] - -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 () - - -withTempDirCurrent :: MVar () -> IO a -> IO a -withTempDirCurrent curdirLock act = withMVar curdirLock $ const $ withTempDir $ \t -> withCurrentDirectory t act +{-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns #-}++-- | Define a continuous integration system.+module Development.Bake.Server.Start(+ 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.Server.Web+import Development.Bake.Server.Brains+import Development.Shake.Command+import Control.Concurrent+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 System.Console.CmdArgs.Verbosity+import System.FilePath+++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)]}+ server port $ \i@Input{..} -> do+ whenLoud $ print i+ handle_ (fmap OutputError . showException) $ do+ res <-+ if null inputURL then+ web oven inputArgs =<< readMVar var+ else if ["html"] `isPrefixOf` inputURL then+ return $ OutputFile $ datadir </> "html" </> last inputURL+ else if ["api"] `isPrefixOf` inputURL then+ (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+ 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)+ )+ 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)+++-- 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]++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 ()+++withServerDir :: MVar () -> IO a -> IO a+withServerDir curdirLock act = withMVar curdirLock $ const $ withCurrentDirectory "bake-server" act
src/Development/Bake/Server/Type.hs view
@@ -1,34 +1,34 @@- --- | 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 Data.Time.Clock - - -defaultServer :: State -> Server -defaultServer s = Server [] [] [] (s,[]) Nothing [] [] [] - -data Server = Server - {history :: [(UTCTime, 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 :: [(UTCTime, State, (State, [Patch]))] - -- ^ Updates that have been made - ,pings :: [(UTCTime, Ping)] - -- ^ Latest time of a ping sent by each client - ,active :: (State, [Patch]) - -- ^ The candidate we are currently aiming to prove - ,paused :: Maybe [(UTCTime, Patch)] - -- ^ 'Just' if we are paused, and the number of people queued up - ,submitted :: [(UTCTime, 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 ++-- | 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
src/Development/Bake/Server/Web.hs view
@@ -1,125 +1,170 @@-{-# LANGUAGE RecordWildCards #-} - --- | 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.Format -import Data.List.Extra -import Data.Time.Clock -import Data.Tuple.Extra - - -web :: Oven State Patch Test -> Input -> Server -> IO Output -web Oven{..} Input{..} server = return $ OutputHTML $ unlines $ - prefix ++ - (case () of - _ | Just c <- lookup "client" inputArgs -> - ["<h2>Runs on " ++ c ++ "</h2>"] ++ - runs shower (nostdout server) ((==) (Client c) . qClient) - | Just t <- lookup "test" inputArgs, Just p <- lookup "patch" inputArgs -> - let tt = if t == "" then Nothing else Just $ Test t in - runs shower server (\Question{..} -> Patch p `elem` snd qCandidate && qTest == tt) - | Just p <- lookup "patch" inputArgs -> - runs shower (nostdout server) (elem (Patch p) . snd . qCandidate) ++ - ["<h2>Patch information</h2>"] ++ - [e | (pp,(_,e)) <- extra server, Patch p == pp] - | otherwise -> - ["<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) - ) ++ - suffix - where - patches = submitted server - clients = sort $ nub $ map (pClient . snd) $ pings server - shower = Shower - {showPatch = \p -> tag "a" ["href=?patch=" ++ fromPatch p, "class=patch"] (stringyPretty ovenStringyPatch p) - ,showTest = \p t -> tag "a" ["href=?patch=" ++ fromPatch p ++ "&" ++ "test=" ++ maybe "" fromTest t] $ - maybe "Preparing" (stringyPretty ovenStringyTest) t - } - -data Shower = Shower - {showPatch :: Patch -> String - ,showTest :: Patch -> Maybe Test -> String - } - - -prefix = - ["<!HTML>" - ,"<html>" - ,"<head>" - ,"<title>Bake Continuous Integration</title>" - ,"<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 {font-family: Consolas, monospace;}" - ,".info {font-size: 75%; color: #888;}" - ,"a.info {color: #4183c4;}" -- tie breaker - ,".good {font-weight: bold; color: #480}" - ,".bad {font-weight: bold; color: #800}" - ,"#footer {margin-top: 40px; font-size: 80%;}" - ,"</style>" - ,"</head>" - ,"<body>" - ,"<h1>Bake Continuous Integration</h1>" - ] - -suffix = - ["<p id=footer><a href='https://github.com/ndmitchell/bake'>Copyright Neil Mitchell 2014</a></p>" - ,"</body>" - ,"</html>"] - -nostdout :: Server -> Server -nostdout s = s{history = [(t,q,fmap (\a -> a{aStdout=""}) a) | (t,q,a) <- history s]} - -runs :: Shower -> Server -> (Question -> Bool) -> [String] -runs Shower{..} Server{..} pred = table "No runs" ["Time","Question","Answer"] - [[show t, show q, show a] | (t,q,a) <- history, pred q] - -patch :: Shower -> Server -> (UTCTime, 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 $ filter fst done) ++ " of " ++ (if todo == 0 then "?" else show todo) ++ ")<br />" ++ - tag "span" ["class=info"] - (if any (not . fst) done then "Retrying " ++ commasLimit 3 [showTest p t | (False,t) <- done] - else if not $ null running then "Running " ++ commasLimit 3 (map (showTest p) 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 [showTest p t | (False,t) <- done, (True,t) `notElem` done]) - ] - where - todo = length $ nub - [ t - | (_,Question{..},Just Answer{..}) <- history - , p `elem` snd qCandidate - , t <- uncurry (++) aTests] - done = nub - [ (aSuccess,qTest) - | (_,Question{..},Just Answer{..}) <- history - , p `elem` snd qCandidate] - running = nub - [ qTest - | (_,Question{..},Nothing) <- history - , p `elem` snd qCandidate] - -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 (uncurry showTest) active] - where active = [(last $ Patch "" : snd qCandidate, qTest) | (_,Question{..},Nothing) <- history, qClient == c] +{-# LANGUAGE RecordWildCards, ViewPatterns #-}++-- | 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 Data.List.Extra+import Data.Tuple.Extra+import Data.Version+import Paths_bake+++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+++data Shower = Shower+ {showPatch :: Patch -> String+ ,showTest :: Maybe Test -> String+ ,showTestPatch :: Patch -> Maybe Test -> String+ ,showTestQuestion :: Question -> String+ ,showState :: State -> String+ ,showTime :: Timestamp -> String+ }++showThreads i = show i ++ " thread" ++ ['s' | i /= 1]+showDuration (ceiling -> i) = show i ++ "s"++shower :: Oven State Patch Test -> IO Shower+shower Oven{..} = do+ showTime <- showRelativeTimestamp+ 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)+ ,showTest = f Nothing Nothing []+ ,showTestPatch = \p -> f Nothing Nothing [p]+ ,showTestQuestion = \Question{..} -> f (Just qClient) (Just $ fst qCandidate) (snd qCandidate) qTest+ ,showTime = showTime+ }+ where+ 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]++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>"]++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>"]+ _ -> [])+ 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)+++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)])+ ]+ 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]++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]
src/Development/Bake/Type.hs view
@@ -1,164 +1,188 @@-{-# 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, - Author - ) where - -import Development.Bake.Format -import Control.Monad.Extra -import Data.Monoid -import Data.Aeson -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. -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 :: 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. -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) -newtype Patch = Patch {fromPatch :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON) -newtype Test = Test {fromTest :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON) -newtype Client = Client {fromClient :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON) - -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 = ovenPatchExtra . unpatch - ,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) +{-# 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
+ src/Development/Bake/Util.hs view
@@ -0,0 +1,51 @@+{-# 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+
src/Development/Bake/Web.hs view
@@ -1,77 +1,77 @@-{-# 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 +{-# 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
src/Example.hs view
@@ -1,43 +1,54 @@- -module Example(main, platforms) where - -import Development.Bake -import Development.Shake.Command -import System.Environment -import System.FilePath -import Data.List.Extra -import Control.Arrow -import Data.Maybe - - -data Platform = Linux | Windows deriving (Show,Read) -data Action = Compile | Run Int deriving (Show,Read) - -platforms = [Linux,Windows] - -main :: IO () -main = do - let err = "You need to set an environment variable named $REPO for the Git repo" - repo <- fromMaybe (error err) `fmap` lookupEnv "REPO" - bake $ - ovenGit repo "master" $ - ovenNotifyStdout $ - ovenTest testStringy (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]] - -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) - --- 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") ++module Example(main, platforms) where++import Development.Bake+import Development.Shake.Command+import System.Environment+import System.FilePath+import Data.List.Extra+import System.Directory+import Control.Arrow+import Control.Monad+import Data.Maybe+++data Platform = Linux | Windows deriving (Show,Read)+data Action = Compile | Run Int deriving (Show,Read)++platforms = [Linux,Windows]++main :: IO ()+main = do+ 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 $+ ovenNotifyStdout $+ ovenTest testStringy (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]]++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"+ () <- 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")
src/Test.hs view
@@ -1,127 +1,131 @@- -module Test(main) where - -import Development.Shake.Command -import System.Directory.Extra -import System.IO.Extra -import System.Time.Extra -import System.Environment -import System.FilePath -import Control.Monad.Extra -import Control.Exception -import Control.Concurrent -import System.Process -import Data.IORef -import Data.Char -import qualified Example - - -main :: IO () -main = do - args <- getArgs - if args /= [] then Example.main else do - dir <- getCurrentDirectory - test $ dir ++ "/.bake-test" - -test :: FilePath -> IO () -test dir = do - b <- doesDirectoryExist dir - when b $ do - () <- cmd "chmod -R 755 .bake-test" - () <- cmd "rm -rf .bake-test" - return () - - 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"] - 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 () - - 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 () - - aborting <- newIORef False - let createProcessAlive p = do - t <- myThreadId - (_,_,_,pid) <- createProcess p - forkIO $ do - waitForProcess pid - b <- readIORef aborting - when (not b) $ throwTo t $ ErrorCall "Process died" - sleep 2 - return pid - exe <- getExecutablePath - createDirectoryIfMissing True $ dir </> "server" - environment <- fmap (("REPO",dir ++ "/repo"):) $ getEnvironment - p0 <- createProcessAlive (proc exe ["server"]) - {cwd=Just $ dir </> "server", env=Just environment} - ps <- forM Example.platforms $ \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} - 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 - Stdout sha1 <- cmd "git rev-parse HEAD" - print "adding patch" - () <- cmd exe "addpatch" ("--name=" ++ sha1) ("--author=" ++ name) - return () - - putStrLn "% MAKING EDIT AS BOB" - edit "bob" $ - writeFile "Main.hs" "module Main(main) where\n\n-- Entry point\nmain = print 1\n" - sleep 2 - putStrLn "% MAKING EDIT AS TONY" - edit "tony" $ - writeFile "Main.hs" "module Main where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n" - - sleep 10 - withTempDir $ \d -> withCurrentDirectory d $ do - unit $ cmd "git clone" (dir </> "repo") "." - unit $ cmd "git checkout master" - src <- readFile "Main.hs" - let expect = "module Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n" - when (src /= expect) $ do - error $ "Expected to have updated Main, but got:\n" ++ src - - putStrLn "% MAKING A GOOD EDIT AS BOB" - edit "bob" $ do - unit $ cmd "git fetch origin" - unit $ cmd "git merge origin/master" - writeFile "Main.hs" "module Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n\n" - putStrLn "% MAKING A BAD EDIT AS BOB" - edit "bob" $ - writeFile "Main.hs" "module Main(main) where\nimport System.Environment\n-- Entry point\nmain :: IO ()\nmain = do [[_]] <- getArgs; print 1\n\n" - putStrLn "% MAKING A GOOD EDIT AS TONY" - edit "tony" $ do - 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" - - sleep 10 - withTempDir $ \d -> withCurrentDirectory d $ do - unit $ cmd "git clone" (dir </> "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" - when (src /= expect) $ do - error $ "Expected to have updated Main, but got:\n" ++ src - - putStrLn "Completed successfully!" ++module Test(main) where++import Development.Shake.Command+import System.Directory.Extra+import System.IO.Extra+import System.Time.Extra+import System.Environment+import System.FilePath+import Control.Monad.Extra+import Control.Exception.Extra+import Control.Concurrent+import System.Process+import Data.List.Extra+import Data.IORef+import Data.Char+import qualified Example+++main :: IO ()+main = do+ args <- getArgs+ if args /= [] then Example.main else do+ dir <- getCurrentDirectory+ test $ dir ++ "/.bake-test"++test :: FilePath -> IO ()+test dir = do+ let repo = "file://" ++ replace "\\" "/" dir ++ "/repo"+ b <- doesDirectoryExist dir+ when b $ do+ () <- cmd "chmod -R 755 .bake-test"+ () <- cmd "rm -rf .bake-test"+ return ()++ 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"]+ 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 ()++ 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 ()++ aborting <- newIORef False+ let createProcessAlive p = do+ t <- myThreadId+ (_,_,_,pid) <- createProcess p+ forkIO $ do+ waitForProcess pid+ b <- readIORef aborting+ when (not b) $ throwTo t $ ErrorCall "Process died"+ sleep 2+ return pid+ exe <- getExecutablePath+ createDirectoryIfMissing True $ dir </> "server"+ environment <- fmap (("REPO",repo):) $ getEnvironment+ p0 <- createProcessAlive (proc exe ["server","--datadir=../.."])+ {cwd=Just $ dir </> "server", env=Just environment}+ ps <- forM Example.platforms $ \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}+ 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+ Stdout sha1 <- cmd "git rev-parse HEAD"+ print "adding patch"+ () <- cmd exe "addpatch" ("--name=" ++ name ++ "=" ++ sha1) ("--author=" ++ name)+ return ()++ putStrLn "% MAKING EDIT AS BOB"+ edit "bob" $+ writeFile "Main.hs" "module Main(main) where\n\n-- Entry point\nmain = print 1\n"+ sleep 2+ putStrLn "% MAKING EDIT AS TONY"+ edit "tony" $+ writeFile "Main.hs" "module Main where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n"++ retry 5 $ do+ sleep 10+ withTempDir $ \d -> withCurrentDirectory d $ do+ unit $ cmd "git clone" repo "."+ unit $ cmd "git checkout master"+ src <- readFile "Main.hs"+ let expect = "module Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n"+ when (src /= expect) $ do+ error $ "Expected to have updated Main, but got:\n" ++ src++ putStrLn "% MAKING A GOOD EDIT AS BOB"+ edit "bob" $ do+ unit $ cmd "git fetch origin"+ unit $ cmd "git merge origin/master"+ writeFile "Main.hs" "module Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n\n"+ putStrLn "% MAKING A BAD EDIT AS BOB"+ edit "bob" $+ writeFile "Main.hs" "module Main(main) where\nimport System.Environment\n-- Entry point\nmain :: IO ()\nmain = do [[_]] <- getArgs; print 1\n\n"+ putStrLn "% MAKING A GOOD EDIT AS TONY"+ edit "tony" $ do+ 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"++ retry 10 $ do+ sleep 10+ withTempDir $ \d -> withCurrentDirectory d $ do+ 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"+ when (src /= expect) $ do+ error $ "Expected to have updated Main, but got:\n" ++ src++ putStrLn "Completed successfully!"