{-# LANGUAGE OverloadedStrings #-}

module Actions where

import Control.Concurrent

import qualified Data.Set as Set

import qualified Data.Sequence as Seq

import System.Log.Logger

import Control.Monad

import Data.Time

import Data.Maybe

import Control.Monad.Reader

import Control.Monad.State.Strict

import qualified Data.ByteString.Char8 as B

import Control.DeepSeq

import Data.Unique

import Control.Arrow

import Control.Exception

-----------------------------

import CoreTypes

import Utils

import ClientIO

import ServerState

import Consts

import ConfigFile

data Action =

    AnswerClients ![ClientChan] ![B.ByteString]

    | SendServerMessage

    | SendServerVars

    | MoveToRoom RoomIndex

    | MoveToLobby B.ByteString

    | RemoveTeam B.ByteString

    | RemoveRoom

    | UnreadyRoomClients

    | JoinLobby

    | ProtocolError B.ByteString

    | Warning B.ByteString

    | NoticeMessage Notice

    | ByeClient B.ByteString

    | KickClient ClientIndex

    | KickRoomClient ClientIndex

    | BanClient NominalDiffTime B.ByteString ClientIndex

    | ChangeMaster

    | RemoveClientTeams ClientIndex

    | ModifyClient (ClientInfo -> ClientInfo)

    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)

    | ModifyRoom (RoomInfo -> RoomInfo)

    | ModifyServerInfo (ServerInfo -> ServerInfo)

    | AddRoom B.ByteString B.ByteString

    | CheckRegistered

    | ClearAccountsCache

    | ProcessAccountInfo AccountInfo

    | AddClient ClientInfo

    | DeleteClient ClientIndex

    | PingAll

    | StatsAction

    | RestartServer Bool

type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]

instance NFData Action where

    rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()

    rnf a = a `seq` ()

instance NFData B.ByteString

instance NFData (Chan a)

othersChans :: StateT ServerState IO [ClientChan]

othersChans = do

    cl <- client's id

    ri <- clientRoomA

    liftM (map sendChan . filter (/= cl)) $ roomClientsS ri

processAction :: Action -> StateT ServerState IO ()

processAction (AnswerClients chans msg) =

    io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)

processAction SendServerMessage = do

    chan <- client's sendChan

    protonum <- client's clientProto

    si <- liftM serverInfo get

    let message = if protonum < latestReleaseVersion si then

            serverMessageForOldVersions si

            else

            serverMessage si

    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]

processAction SendServerVars = do

    chan <- client's sendChan

    si <- gets serverInfo

    io $ writeChan chan ("SERVER_VARS" : vars si)

    where

        vars si = [

            "MOTD_NEW", serverMessage si,

            "MOTD_OLD", serverMessageForOldVersions si,

            "LATEST_PROTO", B.pack . show $ latestReleaseVersion si

            ]

processAction (ProtocolError msg) = do

    chan <- client's sendChan

    processAction $ AnswerClients [chan] ["ERROR", msg]

processAction (Warning msg) = do

    chan <- client's sendChan

    processAction $ AnswerClients [chan] ["WARNING", msg]

processAction (NoticeMessage n) = do

    chan <- client's sendChan

    processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n]

processAction (ByeClient msg) = do

    (Just ci) <- gets clientIndex

    ri <- clientRoomA

    chan <- client's sendChan

    clNick <- client's nick

    when (ri /= lobbyId) $ do

        processAction $ MoveToLobby ("quit: " `B.append` msg)

        return ()

    clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS

    io $

        infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)

    processAction $ AnswerClients [chan] ["BYE", msg]

    processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]

    s <- get

    put $! s{removedClients = ci `Set.insert` removedClients s}

processAction (DeleteClient ci) = do

    rnc <- gets roomsClients

    io $ removeClient rnc ci

    s <- get

    put $! s{removedClients = ci `Set.delete` removedClients s}

processAction (ModifyClient f) = do

    (Just ci) <- gets clientIndex

    rnc <- gets roomsClients

    io $ modifyClient rnc f ci

    return ()

processAction (ModifyClient2 ci f) = do

    rnc <- gets roomsClients

    io $ modifyClient rnc f ci

    return ()

