gameServer/HWProtoLobbyState.hs
author unc0rr
Tue, 08 Feb 2011 22:24:30 +0300
changeset 4936 d65d438acd23
parent 4932 f11d80bac7ed
child 4941 90572c338e60
permissions -rw-r--r--
Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
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
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
     5
import qualified Data.Foldable as Foldable
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     6
import Data.Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Data.List
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     8
import Control.Monad.Reader
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     9
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import Utils
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    14
import HandlerUtils
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    15
import RoomsAndClients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    17
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    18
answerAllTeams :: ClientInfo -> [TeamInfo] -> [Action]
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    19
answerAllTeams cl = concatMap toAnswer
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    20
    where
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    21
        clChan = sendChan cl
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    22
        toAnswer team =
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    23
            [AnswerClients [clChan] $ teamToNet team,
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    24
            AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team],
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    25
            AnswerClients [clChan] ["HH_NUM", teamname team, B.pack . show $ hhnum team]]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    26
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
handleCmd_lobby :: CmdHandler
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    29
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    30
handleCmd_lobby ["LIST"] = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    31
    (ci, irnc) <- ask
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    32
    let cl = irnc `client` ci
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    33
    rooms <- allRoomInfos
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    34
    let roomsInfoList = concatMap (roomInfo irnc) . filter (\r -> (roomProto r == clientProto cl) && not (isRestrictedJoins r))
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    35
    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
    36
    where
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    37
        roomInfo irnc r = [
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    38
                showB $ gameinprogress r,
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    39
                name r,
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    40
                showB $ playersIn r,
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    41
                showB $ length $ teams r,
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    42
                nick $ irnc `client` masterID r,
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    43
                head (Map.findWithDefault ["+gen+"] "MAP" (params r)),
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    44
                head (Map.findWithDefault ["Default"] "SCHEME" (params r)),
4936
d65d438acd23 Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
unc0rr
parents: 4932
diff changeset
    45
                head (Map.findWithDefault ["Default"] "AMMO" (params r)),
d65d438acd23 Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
unc0rr
parents: 4932
diff changeset
    46
                head (Map.findWithDefault ["Default"] "SCHEME" (params r)),
d65d438acd23 Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
unc0rr
parents: 4932
diff changeset
    47
                head (Map.findWithDefault ["0"] "MAPGEN" (params r)),
d65d438acd23 Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
unc0rr
parents: 4932
diff changeset
    48
                head (Map.findWithDefault ["seed"] "SEED" (params r))
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    49
                ]
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    50
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    51
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    52
handleCmd_lobby ["CHAT", msg] = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    53
    n <- clientNick
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    54
    s <- roomOthersChans
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    55
    return [AnswerClients s ["CHAT", n, msg]]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    56
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    57
handleCmd_lobby ["CREATE_ROOM", rName, roomPassword]
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    58
    | illegalName rName = return [Warning "Illegal room name"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    59
    | otherwise = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    60
        rs <- allRoomInfos
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    61
        cl <- thisClient
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    62
        return $ if isJust $ find (\r -> rName == name r) rs then
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    63
            [Warning "Room exists"]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    64
            else
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    65
            [
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    66
                AddRoom rName roomPassword,
4917
8ff92bdc9f98 Convert READY and NOT_READY messages to CLIENT_FLAGS message
unc0rr
parents: 4914
diff changeset
    67
                AnswerClients [sendChan cl] ["CLIENT_FLAGS", "-r", nick cl]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    68
            ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    69
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    70
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    71
handleCmd_lobby ["CREATE_ROOM", rName] =
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    72
    handleCmd_lobby ["CREATE_ROOM", rName, ""]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    73
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
    74
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    75
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    76
    (_, irnc) <- ask
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    77
    let ris = allRooms irnc
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    78
    cl <- thisClient
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    79
    let maybeRI = find (\ri -> roomName == name (irnc `room` ri)) ris
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    80
    let jRI = fromJust maybeRI
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    81
    let jRoom = irnc `room` jRI
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    82
    let jRoomClients = map (client irnc) $ roomClients irnc jRI
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    83
    let nicks = map nick jRoomClients
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    84
    let chans = map sendChan (cl : jRoomClients)
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    85
    return $
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    86
        if isNothing maybeRI then 
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    87
            [Warning "No such rooms"]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    88
            else if isRestrictedJoins jRoom then
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    89
            [Warning "Joining restricted"]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    90
            else if roomPassword /= password jRoom then
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    91
            [Warning "Wrong password"]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    92
            else
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    93
            [
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    94
                MoveToRoom jRI,
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    95
                AnswerClients [sendChan cl] $ "JOINED" : nicks,
4917
8ff92bdc9f98 Convert READY and NOT_READY messages to CLIENT_FLAGS message
unc0rr
parents: 4914
diff changeset
    96
                AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    97
            ]
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    98
            ++ map (readynessMessage cl) jRoomClients
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    99
            ++ answerFullConfig cl (params jRoom)
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
   100
            ++ answerTeams cl jRoom
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
   101
            ++ watchRound cl jRoom
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   102
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   103
        where
4917
8ff92bdc9f98 Convert READY and NOT_READY messages to CLIENT_FLAGS message
unc0rr
parents: 4914
diff changeset
   104
        readynessMessage cl c = AnswerClients [sendChan cl] ["CLIENT_FLAGS", if isReady c then "+r" else "-r", nick c]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   105
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   106
        toAnswer cl (paramName, paramStrs) = AnswerClients [sendChan cl] $ "CFG" : paramName : paramStrs
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   107
4936
d65d438acd23 Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
unc0rr
parents: 4932
diff changeset
   108
        answerFullConfig cl pr = map (toAnswer cl) $
d65d438acd23 Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
unc0rr
parents: 4932
diff changeset
   109
                 ("FULLMAPCONFIG", concatMap ((Map.!) pr) ["MAP", "MAPGEN", "SEED"])
d65d438acd23 Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
unc0rr
parents: 4932
diff changeset
   110
                 : ("SCHEME", pr Map.! "SCHEME")
d65d438acd23 Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
unc0rr
parents: 4932
diff changeset
   111
                 : (filter (\(p, _) -> p /= "SCHEME" && p /= "MAP" && p /= "MAPGEN" && p /= "SEED") $ Map.toList pr)
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   112
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
   113
        answerTeams cl jRoom = let f = if gameinprogress jRoom then teamsAtStart else teams in answerAllTeams cl $ f jRoom
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
   114
4595
cd4433b44920 Send spectators info
unc0rr
parents: 4591
diff changeset
   115
        watchRound cl jRoom = if not $ gameinprogress jRoom then
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   116
                    []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   117
                else
4595
cd4433b44920 Send spectators info
unc0rr
parents: 4591
diff changeset
   118
                    [AnswerClients [sendChan cl]  ["RUN_GAME"],
cd4433b44920 Send spectators info
unc0rr
parents: 4591
diff changeset
   119
                    AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)]
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   120
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   121
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   122
handleCmd_lobby ["JOIN_ROOM", roomName] =
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   123
    handleCmd_lobby ["JOIN_ROOM", roomName, ""]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
   124
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   125
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   126
handleCmd_lobby ["FOLLOW", asknick] = do
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   127
    (_, rnc) <- ask
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   128
    ci <- clientByNick asknick
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   129
    let ri = clientRoom rnc $ fromJust ci
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   130
    let clRoom = room rnc ri
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   131
    if isNothing ci || ri == lobbyId then
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   132
        return []
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   133
        else
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   134
        handleCmd_lobby ["JOIN_ROOM", name clRoom]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   135
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   136
    ---------------------------
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   137
    -- Administrator's stuff --
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   138
4618
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   139
handleCmd_lobby ["KICK", kickNick] = do
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   140
    (ci, _) <- ask
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   141
    cl <- thisClient
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   142
    kickId <- clientByNick kickNick
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   143
    return [KickClient $ fromJust kickId | isAdministrator cl && isJust kickId && fromJust kickId /= ci]
1866
36aa0ca6e8af Cut the length of most used net packet
unc0rr
parents: 1862
diff changeset
   144
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   145
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   146
handleCmd_lobby ["BAN", banNick, reason] = do
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   147
    (ci, _) <- ask
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   148
    cl <- thisClient
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   149
    banId <- clientByNick banNick
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   150
    return [BanClient 60 reason (fromJust banId) | isAdministrator cl && isJust banId && fromJust banId /= ci]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   151
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   152
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   153
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   154
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   155
    return [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator cl]
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1905
diff changeset
   156
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   157
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   158
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   159
    return [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage}) | isAdministrator cl]
3260
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   160
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   161
handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   162
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   163
    return [ModifyServerInfo (\si -> si{latestReleaseVersion = readNum}) | isAdministrator cl && readNum > 0]
3260
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   164
    where
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   165
        readNum = case B.readInt protoNum of
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   166
                       Just (i, t) | B.null t -> fromIntegral i
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
   167
                       _ -> 0
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1905
diff changeset
   168
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   169
handleCmd_lobby ["GET_SERVER_VAR"] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   170
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   171
    return [SendServerVars | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   172
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   173
handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   174
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   175
    return [ClearAccountsCache | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   176
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   177
handleCmd_lobby ["RESTART_SERVER", restartType] = do
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   178
    cl <- thisClient
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   179
    return [RestartServer f | let f = restartType == "FORCE", isAdministrator cl]
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   180
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   181
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
   182
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]