{-# LANGUAGE RankNTypes, TupleSections, GADTs, RecordWildCards #-}

module Development.Bake.Server.Memory(
    ClientInfo(..), Memory(..),
    newMemory, stateFailure,
    notify, notifyAdmins, summary,
    Shower(..), shower,
    ) where

import Development.Bake.Server.Store
import qualified Data.Map as Map
import Development.Bake.Core.Type
import Data.Time
import Development.Bake.Core.Message
import Control.DeepSeq
import qualified Data.Set as Set
import Control.Exception.Extra
import Data.Tuple.Extra
import Data.List.Extra
import Data.Maybe
import General.HTML
import Control.Monad
import General.Extra
import Data.Monoid
import Prelude


stateFailure = toState ""


---------------------------------------------------------------------
-- THE DATA TYPE

data ClientInfo = ClientInfo
    {ciPingTime :: UTCTime
    ,ciPing :: Ping
    ,ciAlive :: Bool
    ,ciTests :: Map.Map (Point, Maybe Test) Bool -- if a single failure, set to False
    } deriving (Eq,Show)

data Memory = Memory
    -- READER
    {simulated :: Bool
        -- ^ Are we running in a simulation (don't spawn separate process)
    ,oven :: Oven State Patch Test
        -- ^ The oven under test
    ,prettys :: Prettys
        -- ^ The pretty functions

    -- STATE
    ,admins :: [Author]
        -- ^ People responsible for overall administration
    ,store :: Store
        -- ^ All the information on disk
    ,fatal :: [String]
        -- ^ A list of fatal error messages that have been raised by the server
    ,clients :: Map.Map Client ClientInfo
        -- ^ Latest time of a ping sent by each client
    ,running :: [(UTCTime, Question)]
        -- ^ Questions you have sent to clients and are waiting for.
    ,paused :: Bool
        -- ^ Pretend the queued is empty
    ,active :: Point
        -- ^ The target we are working at (some may already be rejected).
        --   Note that when restarting, we throw away the rejected ones.
    }

newMemory :: Oven State Patch Test -> Prettys -> Store -> (State, Answer) -> IO Memory
newMemory oven prettys store (state, answer) = do
    store <- storeUpdate store [IUState state answer Nothing]
    let ps = map fst $ sortOn (paQueued . snd) $
             filter (isJust . paStart . snd) $
             map (id &&& storePatch store) $ Set.toList $ storeAlive store
    return $ Memory False oven prettys [] store [] Map.empty [] False (state, ps)

instance NFData Memory where
    rnf Memory{..} = ()


notify :: Memory -> String -> [(Author, HTML)] -> IO (Memory -> Memory)
notify mem subject messages = do
    messages <- return $ concat [(a,b) : map (,b) (admins mem) | (a,b) <- messages]
    res <- try_ $ forM_ (groupSort messages) $ \(author, body) -> do
        let nl = br_ <> str_ "\n" -- important to include lots of lines or Outlook gets upset
        ovenNotify (oven mem) author subject $ renderHTML $ mconcat $ intersperse (nl <> nl) $ nubOrd body
    return $ \mem -> mem{fatal = ["Notification failure: " ++ show e | Left e <- [res]] ++ fatal mem}

notifyAdmins :: Memory -> String -> HTML -> IO (Memory -> Memory)
notifyAdmins mem subject message = notify mem subject $ map (,message) $ admins mem

summary :: String -> HTML
summary x | null $ drop 10000 x {- space efficient version of: length x < 10000 -} = str_ x
          | otherwise = str_ (take 5000 x) <> br_ <> str_ "..." <> br_ <> str_ (takeEnd 5000 x)

data Shower = Shower
    {showLink :: String -> HTML -> HTML
    ,showPatch :: Patch -> HTML
    ,showExtra :: Either State Patch -> HTML
    ,showTest :: Maybe Test -> HTML
    ,showTestAt :: (State, [Patch]) -> Maybe Test -> HTML
    ,showQuestion :: Question -> HTML
    ,showClient :: Client -> HTML
    ,showState :: State -> HTML
    ,showCandidate :: (State, [Patch]) -> HTML
    ,showTime :: UTCTime -> HTML
    ,showThreads :: Int -> HTML
    }

shower :: Memory -> Bool -> IO Shower
shower Memory{prettys=Prettys{..},..} argsAdmin = do
    showRel <- showRelativeTime
    let shwState s | s == toState "" = span__ [class_ "bad" ] $ str_ $ "invalid state"
        shwState s = shwLink ("state=" ++ fromState s) $ str_ $ prettyState s
    let shwPatch p = shwLink ("patch=" ++ fromPatch p) $ str_ $ prettyPatch p
    return $ Shower
        {showLink = shwLink
        ,showPatch = shwPatch
        ,showState = shwState
        ,showCandidate = \(s,ps) -> do
            shwState s
            when (not $ null ps) $ str_ " plus " <> commas_ (map shwPatch ps)
        ,showExtra = \e -> raw_ $ maybe "" fst $ storeExtra store e
        ,showClient = \c -> shwLink ("client=" ++ url_ (fromClient c)) $ str_ $ fromClient c
        ,showTest = f Nothing Nothing []
        ,showTestAt = \(s,ps) -> f Nothing (Just s) ps
        ,showQuestion = \Question{..} -> f (Just qClient) (Just $ fst qCandidate) (snd qCandidate) qTest
        ,showTime = \x -> span__ [class_ "nobr"] $ str_ $ showUTCTime "%H:%M" x ++ " UTC (" ++ showRel x ++ ")"
        ,showThreads = \i -> str_ $ show i ++ " thread" ++ ['s' | i /= 1]
        }
    where
        shwLink url = a__ [href_ $ (if argsAdmin then "?admin=&" else "?") ++ url]

        f c s ps t =
            shwLink (intercalate "&" parts) $ str_ $
            maybe "Preparing" prettyTest t
            where parts = ["client=" ++ url_ (fromClient c) | Just c <- [c]] ++
                          ["state=" ++ url_ (fromState s) | Just s <- [s]] ++
                          ["patch=" ++ url_ (fromPatch p) | p <- ps] ++
                          ["test=" ++ url_ (maybe "" fromTest t)]