{-

 * Hedgewars, a free turn based strategy game

 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>

 *

 * This program is free software; you can redistribute it and/or modify

 * it under the terms of the GNU General Public License as published by

 * the Free Software Foundation; version 2 of the License

 *

 * This program is distributed in the hope that it will be useful,

 * but WITHOUT ANY WARRANTY; without even the implied warranty of

 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

 * GNU General Public License for more details.

 *

 * You should have received a copy of the GNU General Public License

 * along with this program; if not, write to the Free Software

 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

 \-}

{-# 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 as E

import System.Process

import Network.Socket

import System.Random

import qualified Data.Traversable as DT

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

#if defined(OFFICIAL_SERVER)

import OfficialServer.GameReplayStore

#endif

import CoreTypes

import Utils

import ClientIO

import ServerState

import Consts

import ConfigFile

import EngineInteraction

import FloodDetection

import HWProtoCore

import Votes

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

                , isJoinedMidGame = 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

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

    mapM_ processAction [

        AnswerClients chans ["JOINED", clNick]

        , AnswerClients allClientsChans ["CLIENT_FLAGS", "+i", clNick]

        , RegisterEvent RoomJoin

        ]

processAction (MoveToLobby msg) = do

    (Just ci) <- gets clientIndex

    ri <- clientRoomA

    rnc <- gets roomsClients

    playersNum <- io $ room'sM rnc playersIn ri

    specialRoom <- io $ room'sM rnc isSpecial ri

    master <- client's isMaster

--    client <- client's id

    clNick <- client's nick

    chans <- othersChans

    if master then

        if (playersNum > 1) || specialRoom 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]]

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

    processAction $ AnswerClients allClientsChans ["CLIENT_FLAGS", "-i", clNick]

    -- when not removing room

    ready <- client's isReady

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

    specialRoom <- io $ room'sM rnc isSpecial ri

    newMasterId <- if specialRoom then 

        return delegateId

        else

        liftM (\ids -> fromMaybe (listToMaybe . reverse . filter (/= ci) $ ids) $ liftM Just delegateId) . io $ roomClientsIndicesM rnc ri

    newMaster <- io $ client'sM rnc id `DT.mapM` newMasterId

    oldMasterId <- io $ room'sM rnc masterID ri

    oldRoomName <- io $ room'sM rnc name ri

    kicked <- client's isKickedFromServer

    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri

    let newRoomName = if ((proto < 42) || kicked) && (not specialRoom) then maybeNick newMaster else oldRoomName

    when (isJust oldMasterId) $ do

        oldMasterNick <- io $ client'sM rnc nick (fromJust oldMasterId)

        mapM_ processAction [

            ModifyClient2 (fromJust oldMasterId) (\c -> c{isMaster = False})

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

            ]

    when (isJust newMasterId) $

        mapM_ processAction [

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

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

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

        ]

    processAction $

        ModifyRoom (\r -> r{masterID = newMasterId

                , name = newRoomName

                , isRestrictedJoins = False

                , isRestrictedTeams = False

                , isRegisteredOnly = isSpecial r}

                )

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

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

    processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo proto (maybeNick 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 = Just 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 proto 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

    masterCl <- io $ client'sM rnc id `DT.mapM` (masterID rm)

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

    processAction $ AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo proto (maybeNick masterCl) 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, isJoinedMidGame = False})

        , 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

    joinedMidGame <- liftM (filter isJoinedMidGame) $ roomClientsS ri

    answerRemovedTeams <- io $

         room'sM rnc (\r -> let gi = fromJust $ gameInfo r in

                        concatMap (\c ->

                            (answerFullConfigParams c (mapParams r) (params r))

                            ++

                            (map (\t -> AnswerClients [sendChan c] ["REMOVE_TEAM", t]) $ leftTeams gi)

                        ) joinedMidGame

                     ) ri

    rteams <- io $ room'sM rnc (L.nub . rejoinedTeams . fromJust . gameInfo) ri

    mapM_ (processAction . RemoveTeam) rteams

    mapM_ processAction $ (

        SaveReplay

        : ModifyRoom

            (\r -> r{

                gameInfo = Nothing,

                readyPlayers = 0

                }

            )

        : SendUpdateOnThisRoom

        : AnswerClients thisRoomChans ["ROUND_FINISHED"]

        : answerRemovedTeams

        )

        ++ [UnreadyRoomClients]

processAction (SendTeamRemovalMessage teamName) = do

    chans <- othersChans

    mapM_ processAction [

        AnswerClients chans ["EM", rmTeamMsg],

        ModifyRoom (\r -> r{

                gameInfo = liftM (\g -> g{

                    teamsInGameNumber = teamsInGameNumber g - 1

                    , lastFilteredTimedMsg = Nothing

                    , roundMsgs = (if isJust $ lastFilteredTimedMsg g then ((:) rmTeamMsg . (:) (fromJust $ lastFilteredTimedMsg g)) else ((:) 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

    n <- client's nick

    removeTeamActions <- io $ do

        rId <- clientRoomM rnc ci

        roomTeams <- room'sM rnc teams rId

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

    mapM_ processAction removeTeamActions

processAction SetRandomSeed = do

    ri <- clientRoomA

    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri

    seed <- liftM showB $ io $ (randomRIO (0, 10^9) :: IO Int)

    mapM_ processAction [

        ModifyRoom (\r -> r{mapParams = Map.insert "SEED" seed $ mapParams r})

        , AnswerClients thisRoomChans ["CFG", "SEED", seed]

        ]

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 isContr -> do

            b <- isBanned

            c <- client's isChecker

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

        Guest -> do

            b <- isBanned

            c <- client's isChecker

            when (not b) $

                if c then

                    checkerLogin "" False False

                    else

                    processAction JoinLobby

        Admin ->

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

        ReplayName fn -> processAction $ ShowReplay fn