{-# LANGUAGE RecordWildCards, ViewPatterns, TupleSections #-}

-- | Define a continuous integration system.
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;}" -- tie breaker
                ,"a.self, a.self:hover {color: black; text-decoration: none;}"
                ,".good {font-weight: bold; color: darkgreen;}"
                ,".bad {font-weight: bold; color: darkred;}"
                ,".active {background-color: #ffc;}"
                ,".dull {background-color: #e6e6e6;}"
                ,".pass {background-color: #dfc;}"
                ,".fail {background-color: #fcc;}"
                ,".nobr {white-space: nowrap;}"
                ,".red {background-color: #ffdddd;}"
                ,".green {background-color: #ddffdd;}"
                ,"#footer {margin-top: 40px; font-size: 80%;}"
                ,"hr {margin-bottom: 30px;}"
                ,".admin {color: darkorange; font-weight: bold;}"
                ]
        body_ $ do
            inner
            p__ [id_ "footer"] $
                a__ [href_ "https://github.com/ndmitchell/bake"] $
                    str_ $ "Copyright Neil Mitchell 2014-2015, version " ++ showVersion version
    return $ valueHTML inner


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 () -- Idle on a state
    | Just t <- poTodo = p_ $ b_ (str_ "Testing") <>
        str_ (", done " ++ show (Set.size done) ++ " tests out of " ++ show (Set.size t + 1) ++ superset)
    | isRunning = p_ $ b_ (str_ "Preparing") <>
        str_ (", getting ready to test" ++ superset)
    | otherwise = return ()
    where
        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