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