gameServer/Actions.hs
author unc0rr
Sat, 05 Mar 2011 09:32:11 +0300
changeset 4983 1c9381181e85
parent 4975 31da8979e5b1
child 4989 4771fed9272e
permissions -rw-r--r--
Better support for 0.9.15
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
     1
{-# LANGUAGE OverloadedStrings #-}
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
     2
module Actions where
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
     3
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
     4
import Control.Concurrent
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
     5
import qualified Data.Set as Set
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
     6
import qualified Data.Sequence as Seq
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
     7
import System.Log.Logger
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
     8
import Control.Monad
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
     9
import Data.Time
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    10
import Data.Maybe
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    11
import Control.Monad.Reader
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    12
import Control.Monad.State.Strict
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    13
import qualified Data.ByteString.Char8 as B
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    14
import Control.DeepSeq
4918
c6d3aec73f93 Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents: 4917
diff changeset
    15
import Data.Unique
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
    16
import Control.Arrow
4959
09f4978b4fb0 ShutdownException for server shutdown
unc0rr
parents: 4955
diff changeset
    17
import Control.Exception
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    18
-----------------------------
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    19
import CoreTypes
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    20
import Utils
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    21
import ClientIO
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    22
import ServerState
4973
53411a26df7e Add server version (which is separate from protocol version) and a check in frontend for a new enough server (currently only qWarning)
unc0rr
parents: 4962
diff changeset
    23
import Consts
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    24
4975
31da8979e5b1 Use Data.TConfig to read and store server config in hedgewars.ini (a little bit of hate to the author for not exporting Conf type)
unc0rr
parents: 4973
diff changeset
    25
data Action c =
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    26
    AnswerClients ![ClientChan] ![B.ByteString]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    27
    | SendServerMessage
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    28
    | SendServerVars
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    29
    | MoveToRoom RoomIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    30
    | MoveToLobby B.ByteString
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    31
    | RemoveTeam B.ByteString
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    32
    | RemoveRoom
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    33
    | UnreadyRoomClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    34
    | JoinLobby
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    35
    | ProtocolError B.ByteString
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    36
    | Warning B.ByteString
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    37
    | NoticeMessage Notice
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    38
    | ByeClient B.ByteString
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    39
    | KickClient ClientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    40
    | KickRoomClient ClientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    41
    | BanClient NominalDiffTime B.ByteString ClientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    42
    | ChangeMaster
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    43
    | RemoveClientTeams ClientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    44
    | ModifyClient (ClientInfo -> ClientInfo)
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    45
    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    46
    | ModifyRoom (RoomInfo -> RoomInfo)
4975
31da8979e5b1 Use Data.TConfig to read and store server config in hedgewars.ini (a little bit of hate to the author for not exporting Conf type)
unc0rr
parents: 4973
diff changeset
    47
    | ModifyServerInfo (ServerInfo c -> ServerInfo c)
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    48
    | AddRoom B.ByteString B.ByteString
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    49
    | CheckRegistered
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    50
    | ClearAccountsCache
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    51
    | ProcessAccountInfo AccountInfo
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    52
    | AddClient ClientInfo
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    53
    | DeleteClient ClientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    54
    | PingAll
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    55
    | StatsAction
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
    56
    | RestartServer Bool
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    57
4955
84543ecae8c3 Don't forkIO main loop
unc0rr
parents: 4942
diff changeset
    58
4975
31da8979e5b1 Use Data.TConfig to read and store server config in hedgewars.ini (a little bit of hate to the author for not exporting Conf type)
unc0rr
parents: 4973
diff changeset
    59
type CmdHandler c = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action c]
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    60
4975
31da8979e5b1 Use Data.TConfig to read and store server config in hedgewars.ini (a little bit of hate to the author for not exporting Conf type)
unc0rr
parents: 4973
diff changeset
    61
instance NFData (Action c) where
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    62
    rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    63
    rnf a = a `seq` ()
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    64
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    65
instance NFData B.ByteString
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    66
instance NFData (Chan a)
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    67
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
    68
4975
31da8979e5b1 Use Data.TConfig to read and store server config in hedgewars.ini (a little bit of hate to the author for not exporting Conf type)
unc0rr
parents: 4973
diff changeset
    69
othersChans :: StateT (ServerState c) IO [ClientChan]
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    70
othersChans = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    71
    cl <- client's id
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    72
    ri <- clientRoomA
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    73
    liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    74
4975
31da8979e5b1 Use Data.TConfig to read and store server config in hedgewars.ini (a little bit of hate to the author for not exporting Conf type)
unc0rr
parents: 4973
diff changeset
    75
