{-
 * 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
import Text.Regex.TDFA
import qualified Text.Regex.TDFA as TDFA
import qualified Text.Regex.TDFA.ByteString as TDFAB
import qualified Data.Yaml as YAML
-----------------------------
#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 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]
        -- TODO: Send message to other clients, too (requires proper localization, however)
        , AnswerClients [sendChan $ fromJust newMaster] ["CHAT", nickServer, loc "You're the new room master!"]
        ]

    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
    si <- gets serverInfo
    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 | isRegisteredUsersOnly si -> do
            processAction $ ByeClient "Registered users only"
            | otherwise -> 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
    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
        chan <- client's sendChan
        mapM_ processAction $
            if wp == p then
                [ModifyClient $ \c -> c{logonPassed = True}
                , AnswerClients [chan] ["LOGONPASSED"]
                ]
                else
                [ByeClient $ loc "Authentication failed"]
    playerLogin p a contr = do
        cl <- client's id
        mapM_ processAction [
            AnswerClients [sendChan cl] $ ("ASKPASSWORD") : if clientProto cl < 48 then [] else [serverSalt cl]
            , ModifyClient (\c -> c{webPassword = p, isAdministrator = a, isContributor = contr})
            ]

processAction JoinLobby = do
    chan <- client's sendChan
    rnc <- gets roomsClients
    clientNick <- client's nick
    clProto <- client's clientProto
    isAuthenticated <- client's isRegistered
    isAdmin <- client's isAdministrator
    isContr <- client's isContributor
    loggedInClients <- liftM (Prelude.filter isVisible) $! allClientsS
    let (lobbyNicks, clientsChans) = unzip . L.map (nick &&& sendChan) $ loggedInClients
    let authenticatedNicks = L.map nick . L.filter isRegistered $ loggedInClients
    let adminsNicks = L.map nick . L.filter isAdministrator $ loggedInClients
    let contrNicks = L.map nick . L.filter isContributor $ loggedInClients
    inRoomNicks <- io $
        allClientsM rnc
        >>= filterM (liftM ((/=) lobbyId) . clientRoomM rnc)
        >>= mapM (client'sM rnc nick)
    let clFlags = B.concat . L.concat $ [["u" | isAuthenticated], ["a" | isAdmin], ["c" | isContr]]

    roomsInfoList <- io $ do
        rooms <- roomsM rnc
        mapM (\r -> (mapM (client'sM rnc id) $ masterID r)
            >>= \cn -> return $ roomInfo clProto (maybeNick cn) r)
            $ filter (\r -> (roomProto r == clProto)) rooms

    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] ("CLIENT_FLAGS" : "+c" : contrNicks) | not $ null contrNicks]
        , [AnswerClients [chan] ("CLIENT_FLAGS" : "+i" : inRoomNicks) | not $ null inRoomNicks]
        , [AnswerClients (chan : clientsChans) ["CLIENT_FLAGS",  B.concat["+" , clFlags], clientNick] | not $ B.null clFlags]
        , [ModifyClient (\cl -> cl{logonPassed = True, isVisible = True})]
        , [SendServerMessage]
        , [AnswerClients [chan] ("ROOMS" : concat roomsInfoList)]
        ]


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 $ loc "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, ")"]
    processAction $
        AddNick2Bans n msg (addUTCTime seconds currentTime)


processAction BanList = do
    time <- io $ getCurrentTime
    ch <- client's sendChan
    b <- gets (B.intercalate "\n" . concatMap (ban2Str time) . bans . serverInfo)
    processAction $
        AnswerClients [ch] ["BANLIST", b]
    where
        ban2Str time (BanByIP b r t) = ["I", b, r, B.pack . show $ t `diffUTCTime` time]
        ban2Str time (BanByNick b r t) = ["N", b, r, B.pack . show $ t `diffUTCTime` time]


processAction (Unban entry) = do
    processAction $ ModifyServerInfo (\s -> s{bans = filter (not . f) $ bans s})
    where
        f (BanByIP bip _ _) = bip == entry
        f (BanByNick bn _ _) = bn == entry


processAction (KickRoomClient kickId) = do
    modify (\s -> s{clientIndex = Just kickId})
    ch <- client's sendChan
    mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby $ loc "kicked"]


processAction (AddClient cl) = do
    rnc <- gets roomsClients
    si <- gets serverInfo
    newClId <- io $ do
        ci <- addClient rnc cl
        _ <- Exception.mask (\x -> forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci x)

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

        return ci

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

    jm <- gets joinsMonitor
    pass <- io $ joinsSentry jm (host cl) (connectTime cl)

    if pass then
        mapM_ processAction
            [
                CheckBanned True
                , AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server https://www.hedgewars.org/", serverVersion]
            ]
        else
        processAction $ ByeClient $ loc "Reconnected too fast"

