import Control.Concurrent.STM

import Data.IntMap

import Monad

import Maybe

    AnswerThisClient [String]

    | AnswerAll [String]

    | AnswerAllOthers [String]

    | AnswerThisRoom [String]

    | AnswerOthersInRoom [String]

    | AnswerSameClan [String]

    | AnswerLobby [String]

    | RoomAddThisClient Int -- roomID

    | RoomRemoveThisClient String

    | RemoveTeam String

    | MoveToLobby

    | ProtocolError String

    | Warning String

    | ByeClient String

    | KickClient Int -- clID

    | KickRoomClient Int -- clID

    | BanClient String -- nick

    | RemoveClientTeams Int -- clID

    | ModifyClient2 Int (ClientInfo -> ClientInfo)

    | AddRoom String String

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

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

    return (clID, serverInfo, clients, rooms)

            "MOTD_NEW", serverMessage serverInfo, 

            "MOTD_OLD", serverMessageForOldVersions 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

            )

                []

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

        if roomID client /= 0 then

                    processAction (clID, serverInfo, clients, rooms) RemoveRoom

                        (clID, serverInfo, clients, rooms)

        else -- in lobby

            return (clID, serverInfo, clients, rooms)

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

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

    let newServerInfo = serverInfo {nextRoomID = newID}

            roomUID = newID,

            masterID = clID,

            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]

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

            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)

        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)

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

    return (clID, serverInfo, clients, rooms)

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

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

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

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

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

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

            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)

        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

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

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

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

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"]

        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)