processAction :: Action c -> StateT (ServerState c) IO ()
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    76
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    77
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
    78
processAction (AnswerClients chans msg) =
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
    79
    io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    80
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    81
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    82
processAction SendServerMessage = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    83
    chan <- client's sendChan
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    84
    protonum <- client's clientProto
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    85
    si <- liftM serverInfo get
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    86
    let message = if protonum < latestReleaseVersion si then
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    87
            serverMessageForOldVersions si
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    88
            else
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    89
            serverMessage si
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    90
    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    91
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    92
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    93
processAction SendServerVars = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    94
    chan <- client's sendChan
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    95
    si <- gets serverInfo
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    96
    io $ writeChan chan ("SERVER_VARS" : vars si)
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    97
    where
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    98
        vars si = [
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
    99
            "MOTD_NEW", serverMessage si,
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   100
            "MOTD_OLD", serverMessageForOldVersions si,
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   101
            "LATEST_PROTO", B.pack . show $ latestReleaseVersion si
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   102
            ]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   103
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   104
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   105
processAction (ProtocolError msg) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   106
    chan <- client's sendChan
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   107
    processAction $ AnswerClients [chan] ["ERROR", msg]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   108
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   109
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   110
processAction (Warning msg) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   111
    chan <- client's sendChan
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   112
    processAction $ AnswerClients [chan] ["WARNING", msg]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   113
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   114
processAction (NoticeMessage n) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   115
    chan <- client's sendChan
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   116
    processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   117
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   118
processAction (ByeClient msg) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   119
    (Just ci) <- gets clientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   120
    ri <- clientRoomA
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   121
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   122
    chan <- client's sendChan
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   123
    clNick <- client's nick
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   124
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   125
    when (ri /= lobbyId) $ do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   126
        processAction $ MoveToLobby ("quit: " `B.append` msg)
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   127
        return ()
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   128
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   129
    clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   130
    io $
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   131
        infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   132
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   133
    processAction $ AnswerClients [chan] ["BYE", msg]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   134
    processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   135
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   136
    s <- get
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   137
    put $! s{removedClients = ci `Set.insert` removedClients s}
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   138
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   139
processAction (DeleteClient ci) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   140
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   141
    io $ removeClient rnc ci
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   142
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   143
    s <- get
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   144
    put $! s{removedClients = ci `Set.delete` removedClients s}
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   145
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   146
processAction (ModifyClient f) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   147
    (Just ci) <- gets clientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   148
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   149
    io $ modifyClient rnc f ci
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   150
    return ()
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   151
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   152
processAction (ModifyClient2 ci f) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   153
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   154
    io $ modifyClient rnc f ci
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   155
    return ()
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   156
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   157
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   158
processAction (ModifyRoom f) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   159
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   160
    ri <- clientRoomA
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   161
    io $ modifyRoom rnc f ri
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   162
    return ()
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   163
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   164
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   165
processAction (ModifyServerInfo f) =
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   166
    modify (\s -> s{serverInfo = f $ serverInfo s})
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   167
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   168
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   169
processAction (MoveToRoom ri) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   170
    (Just ci) <- gets clientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   171
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   172
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   173
    io $ do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   174
        modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   175
        modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   176
        moveClientToRoom rnc ri ci
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   177
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   178
    chans <- liftM (map sendChan) $ roomClientsS ri
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   179
    clNick <- client's nick
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   180
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   181
    processAction $ AnswerClients chans ["JOINED", clNick]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   182
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   183
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   184
processAction (MoveToLobby msg) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   185
    (Just ci) <- gets clientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   186
    ri <- clientRoomA
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   187
    rnc <- gets roomsClients
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   188
    (gameProgress, playersNum) <- io $ room'sM rnc (gameinprogress &&& playersIn) ri
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   189
    ready <- client's isReady
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   190
    master <- client's isMaster
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   191
--    client <- client's id
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   192
    clNick <- client's nick
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   193
    chans <- othersChans
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   194
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   195
    if master then
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   196
        if gameProgress && playersNum > 1 then
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   197
            mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   198
            else
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   199
            processAction RemoveRoom
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   200
        else
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   201
        mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   202
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   203
    io $ do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   204
            modifyRoom rnc (\r -> r{
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   205
                    playersIn = playersIn r - 1,
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   206
                    readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   207
                    }) ri
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   208
            moveClientToLobby rnc ci
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   209
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   210
processAction ChangeMaster = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   211
    ri <- clientRoomA
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   212
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   213
    newMasterId <- liftM head . io $ roomClientsIndicesM rnc ri
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   214
    newMaster <- io $ client'sM rnc id newMasterId
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   215
    let newRoomName = nick newMaster
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   216
    mapM_ processAction [
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   217
        ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}),
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   218
        ModifyClient2 newMasterId (\c -> c{isMaster = True}),
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   219
        AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   220
        ]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   221
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   222
processAction (AddRoom roomName roomPassword) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   223
    Just clId <- gets clientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   224
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   225
    proto <- io $ client'sM rnc clientProto clId
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   226
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   227
    let rm = newRoom{
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   228
            masterID = clId,
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   229
            name = roomName,
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   230
            password = roomPassword,
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   231
            roomProto = proto
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   232
            }
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   233
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   234
    rId <- io $ addRoom rnc rm
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   235
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   236
    processAction $ MoveToRoom rId
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   237
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   238
    chans <- liftM (map sendChan) $! roomClientsS lobbyId
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   239
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   240
    mapM_ processAction [
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   241
        AnswerClients chans ["ROOM", "ADD", roomName]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   242
        , ModifyClient (\cl -> cl{isMaster = True})
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   243
        ]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   244
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   245
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   246
processAction RemoveRoom = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   247
    Just clId <- gets clientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   248
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   249
    ri <- io $ clientRoomM rnc clId
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   250
    roomName <- io $ room'sM rnc name ri
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   251
    others <- othersChans
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   252
    lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   253
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   254
    mapM_ processAction [
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   255
            AnswerClients lobbyChans ["ROOM", "DEL", roomName],
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   256
            AnswerClients others ["ROOMABANDONED", roomName]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   257
        ]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   258
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   259
    io $ removeRoom rnc ri
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   260
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   261
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   262
processAction (UnreadyRoomClients) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   263
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   264
    ri <- clientRoomA
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   265
    roomPlayers <- roomClientsS ri
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   266
    roomClIDs <- io $ roomClientsIndicesM rnc ri
