{-# LANGUAGE OverloadedStrings #-}
module Actions where

import Control.Concurrent
import Control.Concurrent.Chan
import qualified Data.IntSet as IntSet
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 CoreTypes
import Utils
import ClientIO
import ServerState

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
    | ByeClient B.ByteString
    | KickClient ClientIndex
    | KickRoomClient ClientIndex
    | BanClient B.ByteString -- nick
    | RemoveClientTeams ClientIndex
    | ModifyClient (ClientInfo -> ClientInfo)
    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
    | ModifyRoom (RoomInfo -> RoomInfo)
    | ModifyServerInfo (ServerInfo -> ServerInfo)
    | AddRoom B.ByteString B.ByteString
    | CheckRegistered
    | ClearAccountsCache
    | ProcessAccountInfo AccountInfo
    | Dump
    | AddClient ClientInfo
    | DeleteClient ClientIndex
    | PingAll
    | StatsAction

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


processAction :: Action -> StateT ServerState IO ()


processAction (AnswerClients chans msg) = do
    liftIO $ map (flip seq ()) chans `seq` map (flip seq ()) msg `seq` mapM_ (flip writeChan msg) 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 (clID, serverInfo, rnc) SendServerVars = do
    writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)
    return (clID, serverInfo, rnc)
    where
        client = clients ! clID
        vars = [
            "MOTD_NEW", serverMessage serverInfo,
            "MOTD_OLD", serverMessageForOldVersions serverInfo,
            "LATEST_PROTO", show $ latestReleaseVersion serverInfo
            ]


-}

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 (ByeClient msg) = do
    (Just ci) <- gets clientIndex
    rnc <- gets roomsClients
    ri <- clientRoomA

    chan <- client's sendChan
    ready <- client's isReady

    when (ri /= lobbyId) $ do
        processAction $ MoveToLobby ("quit: " `B.append` msg)
        liftIO $ modifyRoom rnc (\r -> r{
                        --playersIDs = IntSet.delete ci (playersIDs r)
                        playersIn = (playersIn r) - 1,
                        readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
                        }) ri
        return ()

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

        --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom

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

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

processAction (DeleteClient ci) = do
    rnc <- gets roomsClients
    liftIO $ removeClient rnc ci

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

{-
    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 (ModifyClient f) = do
    (Just ci) <- gets clientIndex
    rnc <- gets roomsClients
    liftIO $ modifyClient rnc f ci
    return ()

processAction (ModifyClient2 ci f) = do
    rnc <- gets roomsClients
    liftIO $ modifyClient rnc f ci
    return ()


processAction (ModifyRoom f) = do
    rnc <- gets roomsClients
    ri <- clientRoomA
    liftIO $ modifyRoom rnc f ri
    return ()

{-

processAction (clID, serverInfo, rnc) (ModifyServerInfo func) =
    return (clID, func serverInfo, rnc)

-}

processAction (MoveToRoom ri) = do
    (Just ci) <- gets clientIndex
    rnc <- gets roomsClients
    liftIO $ do
        modifyClient rnc (\cl -> cl{teamsInGame = 0}) ci
        modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri

    liftIO $ 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

    liftIO $ moveClientToLobby rnc ci

{-
    (_, _, newClients, newRooms) <-
            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, rnc) RemoveRoom
            else -- not master
                foldM
                    processAction
                        (clID, serverInfo, rnc)
                        [AnswerOthersInRoom ["LEFT", nick client, msg],
                        RemoveClientTeams clID]


    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, rnc) $ 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 (AddRoom roomName roomPassword) = do
    Just clId <- gets clientIndex
    rnc <- gets roomsClients
    proto <- liftIO $ client'sM rnc clientProto clId

    let room = newRoom{
            masterID = clId,
            name = roomName,
            password = roomPassword,
            roomProto = proto
            }

    rId <- liftIO $ addRoom rnc room

    processAction $ MoveToRoom rId

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

    mapM_ processAction [
        AnswerClients chans ["ROOM", "ADD", roomName]
        , ModifyClient (\cl -> cl{isMaster = True})
        ]

{-
processAction (clID, serverInfo, rnc) (RemoveRoom) = do
    processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "DEL", name room]
    processAction (clID, serverInfo, rnc) $ 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 (UnreadyRoomClients) = do
    rnc <- gets roomsClients
    ri <- clientRoomA
    roomPlayers <- roomClientsS ri
    roomClIDs <- liftIO $ roomClientsIndicesM rnc ri
    processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers)
    liftIO $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
    processAction $ ModifyRoom (\r -> r{readyPlayers = 0})


processAction (RemoveTeam teamName) = do
    rnc <- gets roomsClients
    cl <- client's id
    ri <- clientRoomA
    inGame <- liftIO $ room'sM rnc gameinprogress ri
    chans <- liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
    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 CheckRegistered = do
    (Just ci) <- gets clientIndex
    n <- client's nick
    h <- client's host
    db <- gets (dbQueries . serverInfo)
    liftIO $ writeChan db $ CheckAccount ci n h
    return ()

{-
processAction (clID, serverInfo, rnc) (ClearAccountsCache) = do
    writeChan (dbQueries serverInfo) ClearCache
    return (clID, serverInfo, rnc)
    where
        client = clients ! clID


processAction (clID, serverInfo, rnc) (Dump) = do
    writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
    return (clID, serverInfo, rnc)
-}

processAction (ProcessAccountInfo info) =
    case info of
        HasAccount passwd isAdmin -> do
            chan <- client's sendChan
            processAction $ AnswerClients [chan] ["ASKPASSWORD"]
        Guest -> do
            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 (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) $! allClientsS
    mapM_ processAction $
        (AnswerClients clientsChans ["LOBBY:JOINED", clientNick])
        : [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
        ++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]

{-
processAction (clID, serverInfo, rnc) (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, rnc) (KickClient kickID) =
    liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked")


processAction (clID, serverInfo, rnc) (BanClient banNick) =
    return (clID, serverInfo, rnc)


processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do
    writeChan (sendChan $ clients ! kickID) ["KICKED"]
    liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked")


processAction (clID, serverInfo, rnc) (RemoveClientTeams teamsClID) =
    liftM2 replaceID (return clID) $
        foldM processAction (teamsClID, serverInfo, rnc) 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 (AddClient client) = do
    rnc <- gets roomsClients
    si <- gets serverInfo
    liftIO $ do
        ci <- addClient rnc client
        forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci
        forkIO $ clientSendLoop (clientSocket client) (sendChan client) ci

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

    processAction $ AnswerClients [sendChan client] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
{-        let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo

        if False && (isJust $ host client `Prelude.lookup` newLogins) then
            processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast"
            else
            return (ci, serverInfo)
-}



processAction PingAll = do
    rnc <- gets roomsClients
    liftIO (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
    cis <- liftIO $ allClientsM rnc
    chans <- liftIO $ mapM (client'sM rnc sendChan) cis
    liftIO $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
    processAction $ AnswerClients chans ["PING"]
    where
        kickTimeouted rnc ci = do
            pq <- liftIO $ 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) <- liftIO $ withRoomsAndClients rnc stats
    liftIO $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
    where
          stats irnc = (length $ allRooms irnc, length $ allClients irnc)