{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Actions where

import Control.Concurrent

import qualified Data.Set as Set

import qualified Data.Map as Map

import qualified Data.List as L

import qualified Control.Exception as Exception

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 System.Process

import Network.Socket

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

#if defined(OFFICIAL_SERVER)

import OfficialServer.GameReplayStore

#endif

import CoreTypes

import Utils

import ClientIO

import ServerState

import Consts

import ConfigFile

import EngineInteraction

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

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", showB $ 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", showB . fromEnum $ n]

processAction (ByeClient msg) = do

    (Just ci) <- gets clientIndex

    ri <- clientRoomA

    chan <- client's sendChan

    clNick <- client's nick

    loggedIn <- client's isVisible

    when (ri /= lobbyId) $ do

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

        return ()

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

    io $

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

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

    mapM_ processAction

        [

        AnswerClients [chan] ["BYE", msg]

        , ModifyClient (\c -> c{nick = "", isVisible = False}) -- this will effectively hide client from others while he isn't deleted from list

        ]

    s <- get

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

processAction (DeleteClient ci) = do

    io $ debugM "Clients"  $ "DeleteClient: " ++ show ci

    rnc <- gets roomsClients

    io $ removeClient rnc ci

    s <- get

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

    sp <- gets (shutdownPending . serverInfo)

    cls <- allClientsS

    io $ when (sp && null cls) $ throwIO ShutdownException

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 (ModifyRoomClients f) = do

    rnc <- gets roomsClients

    ri <- clientRoomA

    roomClIDs <- io $ roomClientsIndicesM rnc ri

    io $ mapM_ (modifyClient rnc f) roomClIDs

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, isInGame = False, clientClan = Nothing}) 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

    playersNum <- io $ room'sM rnc playersIn ri

    master <- client's isMaster

--    client <- client's id

    clNick <- client's nick

    chans <- othersChans

    if master then

        if playersNum > 1 then

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

            else

            processAction RemoveRoom

        else

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

    -- when not removing room

    ready <- client's isReady

    when (not master || playersNum > 1) . 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 delegateId)= do

    (Just ci) <- gets clientIndex

    proto <- client's clientProto

    ri <- clientRoomA

    rnc <- gets roomsClients

    newMasterId <- liftM (\ids -> fromMaybe (last . filter (/= ci) $ ids) delegateId) . io $ roomClientsIndicesM rnc ri

    newMaster <- io $ client'sM rnc id newMasterId

    oldRoomName <- io $ room'sM rnc name ri

    oldMaster <- client's nick

    kicked <- client's isKickedFromServer

    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri

    let newRoomName = if (proto < 42) || kicked then nick newMaster else oldRoomName

    mapM_ processAction [

        ModifyRoom (\r -> r{masterID = newMasterId

                , name = newRoomName

                , isRestrictedJoins = False

                , isRestrictedTeams = False

                , isRegisteredOnly = False}

                )

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

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

        , AnswerClients thisRoomChans ["CLIENT_FLAGS", "-h", oldMaster]

        , AnswerClients thisRoomChans ["CLIENT_FLAGS", "+h", nick newMaster]

        ]

    newRoom' <- io $ room'sM rnc id ri

    chans <- liftM (map sendChan) $! sameProtoClientsS proto

    processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo (nick newMaster) newRoom')

processAction (AddRoom roomName roomPassword) = do

    Just clId <- gets clientIndex

    rnc <- gets roomsClients

    proto <- client's clientProto

    n <- client's nick

    let rm = newRoom{

            masterID = clId,

            name = roomName,

            password = roomPassword,

            roomProto = proto

            }

    rId <- io $ addRoom rnc rm

    processAction $ MoveToRoom rId

    chans <- liftM (map sendChan) $! sameProtoClientsS proto

    mapM_ processAction [

      AnswerClients chans ("ROOM" : "ADD" : roomInfo n rm{playersIn = 1})

        ]