processAction (AddNick2Bans n reason expiring) = do
    processAction $ ModifyServerInfo (\s -> s{bans = BanByNick n reason expiring : bans s})

processAction (AddIP2Bans ip reason expiring) = do
    (Just ci) <- gets clientIndex
    rc <- gets removedClients
    when (not $ ci `Set.member` rc)
        $ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s})


processAction (CheckBanned byIP) = do
    clTime <- client's connectTime
    clNick <- client's nick
    clHost <- client's host
    si <- gets serverInfo
    let (validBans, expiredBans) = L.partition (checkNotExpired clTime) $ bans si
    let ban = L.find (checkBan byIP clHost clNick) $ validBans
    mapM_ processAction $
        [ModifyServerInfo (\s -> s{bans = validBans}) | not $ null expiredBans]
        ++ [ByeClient (getBanReason $ fromJust ban) | isJust ban]
    where
        checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0
        checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0
        checkBan True ip _ (BanByIP bip _ _) = isMatch bip ip
        checkBan False _ n (BanByNick bn _ _) = isMatch bn n
        checkBan _ _ _ _ = False
        isMatch :: B.ByteString -> B.ByteString -> Bool
        isMatch rexp src = (==) (Just True) $ mrexp rexp >>= flip matchM src
        mrexp :: B.ByteString -> Maybe TDFAB.Regex
        mrexp = makeRegexOptsM TDFA.defaultCompOpt{TDFA.caseSensitive = False} TDFA.defaultExecOpt
        getBanReason (BanByIP _ msg _) = msg
        getBanReason (BanByNick _ msg _) = msg


