gameServer/HWProtoLobbyState.hs
author nemo
Thu, 01 Jul 2010 23:41:10 -0400
changeset 3608 c509bbc779e7
parent 3566 772a46ef8288
child 3645 c0b3f1bb9316
permissions -rw-r--r--
Revert prior attempted optimisation. Gridding the land pays in some situations, but not all. Restricting to an upper bound might help, but overall, seems too fuzzy to be worth it. On one side is increased cost of Add/Delete + extra test on collision check, on the other is skipping the list iteration. Perhaps for large lists.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3435
diff changeset
     1
{-# LANGUAGE OverloadedStrings #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module HWProtoLobbyState where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import qualified Data.Map as Map
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import qualified Data.IntSet as IntSet
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
     6
import qualified Data.Foldable as Foldable
3555
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3540
diff changeset
     7
import Data.Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import Data.List
3260
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
     9
import Data.Word
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    10
import Control.Monad.Reader
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    11
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
import Utils
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    16
import HandlerUtils
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    17
import RoomsAndClients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    19
{-answerAllTeams protocol teams = concatMap toAnswer teams
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    20
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    21
        toAnswer team =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    22
            [AnswerThisClient $ teamToNet protocol team,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    23
            AnswerThisClient ["TEAM_COLOR", teamname team, teamcolor team],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    24
            AnswerThisClient ["HH_NUM", teamname team, show $ hhnum team]]
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    25
-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
handleCmd_lobby :: CmdHandler
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    28
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    29
handleCmd_lobby ["LIST"] = do
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    30
    (ci, irnc) <- ask
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    31
    let cl = irnc `client` ci
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    32
    rooms <- allRoomInfos
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    33
    let roomsInfoList = concatMap (roomInfo irnc) . filter (\r -> (roomProto r == clientProto cl) && not (isRestrictedJoins r))
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    34
    return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    35
    where
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3555
diff changeset
    36
        roomInfo irnc room = [
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    37
                showB $ gameinprogress room,
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    38
                name room,
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    39
                showB $ playersIn room,
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    40
                showB $ length $ teams room,
3555
4c5ca656d1bb Reimplement ADD_TEAM
unc0rr
parents: 3540
diff changeset
    41
                nick $ irnc `client` masterID room,
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    42
                head (Map.findWithDefault ["+gen+"] "MAP" (params room)),
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    43
                head (Map.findWithDefault ["Default"] "SCHEME" (params room)),
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    44
                head (Map.findWithDefault ["Default"] "AMMO" (params room))
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    45
                ]
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    46
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
    47
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    48
handleCmd_lobby ["CHAT", msg] = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    49
    n <- clientNick
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    50
    s <- roomOthersChans
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    51
    return [AnswerClients s ["CHAT", n, msg]]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    53
handleCmd_lobby ["CREATE_ROOM", newRoom, roomPassword]
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    54
    | illegalName newRoom = return [Warning "Illegal room name"]
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    55
    | otherwise = do
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    56
        rs <- allRoomInfos
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    57
        (ci, irnc) <- ask
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    58
        let cl =  irnc `client` ci
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    59
        return $ if isJust $ find (\room -> newRoom == name room) rs then 
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    60
            [Warning "Room exists"]
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    61
            else
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    62
            [
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    63
                AddRoom newRoom roomPassword,
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    64
                AnswerClients [sendChan cl] ["NOT_READY", nick cl]
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    65
            ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
    67
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    68
handleCmd_lobby ["CREATE_ROOM", newRoom] =
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    69
    handleCmd_lobby ["CREATE_ROOM", newRoom, ""]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    71
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    72
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    73
    (ci, irnc) <- ask
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    74
    let ris = allRooms irnc
3540
b602a57ba0fb Reimplement CFG protocol command
unc0rr
parents: 3536
diff changeset
    75
    cl <- thisClient
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    76
    let maybeRI = find (\ri -> roomName == name (irnc `room` ri)) ris
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    77
    let jRI = fromJust maybeRI
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    78
    let jRoom = irnc `room` jRI
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    79
    let jRoomClients = map (client irnc) $! roomClients irnc jRI -- no lazyness here!
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    80
    return $
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    81
        if isNothing maybeRI then 
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    82
            [Warning "No such rooms"]
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    83
            else if isRestrictedJoins jRoom then
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    84
            [Warning "Joining restricted"]
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    85
            else if roomPassword /= password jRoom then
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    86
            [Warning "Wrong password"]
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    87
            else
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    88
            [
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    89
                MoveToRoom jRI,
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    90
                AnswerClients (map sendChan $ cl : jRoomClients) ["NOT_READY", nick cl]
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    91
            ]
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    92
            ++ [ AnswerClients [sendChan cl] $ "JOINED" : map nick jRoomClients | playersIn jRoom /= 0]
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    93
            ++ (map (readynessMessage cl) jRoomClients)
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    94
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    95
    where
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    96
        readynessMessage cl c = AnswerClients [sendChan cl] [if isReady c then "READY" else "NOT_READY", nick c]
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    97
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    98
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    99
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
   100
{-
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   101
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2155
diff changeset
   102
handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, roomPassword]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   103
    | noSuchRoom = [Warning "No such room"]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   104
    | isRestrictedJoins jRoom = [Warning "Joining restricted"]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   105
    | roomPassword /= password jRoom = [Warning "Wrong password"]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   106
    | otherwise =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   107
        [RoomRemoveThisClient "", -- leave lobby
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   108
        RoomAddThisClient rID] -- join room
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   109
        ++ answerNicks
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   110
        ++ answerReady
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   111
        ++ [AnswerThisRoom ["NOT_READY", nick client]]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   112
        ++ answerFullConfig
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   113
        ++ answerTeams
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   114
        ++ watchRound
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   115
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   116
        answerNicks =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   117
            [AnswerThisClient $ "JOINED" :
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   118
            map (\clID -> nick $ clients IntMap.! clID) roomClientsIDs | playersIn jRoom /= 0]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   119
        answerReady = map
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   120
            ((\ c ->
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   121
                AnswerThisClient
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   122
                [if isReady c then "READY" else "NOT_READY", nick c])
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   123
            . (\ clID -> clients IntMap.! clID))
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   124
            roomClientsIDs
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   125
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   126
        toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 3283
diff changeset
   127
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   128
        answerFullConfig = map toAnswer (leftConfigPart ++ rightConfigPart)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   129
        (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p /= "MAP") (Map.toList $ params jRoom)
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   130
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   131
        watchRound = if not $ gameinprogress jRoom then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   132
                    []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   133
                else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   134
                    [AnswerThisClient  ["RUN_GAME"],
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   135
                    AnswerThisClient $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)]
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   136
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   137
        answerTeams = if gameinprogress jRoom then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   138
                answerAllTeams (clientProto client) (teamsAtStart jRoom)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   139
            else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   140
                answerAllTeams (clientProto client) (teams jRoom)
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   141
-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   142
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   143
handleCmd_lobby ["JOIN_ROOM", roomName] =
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   144
    handleCmd_lobby ["JOIN_ROOM", roomName, ""]
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 3283
diff changeset
   145
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   146
{-
2961
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   147
handleCmd_lobby clID clients rooms ["FOLLOW", asknick] =
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   148
    if noSuchClient || roomID followClient == 0 then
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   149
        []
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   150
    else
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   151
        handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName]
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   152
    where
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   153
        maybeClient = Foldable.find (\cl -> asknick == nick cl) clients
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   154
        noSuchClient = isNothing maybeClient
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   155
        followClient = fromJust maybeClient
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   156
        roomName = name $ rooms IntMap.! roomID followClient
3e057dfa601f Fix "FOLLOW" command handler and place it into proper file
unc0rr
parents: 2867
diff changeset
   157
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   158
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   159
    ---------------------------
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   160
    -- Administrator's stuff --
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   161
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   162
handleCmd_lobby clID clients rooms ["KICK", kickNick] =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   163
        [KickClient kickID | isAdministrator client && (not noSuchClient) && kickID /= clID]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   164
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   165
        client = clients IntMap.! clID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   166
        maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   167
        noSuchClient = isNothing maybeClient
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   168
        kickID = clientUID $ fromJust maybeClient
1866
36aa0ca6e8af Cut the length of most used net packet
unc0rr
parents: 1862
diff changeset
   169
36aa0ca6e8af Cut the length of most used net packet
unc0rr
parents: 1862
diff changeset
   170
36aa0ca6e8af Cut the length of most used net packet
unc0rr
parents: 1862
diff changeset
   171
handleCmd_lobby clID clients rooms ["BAN", banNick] =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   172
    if not $ isAdministrator client then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   173
        []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   174
    else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   175
        BanClient banNick : handleCmd_lobby clID clients rooms ["KICK", banNick]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   176
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   177
        client = clients IntMap.! clID
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   178
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   179
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   180
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   181
handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "MOTD_NEW", newMessage] =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   182
        [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator client]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   183
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   184
        client = clients IntMap.! clID
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1905
diff changeset
   185
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   186
handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "MOTD_OLD", newMessage] =
3260
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   187
        [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage}) | isAdministrator client]
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   188
    where
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   189
        client = clients IntMap.! clID
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   190
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   191
handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] =
3260
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   192
    [ModifyServerInfo (\si -> si{latestReleaseVersion = fromJust readNum}) | isAdministrator client && isJust readNum]
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   193
    where
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   194
        client = clients IntMap.! clID
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   195
        readNum = maybeRead protoNum :: Maybe Word16
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1905
diff changeset
   196
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   197
handleCmd_lobby clID clients rooms ["GET_SERVER_VAR"] =
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   198
    [SendServerVars | isAdministrator client]
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   199
    where
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   200
        client = clients IntMap.! clID
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   201
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   202
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2150
diff changeset
   203
handleCmd_lobby clID clients rooms ["CLEAR_ACCOUNTS_CACHE"] =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   204
        [ClearAccountsCache | isAdministrator client]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   205
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   206
        client = clients IntMap.! clID
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
   207
-}
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2150
diff changeset
   208
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2150
diff changeset
   209
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
   210
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]