4942
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4932
diff changeset
   267
    pr <- client's clientProto
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4932
diff changeset
   268
    processAction $ AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr (map nick roomPlayers)
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   269
    io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   270
    processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
4942
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4932
diff changeset
   271
    where
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4932
diff changeset
   272
        notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   273
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   274
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   275
processAction (RemoveTeam teamName) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   276
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   277
    ri <- clientRoomA
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   278
    inGame <- io $ room'sM rnc gameinprogress ri
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   279
    chans <- othersChans
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   280
    if inGame then
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   281
            mapM_ processAction [
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   282
                AnswerClients chans ["REMOVE_TEAM", teamName],
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   283
                ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r})
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   284
                ]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   285
        else
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   286
            mapM_ processAction [
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   287
                AnswerClients chans ["EM", rmTeamMsg],
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   288
                ModifyRoom (\r -> r{
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   289
                    teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   290
                    leftTeams = teamName : leftTeams r,
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   291
                    roundMsgs = roundMsgs r Seq.|> rmTeamMsg
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   292
                    })
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   293
                ]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   294
    where
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   295
        rmTeamMsg = toEngineMsg $ B.singleton 'F' `B.append` teamName
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   296
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   297
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   298
processAction (RemoveClientTeams clId) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   299
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   300
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   301
    removeTeamActions <- io $ do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   302
        clNick <- client'sM rnc nick clId
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   303
        rId <- clientRoomM rnc clId
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   304
        roomTeams <- room'sM rnc teams rId
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   305
        return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   306
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   307
    mapM_ processAction removeTeamActions
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   308
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   309
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   310
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   311
processAction CheckRegistered = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   312
    (Just ci) <- gets clientIndex
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   313
    n <- client's nick
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   314
    h <- client's host
4918
c6d3aec73f93 Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents: 4917
diff changeset
   315
    uid <- client's clUID
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   316
    db <- gets (dbQueries . serverInfo)
4918
c6d3aec73f93 Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents: 4917
diff changeset
   317
    io $ writeChan db $ CheckAccount ci (hashUnique uid) n h
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   318
    return ()
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   319
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   320
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   321
processAction ClearAccountsCache = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   322
    dbq <- gets (dbQueries . serverInfo)
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   323
    io $ writeChan dbq ClearCache
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   324
    return ()
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   325
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   326
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   327
processAction (ProcessAccountInfo info) =
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   328
    case info of
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   329
        HasAccount passwd isAdmin -> do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   330
            chan <- client's sendChan