processAction RemoveRoom = do

    Just clId <- gets clientIndex

    rnc <- gets roomsClients

    ri <- io $ clientRoomM rnc clId

    roomName <- io $ room'sM rnc name ri

    others <- othersChans

    proto <- client's clientProto

    chans <- liftM (map sendChan) $! sameProtoClientsS proto

    mapM_ processAction [

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

            AnswerClients others ["ROOMABANDONED", roomName]

        ]

    io $ removeRoom rnc ri

processAction SendUpdateOnThisRoom = do

    Just clId <- gets clientIndex

    proto <- client's clientProto

    rnc <- gets roomsClients

    ri <- io $ clientRoomM rnc clId

    rm <- io $ room'sM rnc id ri

    n <- io $ client'sM rnc nick (masterID rm)

    chans <- liftM (map sendChan) $! sameProtoClientsS proto

    processAction $ AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo n rm)

processAction UnreadyRoomClients = do

    ri <- clientRoomA

    roomPlayers <- roomClientsS ri

    pr <- client's clientProto

    mapM_ processAction [

        AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr . map nick . filter (not . isMaster) $ roomPlayers

        , ModifyRoomClients (\cl -> cl{isReady = isMaster cl})

        , ModifyRoom (\r -> r{readyPlayers = 1})

        ]

    where

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

processAction FinishGame = do

    rnc <- gets roomsClients

    ri <- clientRoomA

    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri

    answerRemovedTeams <- io $

         room'sM rnc (map (\t -> AnswerClients thisRoomChans ["REMOVE_TEAM", t]) . leftTeams . fromJust . gameInfo) ri

    mapM_ processAction $

        SaveReplay

        : ModifyRoom

            (\r -> r{

                gameInfo = Nothing,

                readyPlayers = 0

                }

            )

        : UnreadyRoomClients

        : SendUpdateOnThisRoom

        : AnswerClients thisRoomChans ["ROUND_FINISHED"]

        : answerRemovedTeams

processAction (SendTeamRemovalMessage teamName) = do

    chans <- othersChans

    mapM_ processAction [

        AnswerClients chans ["EM", rmTeamMsg],

        ModifyRoom (\r -> r{

                gameInfo = liftM (\g -> g{

                    teamsInGameNumber = teamsInGameNumber g - 1

                    , roundMsgs = rmTeamMsg : roundMsgs g

                }) $ gameInfo r

            })

        ]

    rnc <- gets roomsClients

    ri <- clientRoomA

    gi <- io $ room'sM rnc gameInfo ri

    when (0 == teamsInGameNumber (fromJust gi)) $

        processAction FinishGame

    where

        rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName

processAction (RemoveTeam teamName) = do

    (Just ci) <- gets clientIndex

    rnc <- gets roomsClients

    ri <- clientRoomA

    inGame <- io $ do

        r <- room'sM rnc (isJust . gameInfo) ri

        c <- client'sM rnc isInGame ci

        return $ r && c

    chans <- othersChans

    mapM_ processAction $

        ModifyRoom (\r -> r{

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

            , gameInfo = liftM (\g -> g{leftTeams = teamName : leftTeams g}) $ gameInfo r

            })

        : SendUpdateOnThisRoom

        : AnswerClients chans ["REMOVE_TEAM", teamName]

        : [SendTeamRemovalMessage teamName | inGame]

processAction RemoveClientTeams = do

    (Just ci) <- gets clientIndex

    rnc <- gets roomsClients

    removeTeamActions <- io $ do

        rId <- clientRoomM rnc ci

        roomTeams <- room'sM rnc teams rId

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

    mapM_ processAction removeTeamActions