processAction (ModifyRoom f) = do

    rnc <- gets roomsClients

    ri <- clientRoomA

    io $ modifyRoom rnc f ri

    return ()

processAction (ModifyServerInfo f) = do

    modify (\s -> s{serverInfo = f $ serverInfo s})

    si <- gets serverInfo

    io $ writeServerConfig si

processAction (MoveToRoom ri) = do

    (Just ci) <- gets clientIndex

    rnc <- gets roomsClients

    io $ do

        modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci

        modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri

        moveClientToRoom rnc ri ci

    chans <- liftM (map sendChan) $ roomClientsS ri

    clNick <- client's nick

    processAction $ AnswerClients chans ["JOINED", clNick]

processAction (MoveToLobby msg) = do

    (Just ci) <- gets clientIndex

    ri <- clientRoomA

    rnc <- gets roomsClients

    (gameProgress, playersNum) <- io $ room'sM rnc (gameinprogress &&& playersIn) ri

    ready <- client's isReady

    master <- client's isMaster

--    client <- client's id

    clNick <- client's nick

    chans <- othersChans

    if master then

        if gameProgress && playersNum > 1 then

            mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci]

            else

            processAction RemoveRoom

        else

        mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]

    io $ do

            modifyRoom rnc (\r -> r{

                    playersIn = playersIn r - 1,

                    readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r

                    }) ri

            moveClientToLobby rnc ci

processAction ChangeMaster = do

    ri <- clientRoomA

    rnc <- gets roomsClients

    newMasterId <- liftM head . io $ roomClientsIndicesM rnc ri

    newMaster <- io $ client'sM rnc id newMasterId

    let newRoomName = nick newMaster

    mapM_ processAction [

        ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}),

        ModifyClient2 newMasterId (\c -> c{isMaster = True}),

        AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]

        ]

processAction (AddRoom roomName roomPassword) = do

    Just clId <- gets clientIndex

    rnc <- gets roomsClients

    proto <- io $ client'sM rnc clientProto clId

    let rm = newRoom{

            masterID = clId,

            name = roomName,

            password = roomPassword,

            roomProto = proto

            }

    rId <- io $ addRoom rnc rm

    processAction $ MoveToRoom rId

    chans <- liftM (map sendChan) $! roomClientsS lobbyId

    mapM_ processAction [

        AnswerClients chans ["ROOM", "ADD", roomName]

        , ModifyClient (\cl -> cl{isMaster = True})

        ]

processAction RemoveRoom = do

    Just clId <- gets clientIndex

    rnc <- gets roomsClients

    ri <- io $ clientRoomM rnc clId

    roomName <- io $ room'sM rnc name ri

    others <- othersChans

    lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId

    mapM_ processAction [

            AnswerClients lobbyChans ["ROOM", "DEL", roomName],

            AnswerClients others ["ROOMABANDONED", roomName]

        ]

    io $ removeRoom rnc ri

processAction (UnreadyRoomClients) = do

    rnc <- gets roomsClients

    ri <- clientRoomA

    roomPlayers <- roomClientsS ri

    roomClIDs <- io $ roomClientsIndicesM rnc ri

    pr <- client's clientProto

    processAction $ AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr (map nick roomPlayers)

    io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs

    processAction $ ModifyRoom (\r -> r{readyPlayers = 0})

    where

        notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks

processAction (RemoveTeam teamName) = do

    rnc <- gets roomsClients

    ri <- clientRoomA

    inGame <- io $ room'sM rnc gameinprogress ri

    chans <- othersChans

    if inGame then

            mapM_ processAction [

                AnswerClients chans ["REMOVE_TEAM", teamName],

                ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r})

                ]

        else

            mapM_ processAction [

                AnswerClients chans ["EM", rmTeamMsg],

                ModifyRoom (\r -> r{

                    teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,

                    leftTeams = teamName : leftTeams r,

                    roundMsgs = roundMsgs r Seq.|> rmTeamMsg

                    })

                ]

    where

        rmTeamMsg = toEngineMsg $ B.singleton 'F' `B.append` teamName

