module Actions where

import Control.Concurrent.STM

import Control.Concurrent.Chan

import Data.IntMap

import qualified Data.IntSet as IntSet

import qualified Data.Sequence as Seq

import System.Log.Logger

import Monad

import Data.Time

import Maybe

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

import CoreTypes

import Utils

data Action =

    AnswerThisClient [String]

    | AnswerAll [String]

    | AnswerAllOthers [String]

    | AnswerThisRoom [String]

    | AnswerOthersInRoom [String]

    | AnswerSameClan [String]

    | AnswerLobby [String]

    | SendServerMessage

    | SendServerVars

    | RoomAddThisClient Int -- roomID

    | RoomRemoveThisClient String

    | RemoveTeam String

    | RemoveRoom

    | UnreadyRoomClients

    | MoveToLobby

    | ProtocolError String

    | Warning String

    | ByeClient String

    | KickClient Int -- clID

    | KickRoomClient Int -- clID

    | BanClient String -- nick

    | RemoveClientTeams Int -- clID

    | ModifyClient (ClientInfo -> ClientInfo)

    | ModifyClient2 Int (ClientInfo -> ClientInfo)

    | ModifyRoom (RoomInfo -> RoomInfo)

    | ModifyServerInfo (ServerInfo -> ServerInfo)

    | AddRoom String String

    | CheckRegistered

    | ClearAccountsCache

    | ProcessAccountInfo AccountInfo

    | Dump

    | AddClient ClientInfo

    | PingAll

    | StatsAction

type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action]

replaceID a (b, c, d, e) = (a, c, d, e)

processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms)

processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do

    writeChan (sendChan $ clients ! clID) msg

    return (clID, serverInfo, clients, rooms)

processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do

    mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients)

    return (clID, serverInfo, clients, rooms)

processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do

    mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $

        Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients)

    return (clID, serverInfo, clients, rooms)

processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do

    mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients

    return (clID, serverInfo, clients, rooms)

    where

        roomClients = IntSet.elems $ playersIDs room

        room = rooms ! rID

        rID = roomID client

        client = clients ! clID

processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do

    mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ Prelude.filter (/= clID) roomClients

    return (clID, serverInfo, clients, rooms)

    where

        roomClients = IntSet.elems $ playersIDs room

        room = rooms ! rID

        rID = roomID client

        client = clients ! clID

processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do

    mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients

    return (clID, serverInfo, clients, rooms)

    where

        roomClients = IntSet.elems $ playersIDs room

        room = rooms ! 0

processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do

    mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec

    return (clID, serverInfo, clients, rooms)

    where

        otherRoomClients = Prelude.map ((!) clients) $ IntSet.elems $ clID `IntSet.delete` (playersIDs room)

        sameClanOrSpec = if teamsInGame client > 0 then sameClanClients else spectators

        spectators = Prelude.filter (\cl -> teamsInGame cl == 0) otherRoomClients

        sameClanClients = Prelude.filter (\cl -> teamsInGame cl > 0 && clientClan cl == thisClan) otherRoomClients

        thisClan = clientClan client

        room = rooms ! rID

        rID = roomID client

        client = clients ! clID

processAction (clID, serverInfo, clients, rooms) SendServerMessage = do

    writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo]

    return (clID, serverInfo, clients, rooms)

    where

        client = clients ! clID

        message si = if clientProto client < latestReleaseVersion si then

            serverMessageForOldVersions si

            else

            serverMessage si

processAction (clID, serverInfo, clients, rooms) SendServerVars = do

    writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)

    return (clID, serverInfo, clients, rooms)

    where

        client = clients ! clID

        vars = [

            "MOTD_NEW", serverMessage serverInfo, 

            "MOTD_OLD", serverMessageForOldVersions serverInfo, 

            "LATEST_PROTO", show $ latestReleaseVersion serverInfo

            ]

processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do

    writeChan (sendChan $ clients ! clID) ["ERROR", msg]

    return (clID, serverInfo, clients, rooms)

processAction (clID, serverInfo, clients, rooms) (Warning msg) = do

    writeChan (sendChan $ clients ! clID) ["WARNING", msg]

    return (clID, serverInfo, clients, rooms)

processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do

    infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg)

    (_, _, newClients, newRooms) <-

            if roomID client /= 0 then

                processAction  (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit"

                else

                    return (clID, serverInfo, clients, rooms)

    mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom

    writeChan (sendChan $ clients ! clID) ["BYE", msg]

    return (

            0,

            serverInfo,

            delete clID newClients,

            adjust (\r -> r{

                    playersIDs = IntSet.delete clID (playersIDs r),

                    playersIn = (playersIn r) - 1,

                    readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r

                    }) (roomID $ newClients ! clID) newRooms

            )

    where

        client = clients ! clID

        clientNick = nick client

        answerInformRoom =

            if roomID client /= 0 then

                if not $ Prelude.null msg then

                    [AnswerThisRoom ["LEFT", clientNick, msg]]

                else

                    [AnswerThisRoom ["LEFT", clientNick]]

            else

                []

        answerOthersQuit =

            if logonPassed client then

                if not $ Prelude.null msg then

                    [AnswerAll ["LOBBY:LEFT", clientNick, msg]]

                else

                    [AnswerAll ["LOBBY:LEFT", clientNick]]

            else

                []

processAction (clID, serverInfo, clients, rooms) (ModifyClient func) =

    return (clID, serverInfo, adjust func clID clients, rooms)

processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) =

    return (clID, serverInfo, adjust func cl2ID clients, rooms)

processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) =

    return (clID, serverInfo, clients, adjust func rID rooms)

    where

        rID = roomID $ clients ! clID

processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) =

    return (clID, func serverInfo, clients, rooms)

processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) =

    processAction (

        clID,

        serverInfo,

        adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,

        adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $

            adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms

        ) joinMsg

    where

        client = clients ! clID

        joinMsg = if rID == 0 then

                AnswerAllOthers ["LOBBY:JOINED", nick client]

            else

                AnswerThisRoom ["JOINED", nick client]

processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do

    (_, _, newClients, newRooms) <-

        if roomID client /= 0 then

            if isMaster client then

                if (gameinprogress room) && (playersIn room > 1) then

                    (changeMaster >>= (\state -> foldM processAction state

                        [AnswerOthersInRoom ["LEFT", nick client, msg],

                        AnswerOthersInRoom ["WARNING", "Admin left the room"],

                        RemoveClientTeams clID]))

                else -- not in game

                    processAction (clID, serverInfo, clients, rooms) RemoveRoom

            else -- not master

                foldM

                    processAction

                        (clID, serverInfo, clients, rooms)

                        [AnswerOthersInRoom ["LEFT", nick client, msg],

                        RemoveClientTeams clID]

        else -- in lobby

            return (clID, serverInfo, clients, rooms)

    return (

        clID,

        serverInfo,

        adjust resetClientFlags clID newClients,

        adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms

        )

    where

        rID = roomID client

        client = clients ! clID

        room = rooms ! rID

        resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined}

        removeClientFromRoom r = r{

                playersIDs = otherPlayersSet,

                playersIn = (playersIn r) - 1,

                readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r

                }

        insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}

        changeMaster = do

            processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]

            return (

                clID,

                serverInfo,

                adjust (\cl -> cl{isMaster = True}) newMasterId clients,

                adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms

                )

        newRoomName = nick newMasterClient

        otherPlayersSet = IntSet.delete clID (playersIDs room)

        newMasterId = IntSet.findMin otherPlayersSet

        newMasterClient = clients ! newMasterId

processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do

    let newServerInfo = serverInfo {nextRoomID = newID}

    let room = newRoom{

            roomUID = newID,

            masterID = clID,

            name = roomName,

            password = roomPassword,

            roomProto = (clientProto client)

            }

    processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName]

    processAction (

        clID,

        newServerInfo,

        adjust (\cl -> cl{isMaster = True}) clID clients,

        insert newID room rooms

        ) $ RoomAddThisClient newID

    where

        newID = (nextRoomID serverInfo) - 1

        client = clients ! clID

processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do

    processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room]

    processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room]

    return (clID,

        serverInfo,

        Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients,

        delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms

        )

    where

        room = rooms ! rID

        rID = roomID client

        client = clients ! clID

processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do

    processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers)

    return (clID,

        serverInfo,

        Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients,

        adjust (\r -> r{readyPlayers = 0}) rID rooms)

    where

        room = rooms ! rID

        rID = roomID client

        client = clients ! clID

        roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs

        roomPlayersIDs = IntSet.elems $ playersIDs room

processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do

    newRooms <- if not $ gameinprogress room then

            do

            processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName]

            return $

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

        else

            do

            processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg]

            return $

                adjust (\r -> r{

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

                leftTeams = teamName : leftTeams r,

                roundMsgs = roundMsgs r Seq.|> rmTeamMsg

                }) rID rooms

    return (clID, serverInfo, clients, newRooms)

    where

        room = rooms ! rID

        rID = roomID client

        client = clients ! clID

        rmTeamMsg = toEngineMsg $ 'F' : teamName

processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do

    writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client)

    return (clID, serverInfo, clients, rooms)

    where

        client = clients ! clID

processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do

    writeChan (dbQueries serverInfo) ClearCache

    return (clID, serverInfo, clients, rooms)

    where

        client = clients ! clID

processAction (clID, serverInfo, clients, rooms) (Dump) = do

    writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]

    return (clID, serverInfo, clients, rooms)

processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) =

    case info of

        HasAccount passwd isAdmin -> do

            infoM "Clients" $ show clID ++ " has account"

            writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]

            return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms)

        Guest -> do

            infoM "Clients" $ show clID ++ " is guest"

            processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby

        Admin -> do

            infoM "Clients" $ show clID ++ " is admin"

            foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]]

processAction (clID, serverInfo, clients, rooms) (MoveToLobby) =

    foldM processAction (clID, serverInfo, clients, rooms) $

        (RoomAddThisClient 0)

        : answerLobbyNicks

        ++ [SendServerMessage]

        -- ++ (answerServerMessage client clients)

    where

        lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients

        answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]

processAction (clID, serverInfo, clients, rooms) (KickClient kickID) =

    liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked")

processAction (clID, serverInfo, clients, rooms) (BanClient banNick) =

    return (clID, serverInfo, clients, rooms)

processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do

    writeChan (sendChan $ clients ! kickID) ["KICKED"]

    liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked")

processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) =

    liftM2 replaceID (return clID) $

        foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions

    where

        client = clients ! teamsClID

        room = rooms ! (roomID client)

        teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room

        removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove

processAction (clID, serverInfo, clients, rooms) (AddClient client) = do

    let updatedClients = insert (clientUID client) client clients

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

    writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]

    let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo

    if isJust $ host client `Prelude.lookup` newLogins then

        processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast"

        else

        return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms)

processAction (clID, serverInfo, clients, rooms) PingAll = do

    (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients

    processAction (clID,

        serverInfo,

        Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients,

        newRooms) $ AnswerAll ["PING"]

    where

        kickTimeouted (clID, serverInfo, clients, rooms) client =

            if pingsQueue client > 0 then

                processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout"

                else

                return (clID, serverInfo, clients, rooms)

processAction (clID, serverInfo, clients, rooms) (StatsAction) = do

    writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)

    return (clID, serverInfo, clients, rooms)