processAction CheckRegistered = do

    (Just ci) <- gets clientIndex

    n <- client's nick

    h <- client's host

    p <- client's clientProto

    checker <- client's isChecker

    uid <- client's clUID

    -- allow multiple checker logins

    haveSameNick <- liftM (not . null . tail . filter (\c -> (not $ isChecker c) && caseInsensitiveCompare (nick c) n)) allClientsS

    if (not checker) && haveSameNick then

        if p < 38 then

            processAction $ ByeClient $ loc "Nickname is already in use"

            else

            mapM_ processAction [NoticeMessage NickAlreadyInUse, ModifyClient $ \c -> c{nick = B.empty}]

        else

        do

        db <- gets (dbQueries . serverInfo)

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

        return ()

processAction ClearAccountsCache = do

    dbq <- gets (dbQueries . serverInfo)

    io $ writeChan dbq ClearCache

    return ()

processAction (ProcessAccountInfo info) = do

    case info of

        HasAccount passwd isAdmin -> do

            b <- isBanned

            c <- client's isChecker

            when (not b) $ (if c then checkerLogin else playerLogin) passwd isAdmin

        Guest -> do

            b <- isBanned

            c <- client's isChecker

            when (not b) $

                if c then

                    checkerLogin "" False

                    else

                    processAction JoinLobby

        Admin -> do

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

            chan <- client's sendChan

            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]

    where

    isBanned = do

        processAction $ CheckBanned False

        liftM B.null $ client's nick

    checkerLogin _ False = processAction $ ByeClient $ loc "No checker rights"

    checkerLogin p True = do

        wp <- client's webPassword

        processAction $

            if wp == p then ModifyClient $ \c -> c{logonPassed = True} else ByeClient $ loc "Authentication failed"

    playerLogin p a = do

        chan <- client's sendChan

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

processAction JoinLobby = do

    chan <- client's sendChan

    clientNick <- client's nick

    isAuthenticated <- liftM (not . B.null) $ client's webPassword

    isAdmin <- client's isAdministrator

    loggedInClients <- liftM (Prelude.filter isVisible) $! allClientsS

    let (lobbyNicks, clientsChans) = unzip . L.map (nick &&& sendChan) $ loggedInClients

    let authenticatedNicks = L.map nick . L.filter (not . B.null . webPassword) $ loggedInClients

    let adminsNicks = L.map nick . L.filter isAdministrator $ loggedInClients

    let clFlags = B.concat . L.concat $ [["u" | isAuthenticated], ["a" | isAdmin]]

    mapM_ processAction . concat $ [

        [AnswerClients clientsChans ["LOBBY:JOINED", clientNick]]

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

        , [AnswerClients [chan] ("CLIENT_FLAGS" : "+u" : authenticatedNicks) | not $ null authenticatedNicks]

        , [AnswerClients [chan] ("CLIENT_FLAGS" : "+a" : adminsNicks) | not $ null adminsNicks]

        , [AnswerClients (chan : clientsChans) ["CLIENT_FLAGS",  B.concat["+" , clFlags], clientNick] | not $ B.null clFlags]

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

        , [SendServerMessage]

        ]

processAction (KickClient kickId) = do

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

    clHost <- client's host

    currentTime <- io getCurrentTime

    mapM_ processAction [

        AddIP2Bans clHost (loc "60 seconds cooldown after kick") (addUTCTime 60 currentTime)

        , ModifyClient (\c -> c{isKickedFromServer = True})

        , ByeClient "Kicked"

        ]

processAction (BanClient seconds reason banId) = do

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

    clHost <- client's host

    currentTime <- io getCurrentTime

    let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]

    mapM_ processAction [

        AddIP2Bans clHost msg (addUTCTime seconds currentTime)

        , KickClient banId

        ]

processAction (BanIP ip seconds reason) = do

    currentTime <- io getCurrentTime

    let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]

    processAction $

        AddIP2Bans ip msg (addUTCTime seconds currentTime)

processAction (BanNick n seconds reason) = do

    currentTime <- io getCurrentTime

    let msg = 

            if seconds > 60 * 60 * 24 * 365 then

                B.concat ["Permanent ban (", reason, ")"]

                else

                B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]