processAction PingAll = do
    rnc <- gets roomsClients
    io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
    cis <- io $ allClientsM rnc
    chans <- io $ mapM (client'sM rnc sendChan) cis
    io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
    processAction $ AnswerClients chans ["PING"]
    where
        kickTimeouted rnc ci = do
            pq <- io $ client'sM rnc pingsQueue ci
            when (pq > 0) $ do
                withStateT (\as -> as{clientIndex = Just ci}) $
                    processAction (ByeClient $ loc "Ping timeout")
--                when (pq > 1) $
--                    processAction $ DeleteClient ci -- smth went wrong with client io threads, issue DeleteClient here


processAction StatsAction = do
    si <- gets serverInfo
    when (not $ shutdownPending si) $ do
        rnc <- gets roomsClients
        (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st
        io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
    where
          st irnc = (length $ allRooms irnc, length $ allClients irnc)


processAction RestartServer = do
    sp <- gets (shutdownPending . serverInfo)
    when (not sp) $ do
        sock <- gets (fromJust . serverSocket . serverInfo)
        args <- gets (runArgs . serverInfo)
        io $ do
            noticeM "Core" "Closing listening socket"
            sClose sock
            noticeM "Core" "Spawning new server"
            _ <- createProcess (proc "./hedgewars-server" args)
            return ()
        processAction $ ModifyServerInfo (\s -> s{shutdownPending = True})


processAction Stats = do
    cls <- allClientsS
    rms <- allRoomsS
    let clientsMap = Map.fromListWith (+) . map (\c -> (clientProto c, 1 :: Int)) $ cls
    let roomsMap = Map.fromListWith (+) . map (\c -> (roomProto c, 1 :: Int)) . filter ((/=) 0 . roomProto) $ rms
    let keys = Map.keysSet clientsMap `Set.union` Map.keysSet roomsMap
    let versionsStats = B.concat . ((:) "<table border=1>") . (flip (++) ["</table>"])
            . concatMap (\p -> [
                    "<tr><td>", protoNumber2ver p
                    , "</td><td>", showB $ Map.findWithDefault 0 p clientsMap
                    , "</td><td>", showB $ Map.findWithDefault 0 p roomsMap
                    , "</td></tr>"])
            . Set.toList $ keys
    processAction $ Warning versionsStats


processAction (Random chans items) = do
    let i = if null items then ["heads", "tails"] else items
    n <- io $ randomRIO (0, length i - 1)
    processAction $ AnswerClients chans ["CHAT", nickRandom, i !! n]


processAction (LoadGhost location) = do
    ri <- clientRoomA
    rnc <- gets roomsClients
    thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
#if defined(OFFICIAL_SERVER)
    rm <- io $ room'sM rnc id ri
    points <- io $ loadFile (B.unpack $ "ghosts/" `B.append` sanitizeName location)
    when (roomProto rm > 51) $ do
        processAction $ ModifyRoom $ \r -> r{params = Map.insert "DRAWNMAP" [prependGhostPoints (toP points) $ head $ (params r) Map.! "DRAWNMAP"] (params r)}
#endif
    cl <- client's id
    rm <- io $ room'sM rnc id ri
    mapM_ processAction $ map (replaceChans thisRoomChans) $ answerFullConfigParams cl (mapParams rm) (params rm)
    where
    loadFile :: String -> IO [Int]
    loadFile fileName = E.handle (\(e :: SomeException) -> return []) $ do
        points <- liftM read $ readFile fileName
        return (points `deepseq` points)
    replaceChans chans (AnswerClients _ msg) = AnswerClients chans msg
    replaceChans _ a = a
    toP [] = []
    toP (p1:p2:ps) = (fromIntegral p1, fromIntegral p2) : toP ps
{-
        let a = map (replaceChans chans) $ answerFullConfigParams cl mp p
-}
#if defined(OFFICIAL_SERVER)
processAction SaveReplay = do
    ri <- clientRoomA
    rnc <- gets roomsClients

    readyCheckersIds <- io $ do
        r <- room'sM rnc id ri
        saveReplay r
        allci <- allClientsM rnc
        filterM (client'sM rnc isReadyChecker) allci

    when (not $ null readyCheckersIds) $ do
        oldci <- gets clientIndex
        withStateT (\s -> s{clientIndex = Just $ head readyCheckersIds})
            $ processAction CheckRecord
        modify (\s -> s{clientIndex = oldci})
    where
        isReadyChecker cl = isChecker cl && isReady cl


processAction CheckRecord = do
    p <- client's clientProto
    c <- client's sendChan
    ri <- clientRoomA
    rnc <- gets roomsClients

    blackList <- liftM (map (recordFileName . fromJust . checkInfo) . filter (isJust . checkInfo)) allClientsS

    (cinfo, l) <- io $ loadReplay (fromIntegral p) blackList
    when (isJust cinfo) $
        mapM_ processAction [
            AnswerClients [c] ("REPLAY" : l)
            , ModifyClient $ \c -> c{checkInfo = cinfo, isReady = False}
            ]


processAction (CheckFailed msg) = do
    Just (CheckInfo fileName _ _) <- client's checkInfo
    io $ moveFailedRecord fileName


processAction (CheckSuccess info) = do
    Just (CheckInfo fileName teams gameDetails) <- client's checkInfo
    p <- client's clientProto
    si <- gets serverInfo
    when (isJust gameDetails)
        $ io $ writeChan (dbQueries si) $ StoreAchievements p (B.pack fileName) (map toPair teams) (fromJust gameDetails) info
    io $ moveCheckedRecord fileName
    where
        toPair t = (teamname t, teamowner t)

processAction (QueryReplay rname) = do
    (Just ci) <- gets clientIndex
    si <- gets serverInfo
    uid <- client's clUID
    io $ writeChan (dbQueries si) $ GetReplayName ci (hashUnique uid) rname

#else
processAction SaveReplay = return ()
processAction CheckRecord = return ()
processAction (CheckFailed _) = return ()
processAction (CheckSuccess _) = return ()
processAction (QueryReplay _) = processAction $ Warning $ loc "This server does not support replays!"
#endif

processAction (ShowReplay rname) = do
    c <- client's sendChan
    cl <- client's id

    let fileName = B.concat ["checked/", if B.isPrefixOf "replays/" rname then B.drop 8 rname else rname]

    cInfo <- liftIO $ E.handle (\(e :: SomeException) ->
                    warningM "REPLAYS" (B.unpack $ B.concat ["Problems reading ", fileName, ": ", B.pack $ show e]) >> return Nothing) $ do
            (t, p1, p2, msgs) <- liftM read $ readFile (B.unpack fileName)
            return $ Just (t, Map.fromList p1, Map.fromList p2, reverse msgs)

    let (teams', params1, params2, roundMsgs') = fromJust cInfo

    when (isJust cInfo) $ do
        mapM_ processAction $ concat [
            [AnswerClients [c] ["JOINED", nick cl]]
            , answerFullConfigParams cl params1 params2
            , answerAllTeams cl teams'
            , [AnswerClients [c]  ["RUN_GAME"]]
            , [AnswerClients [c] $ "EM" : roundMsgs']
            , [AnswerClients [c] ["KICKED"]]
            ]

processAction (SaveRoom rname) = do
    rnc <- gets roomsClients
    ri <- clientRoomA
    rm <- io $ room'sM rnc id ri
    liftIO $ YAML.encodeFile (B.unpack rname) (greeting rm, roomSaves rm)

processAction (LoadRoom rname) = do
    Right (g, rs) <- io $ YAML.decodeFileEither (B.unpack rname)
    processAction $ ModifyRoom $ \r -> r{greeting = g, roomSaves = rs}

processAction Cleanup = do
    jm <- gets joinsMonitor

    io $ do
        t <- getCurrentTime
        cleanup jm t


processAction (RegisterEvent e) = do
    actions <- registerEvent e
    mapM_ processAction actions


processAction (ReactCmd cmd) = do
    (Just ci) <- gets clientIndex
    rnc <- gets roomsClients
    actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
    forM_ (actions `deepseq` actions) processAction

processAction CheckVotes =
    checkVotes >>= mapM_ processAction