{-# 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 ->
["Runs on " ++ c ++ "
"] ++
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) ++
["Patch information
"] ++
[e | (pp,(_,e)) <- extra server, Patch p == pp]
| otherwise ->
["Patches
"] ++
table "No patches submitted" ["Patch","Status"] (map (patch shower server) patches) ++
["Clients
"] ++
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 =
[""
,""
,""
,"Bake Continuous Integration"
,""
,""
,""
,"Bake Continuous Integration
"
]
suffix =
[""
,""
,""]
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] ++ "
" ++
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) ++ ")
" ++
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" ++ "
" ++
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 "None"
else commas $ map (uncurry showTest) active]
where active = [(last $ Patch "" : snd qCandidate, qTest) | (_,Question{..},Nothing) <- history, qClient == c]