processAction (RemoveClientTeams clId) = do

    rnc <- gets roomsClients

    removeTeamActions <- io $ do

        clNick <- client'sM rnc nick clId

        rId <- clientRoomM rnc clId

        roomTeams <- room'sM rnc teams rId

        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams

    mapM_ processAction removeTeamActions

processAction CheckRegistered = do

    (Just ci) <- gets clientIndex

    n <- client's nick

    h <- client's host

    p <- client's clientProto

    uid <- client's clUID

    haveSameNick <- liftM (not . null . tail . filter (\c -> nick c == n)) allClientsS

    if haveSameNick then

        if p < 38 then

            mapM_ processAction [ByeClient "Nickname is already in use", removeNick]

            else

            mapM_ processAction [NoticeMessage NickAlreadyInUse, removeNick]

        else

        do

        db <- gets (dbQueries . serverInfo)

        io $ writeChan db $ CheckAccount ci (hashUnique uid) n h

        return ()

   where

       removeNick = ModifyClient (\c -> c{nick = ""})

processAction ClearAccountsCache = do

    dbq <- gets (dbQueries . serverInfo)

    io $ writeChan dbq ClearCache

    return ()

processAction (ProcessAccountInfo info) =

    case info of

        HasAccount passwd isAdmin -> do

            chan <- client's sendChan

            mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]

        Guest ->

            processAction JoinLobby

        Admin -> do

            mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]

            chan <- client's sendChan

            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]

processAction JoinLobby = do

    chan <- client's sendChan

    clientNick <- client's nick

    (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (nick &&& sendChan) . Prelude.filter logonPassed) $! allClientsS

    mapM_ processAction $

        AnswerClients clientsChans ["LOBBY:JOINED", clientNick]

        : AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)

        : [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]

processAction (KickClient kickId) = do

    modify (\s -> s{clientIndex = Just kickId})

    processAction $ ByeClient "Kicked"

processAction (BanClient seconds reason banId) = do

    modify (\s -> s{clientIndex = Just banId})

    clHost <- client's host

    currentTime <- io getCurrentTime

    let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` reason ` B.append` ")"

    mapM_ processAction [

        ModifyServerInfo (\s -> s{lastLogins = (clHost, (addUTCTime seconds currentTime, msg)) : lastLogins s})

        , KickClient banId

        ]

processAction (KickRoomClient kickId) = do

    modify (\s -> s{clientIndex = Just kickId})

    ch <- client's sendChan

    mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "kicked"]

processAction (AddClient cl) = do

    rnc <- gets roomsClients

    si <- gets serverInfo

    newClId <- io $ do

        ci <- addClient rnc cl

        t <- forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) ci

        _ <- forkIO $ clientSendLoop (clientSocket cl) t (coreChan si) (sendChan cl) ci

        infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))

        return ci

    modify (\s -> s{clientIndex = Just newClId})

    processAction $ AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion]

    let newLogins = takeWhile (\(_ , (time, _)) -> connectTime cl `diffUTCTime` time <= 0) $ lastLogins si

    let info = host cl `Prelude.lookup` newLogins

    if isJust info then

        mapM_ processAction [ModifyServerInfo (\s -> s{lastLogins = newLogins}), ByeClient (snd .  fromJust $ info)]

        else

        processAction $ ModifyServerInfo (\s -> s{lastLogins = (host cl, (addUTCTime 10 $ connectTime cl, "Reconnected too fast")) : newLogins})

processAction PingAll = do

    rnc <- gets roomsClients

    io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)

    cis <- io $ allClientsM rnc

    chans <- io $ mapM (client'sM rnc sendChan) cis

    io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis

    processAction $ AnswerClients chans ["PING"]

    where

        kickTimeouted rnc ci = do

            pq <- io $ client'sM rnc pingsQueue ci

            when (pq > 0) $

                withStateT (\as -> as{clientIndex = Just ci}) $

                    processAction (ByeClient "Ping timeout")

processAction StatsAction = do

    rnc <- gets roomsClients

    si <- gets serverInfo

    (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st

    io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)

    where

          st irnc = (length $ allRooms irnc, length $ allClients irnc)

processAction (RestartServer force) = do

    if force then do

        throw RestartException

        else

        processAction $ ModifyServerInfo (\s -> s{restartPending=True})