gameServer/HWProtoLobbyState.hs
author unc0rr
Wed, 19 Jun 2013 00:52:21 +0400
branchwebgl
changeset 9264 21df1a0ec9ed
parent 9109 878f06e9c484
child 9303 457efde100b5
permissions -rw-r--r--
engine links
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
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
     4
import Data.Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
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
     6
import Control.Monad.Reader
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
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
    11
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
    12
import RoomsAndClients
6068
e18713ecf1e0 Introduce EngineInteraction module
unc0rr
parents: 5996
diff changeset
    13
import EngineInteraction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    15
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4984
diff changeset
    16
answerAllTeams :: ClientInfo -> [TeamInfo] -> [Action]
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    17
answerAllTeams cl = concatMap toAnswer
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    18
    where
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    19
        clChan = sendChan cl
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    20
        toAnswer team =
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    21
            [AnswerClients [clChan] $ teamToNet team,
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    22
            AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team],
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 4989
diff changeset
    23
            AnswerClients [clChan] ["HH_NUM", teamname team, showB $ hhnum team]]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    24
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
    25
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4984
diff changeset
    26
handleCmd_lobby :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
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
    28
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
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
    30
    (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
    31
    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
    32
    rooms <- allRoomInfos
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 6191
diff changeset
    33
    let roomsInfoList = concatMap (\r -> roomInfo (nick $ irnc `client` masterID r) r) . filter (\r -> (roomProto r == clientProto 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
    34
    return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    35
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
    36
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
    37
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
    38
    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
    39
    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
    40
    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
    41
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    42
handleCmd_lobby ["CREATE_ROOM", rName, roomPassword]
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    43
    | illegalName rName = return [Warning $ loc "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
    44
    | 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
    45
        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
    46
        cl <- thisClient
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    47
        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
    48
            [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
    49
            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
    50
            [
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    51
                AddRoom rName roomPassword
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    52
                , AnswerClients [sendChan cl] ["CLIENT_FLAGS", "+hr", nick cl]
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
    53
                , ModifyClient (\c -> c{isMaster = True, isReady = True, isJoinedMidGame = False})
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    54
                , ModifyRoom (\r -> r{readyPlayers = 1})
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
    55
            ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    57
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    58
handleCmd_lobby ["CREATE_ROOM", rName] =
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    59
    handleCmd_lobby ["CREATE_ROOM", rName, ""]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    60
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
    61
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
    62
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    63
    (_, 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
    64
    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
    65
    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
    66
    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
    67
    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
    68
    let jRoom = irnc `room` jRI
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
    69
    let sameProto = clientProto cl == roomProto jRoom
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    70
    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
    71
    let nicks = map nick jRoomClients
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    72
    let ownerNick = nick . fromJust $ find isMaster jRoomClients
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    73
    let chans = map sendChan (cl : jRoomClients)
7537
833a0c34fafc Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents: 7321
diff changeset
    74
    let isBanned = host cl `elem` roomBansList jRoom
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
    return $
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
    76
        if isNothing maybeRI || not sameProto then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    77
            [Warning $ loc "No such room"]
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
    78
            else if isRestrictedJoins jRoom then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    79
            [Warning $ loc "Joining restricted"]
8232
fb5aa767a2a0 "Registered users only" room flag
unc0rr
parents: 8156
diff changeset
    80
            else if isRegisteredOnly jRoom then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    81
            [Warning $ loc "Registered users only"]
7537
833a0c34fafc Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents: 7321
diff changeset
    82
            else if isBanned then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    83
            [Warning $ loc "You are banned in this room"]
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
    84
            else if roomPassword /= password jRoom then
6912
831416764d2d Allow LIST command while in room to not annoy old frontends (0.9.17 or less) with warnings
unc0rr
parents: 6541
diff changeset
    85
            [NoticeMessage WrongPassword]
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
    86
            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
    87
            [
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    88
                MoveToRoom jRI
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
    89
                , ModifyClient (\c -> c{isJoinedMidGame = isJust $ gameInfo jRoom})
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    90
                , AnswerClients [sendChan cl] $ "JOINED" : nicks
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    91
                , AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl]
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    92
                , AnswerClients [sendChan cl] $ ["CLIENT_FLAGS", "+h", ownerNick]
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
    93
            ]
8235
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
    94
            ++ (if clientProto cl < 38 then map (readynessMessage cl) jRoomClients else [sendStateFlags cl jRoomClients])
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
    95
            ++ answerFullConfig cl jRoom
8897
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8519
diff changeset
    96
            ++ answerTeams cl jRoom
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8519
diff changeset
    97
            ++ watchRound cl jRoom chans
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    98
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
    99
        where
8235
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   100
        readynessMessage cl c = AnswerClients [sendChan cl] [if isReady c then "READY" else "NOT_READY", nick c]
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   101
        sendStateFlags cl clients = AnswerClients [sendChan cl] . concat . intersperse [""] . filter (not . null) . concat $
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   102
                [f "+r" ready, f "-r" unready, f "+g" ingame, f "-g" inroomlobby]
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   103
            where
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   104
            (ready, unready) = partition isReady clients
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   105
            (ingame, inroomlobby) = partition isInGame clients
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   106
            f fl lst = ["CLIENT_FLAGS" : fl : map nick lst | not $ null lst]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   107
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
   108
        -- get config from gameInfo if possible, otherwise from room
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
   109
        answerFullConfig cl jRoom = let f r g = (if isJust $ gameInfo jRoom then g . fromJust . gameInfo else r) jRoom
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
   110
                                    in answerFullConfigParams cl (f mapParams giMapParams) (f params giParams)
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   111
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5931
diff changeset
   112
        answerTeams cl jRoom = let f = if isJust $ gameInfo jRoom then teamsAtStart . fromJust . gameInfo else teams in answerAllTeams cl $ f jRoom
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
   113
8237
4ab4f461086e Show others if spectator is in game
unc0rr
parents: 8235
diff changeset
   114
        watchRound cl jRoom chans = if isNothing $ gameInfo jRoom then
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   115
                    []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   116
                else
8237
4ab4f461086e Show others if spectator is in game
unc0rr
parents: 8235
diff changeset
   117
                    [AnswerClients [sendChan cl]  ["RUN_GAME"]
4ab4f461086e Show others if spectator is in game
unc0rr
parents: 8235
diff changeset
   118
                    , AnswerClients chans ["CLIENT_FLAGS", "+g", nick cl]
4ab4f461086e Show others if spectator is in game
unc0rr
parents: 8235
diff changeset
   119
                    , ModifyClient (\c -> c{isInGame = True})
8369
31033e521653 Throw away stupid Data.Seq
unc0rr
parents: 8237
diff changeset
   120
                    , AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : (reverse . roundMsgs . fromJust . gameInfo $ jRoom)]
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   121
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   122
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
   123
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
   124
    handleCmd_lobby ["JOIN_ROOM", roomName, ""]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
   125
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   126
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   127
handleCmd_lobby ["FOLLOW", asknick] = do
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   128
    (_, rnc) <- ask
8486
9a65baafd7d7 Send JOINING message in response to FOLLOW. Actual join may still fail due to room restrictions. Not tested.
unc0rr
parents: 8403
diff changeset
   129
    clChan <- liftM sendChan thisClient
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   130
    ci <- clientByNick asknick
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   131
    let ri = clientRoom rnc $ fromJust ci
8486
9a65baafd7d7 Send JOINING message in response to FOLLOW. Actual join may still fail due to room restrictions. Not tested.
unc0rr
parents: 8403
diff changeset
   132
    let roomName = name $ room rnc ri
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
   133
    if isNothing ci || ri == lobbyId then
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   134
        return []
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   135
        else
8486
9a65baafd7d7 Send JOINING message in response to FOLLOW. Actual join may still fail due to room restrictions. Not tested.
unc0rr
parents: 8403
diff changeset
   136
        liftM ((:) (AnswerClients [clChan] ["JOINING", roomName])) $ handleCmd_lobby ["JOIN_ROOM", roomName]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   137
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   138
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   139
handleCmd_lobby ("RND":rs) = do
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   140
    c <- liftM sendChan thisClient
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   141
    return [Random [c] rs]
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   142
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   143
    ---------------------------
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   144
    -- Administrator's stuff --
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   145
4618
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   146
handleCmd_lobby ["KICK", kickNick] = do
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   147
    (ci, _) <- ask
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   148
    cl <- thisClient
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   149
    kickId <- clientByNick kickNick
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   150
    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
   151
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   152
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8154
diff changeset
   153
handleCmd_lobby ["BAN", banNick, reason, duration] = do
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   154
    (ci, _) <- ask
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   155
    cl <- thisClient
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   156
    banId <- clientByNick banNick
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8154
diff changeset
   157
    return [BanClient (readInt_ duration) reason (fromJust banId) | isAdministrator cl && isJust banId && fromJust banId /= ci]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
   158
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   159
handleCmd_lobby ["BANIP", ip, reason, duration] = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   160
    cl <- thisClient
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   161
    return [BanIP ip (readInt_ duration) reason | isAdministrator cl]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
   162
8154
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   163
handleCmd_lobby ["BANNICK", n, reason, duration] = do
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   164
    cl <- thisClient
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   165
    return [BanNick n (readInt_ duration) reason | isAdministrator cl]
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   166
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   167
handleCmd_lobby ["BANLIST"] = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   168
    cl <- thisClient
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   169
    return [BanList | isAdministrator cl]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   170
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   171
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   172
handleCmd_lobby ["UNBAN", entry] = do
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   173
    cl <- thisClient
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   174
    return [Unban entry | isAdministrator cl]
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   175
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   176
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   177
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   178
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   179
    return [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator cl]
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1905
diff changeset
   180
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   181
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   182
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   183
    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
   184
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   185
handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   186
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   187
    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
   188
    where
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 4989
diff changeset
   189
        readNum = readInt_ protoNum
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
   190
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   191
handleCmd_lobby ["GET_SERVER_VAR"] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   192
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   193
    return [SendServerVars | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   194
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   195
handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   196
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   197
    return [ClearAccountsCache | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   198
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5093
diff changeset
   199
handleCmd_lobby ["RESTART_SERVER"] = do
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   200
    cl <- thisClient
7537
833a0c34fafc Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents: 7321
diff changeset
   201
    return [RestartServer | isAdministrator cl]
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   202
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   203
handleCmd_lobby ["STATS"] = do
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   204
    cl <- thisClient
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   205
    return [Stats | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   206
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
   207
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]