4923
c7829611c682 Fix admin stuff :D
unc0rr
parents: 4922
diff changeset
   331
            mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   332
        Guest ->
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   333
            processAction JoinLobby
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   334
        Admin -> do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   335
            mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   336
            chan <- client's sendChan
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   337
            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   338
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   339
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   340
processAction JoinLobby = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   341
    chan <- client's sendChan
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   342
    clientNick <- client's nick
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   343
    (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (nick &&& sendChan) . Prelude.filter logonPassed) $! allClientsS
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   344
    mapM_ processAction $
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   345
        AnswerClients clientsChans ["LOBBY:JOINED", clientNick]
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   346
        : AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   347
        : [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   348
4942
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4932
diff changeset
   349
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   350
processAction (KickClient kickId) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   351
    modify (\s -> s{clientIndex = Just kickId})
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   352
    processAction $ ByeClient "Kicked"
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   353
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   354
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   355
processAction (BanClient seconds reason banId) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   356
    modify (\s -> s{clientIndex = Just banId})
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   357
    clHost <- client's host
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   358
    currentTime <- io getCurrentTime
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   359
    let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` reason ` B.append` ")"
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4907
diff changeset
   360
    mapM_ processAction [
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   361
        ModifyServerInfo (\s -> s{lastLogins = (clHost, (addUTCTime seconds currentTime, msg)) : lastLogins s})
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4907
diff changeset
   362
        , KickClient banId
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4907
diff changeset
   363
        ]
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   364
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   365
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   366
processAction (KickRoomClient kickId) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   367
    modify (\s -> s{clientIndex = Just kickId})
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   368
    ch <- client's sendChan
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   369
    mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "kicked"]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   370
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   371
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   372
processAction (AddClient cl) = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   373
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   374
    si <- gets serverInfo
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   375
    newClId <- io $ do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   376
        ci <- addClient rnc cl
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   377
        t <- forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) ci
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   378
        _ <- forkIO $ clientSendLoop (clientSocket cl) t (coreChan si) (sendChan cl) ci
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   379
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   380
        infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   381
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   382
        return ci
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   383
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   384
    modify (\s -> s{clientIndex = Just newClId})
4973
53411a26df7e Add server version (which is separate from protocol version) and a check in frontend for a new enough server (currently only qWarning)
unc0rr
parents: 4962
diff changeset
   385
    processAction $ AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion]
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   386
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   387
    let newLogins = takeWhile (\(_ , (time, _)) -> connectTime cl `diffUTCTime` time <= 0) $ lastLogins si
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   388
    let info = host cl `Prelude.lookup` newLogins
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   389
    if isJust info then
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   390
        mapM_ processAction [ModifyServerInfo (\s -> s{lastLogins = newLogins}), ByeClient (snd .  fromJust $ info)]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   391
        else
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   392
        processAction $ ModifyServerInfo (\s -> s{lastLogins = (host cl, (addUTCTime 10 $ connectTime cl, "Reconnected too fast")) : newLogins})
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   393
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   394
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   395
processAction PingAll = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   396
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   397
    io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   398
    cis <- io $ allClientsM rnc
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   399
    chans <- io $ mapM (client'sM rnc sendChan) cis
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   400
    io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   401
    processAction $ AnswerClients chans ["PING"]
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   402
    where
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   403
        kickTimeouted rnc ci = do
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   404
            pq <- io $ client'sM rnc pingsQueue ci
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   405
            when (pq > 0) $
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   406
                withStateT (\as -> as{clientIndex = Just ci}) $
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   407
                    processAction (ByeClient "Ping timeout")
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   408
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   409
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   410
processAction StatsAction = do
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   411
    rnc <- gets roomsClients
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   412
    si <- gets serverInfo
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   413
    (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   414
    io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   415
    where
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4923
diff changeset
   416
          st irnc = (length $ allRooms irnc, length $ allClients irnc)
4907
8bf14795a528 KICK and BAN actions (ban has no protocol command for it yet)
unc0rr
parents: 4905
diff changeset
   417
4955
84543ecae8c3 Don't forkIO main loop
unc0rr
parents: 4942
diff changeset
   418
processAction (RestartServer force) = do
84543ecae8c3 Don't forkIO main loop
unc0rr
parents: 4942
diff changeset
   419
    if force then do
4962
705c6186ad9d Start new server on RestartException
unc0rr
parents: 4960
diff changeset
   420
        throw RestartException
4955
84543ecae8c3 Don't forkIO main loop
unc0rr
parents: 4942
diff changeset
   421
        else
84543ecae8c3 Don't forkIO main loop
unc0rr
parents: 4942
diff changeset
   422
        processAction $ ModifyServerInfo (\s -> s{restartPending=True})