gameServer/HWProtoLobbyState.hs
author sheepluva
Sun, 09 Feb 2014 18:35:11 +0100
changeset 10125 7a77a819a94d
parent 10092 a92a4ba39a79
child 10212 5fb3bb2de9d2
permissions -rw-r--r--
fix misleading indentation
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
9303
457efde100b5 Fix "registered only" option
unc0rr
parents: 9109
diff changeset
     7
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
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
    12
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
    13
import RoomsAndClients
6068
e18713ecf1e0 Introduce EngineInteraction module
unc0rr
parents: 5996
diff changeset
    14
import EngineInteraction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    16
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4984
diff changeset
    17
handleCmd_lobby :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
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
    19
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
    20
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
    21
    (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
    22
    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
    23
    rooms <- allRoomInfos
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9729
diff changeset
    24
    let roomsInfoList = concatMap (\r -> roomInfo (clientProto cl) (maybeNick . liftM (client irnc) $ 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
    25
    return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    26
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
    27
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
    28
    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
    29
    s <- roomOthersChans
10092
a92a4ba39a79 Fix build
unc0rr
parents: 9787
diff changeset
    30
    return [AnswerClients s ["CHAT", n, msg], RegisterEvent LobbyChatMessage]
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
    31
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    32
handleCmd_lobby ["CREATE_ROOM", rName, roomPassword]
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    33
    | 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
    34
    | 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
    35
        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
    36
        cl <- thisClient
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    37
        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
    38
            [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
    39
            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
    40
            [
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    41
                AddRoom rName roomPassword
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    42
                , 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
    43
                , ModifyClient (\c -> c{isMaster = True, isReady = True, isJoinedMidGame = False})
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    44
                , 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
    45
            ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    47
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    48
handleCmd_lobby ["CREATE_ROOM", rName] =
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    49
    handleCmd_lobby ["CREATE_ROOM", rName, ""]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    50
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
    51
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
    52
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    53
    (_, 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
    54
    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
    55
    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
    56
    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
    57
    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
    58
    let jRoom = irnc `room` jRI
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
    59
    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
    60
    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
    61
    let nicks = map nick jRoomClients
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9729
diff changeset
    62
    let owner = find isMaster jRoomClients
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    63
    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
    64
    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
    65
    return $
9729
6a3640c4f4b7 Show "incompatible version" message instead of "no such room" on try to join room with another protocol version
unc0rr
parents: 9702
diff changeset
    66
        if isNothing maybeRI then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    67
            [Warning $ loc "No such room"]
9729
6a3640c4f4b7 Show "incompatible version" message instead of "no such room" on try to join room with another protocol version
unc0rr
parents: 9702
diff changeset
    68
            else if not sameProto then
6a3640c4f4b7 Show "incompatible version" message instead of "no such room" on try to join room with another protocol version
unc0rr
parents: 9702
diff changeset
    69
            [Warning $ loc "Room version incompatible to your hedgewars version"]
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
    70
            else if isRestrictedJoins jRoom then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    71
            [Warning $ loc "Joining restricted"]
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9729
diff changeset
    72
            else if isRegisteredOnly jRoom && (B.null . webPassword $ cl) && not (isAdministrator cl) then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    73
            [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
    74
            else if isBanned then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    75
            [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
    76
            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
    77
            [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
    78
            else
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9729
diff changeset
    79
            (
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    80
                MoveToRoom jRI
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9729
diff changeset
    81
                : ModifyClient (\c -> c{isJoinedMidGame = isJust $ gameInfo jRoom})
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9729
diff changeset
    82
                : AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl]
9787
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
    83
                : [(AnswerClients [sendChan cl] $ "JOINED" : nicks) | not $ null nicks]
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9729
diff changeset
    84
            )
9787
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
    85
            ++ [AnswerClients [sendChan cl] ["CLIENT_FLAGS", "+h", nick $ fromJust owner] | isJust owner]
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
    86
            ++ [sendStateFlags cl jRoomClients | not $ null jRoomClients]
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
    87
            ++ answerFullConfig cl jRoom
8897
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8519
diff changeset
    88
            ++ answerTeams cl jRoom
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8519
diff changeset
    89
            ++ watchRound cl jRoom chans
9787
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
    90
            ++ [AnswerClients [sendChan cl] ["CHAT", "[greeting]", greeting jRoom] | greeting jRoom /= ""]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    91
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
    92
        where
8235
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
    93
        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
    94
                [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
    95
            where
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
    96
            (ready, unready) = partition isReady clients
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
    97
            (ingame, inroomlobby) = partition isInGame clients
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
    98
            f fl lst = ["CLIENT_FLAGS" : fl : map nick lst | not $ null lst]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    99
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
   100
        -- 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
   101
        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
   102
                                    in answerFullConfigParams cl (f mapParams giMapParams) (f params giParams)
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   103
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
   104
        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
   105
8237
4ab4f461086e Show others if spectator is in game
unc0rr
parents: 8235
diff changeset
   106
        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
   107
                    []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   108
                else
9304
3f4c3fc146c2 Fix spectator desync in rare conditions (there was team which left during its turn, and last command with timestamp from it was '+')
unc0rr
parents: 9303
diff changeset
   109
                    AnswerClients [sendChan cl]  ["RUN_GAME"]
3f4c3fc146c2 Fix spectator desync in rare conditions (there was team which left during its turn, and last command with timestamp from it was '+')
unc0rr
parents: 9303
diff changeset
   110
                    : AnswerClients chans ["CLIENT_FLAGS", "+g", nick cl]
3f4c3fc146c2 Fix spectator desync in rare conditions (there was team which left during its turn, and last command with timestamp from it was '+')
unc0rr
parents: 9303
diff changeset
   111
                    : ModifyClient (\c -> c{isInGame = True})
9381
90f9d8046a86 Fix silliness from r3f4c3fc146c2 (was I sleepy?)
unc0rr
parents: 9304
diff changeset
   112
                    : [AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : (reverse . roundMsgs . fromJust . gameInfo $ jRoom)]
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   113
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   114
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
   115
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
   116
    handleCmd_lobby ["JOIN_ROOM", roomName, ""]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
   117
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   118
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   119
handleCmd_lobby ["FOLLOW", asknick] = do
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   120
    (_, 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
   121
    clChan <- liftM sendChan thisClient
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   122
    ci <- clientByNick asknick
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   123
    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
   124
    let roomName = name $ room rnc ri
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
   125
    if isNothing ci || ri == lobbyId then
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   126
        return []
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   127
        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
   128
        liftM ((:) (AnswerClients [clChan] ["JOINING", roomName])) $ handleCmd_lobby ["JOIN_ROOM", roomName]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   129
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   130
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   131
handleCmd_lobby ("RND":rs) = do
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   132
    c <- liftM sendChan thisClient
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   133
    return [Random [c] rs]
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   134
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   135
    ---------------------------
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   136
    -- Administrator's stuff --
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   137
4618
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   138
handleCmd_lobby ["KICK", kickNick] = do
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   139
    (ci, _) <- ask
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   140
    cl <- thisClient
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   141
    kickId <- clientByNick kickNick
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   142
    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
   143
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   144
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8154
diff changeset
   145
handleCmd_lobby ["BAN", banNick, reason, duration] = do
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   146
    (ci, _) <- ask
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   147
    cl <- thisClient
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   148
    banId <- clientByNick banNick
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8154
diff changeset
   149
    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
   150
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   151
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
   152
    cl <- thisClient
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   153
    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
   154
8154
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   155
handleCmd_lobby ["BANNICK", n, reason, duration] = do
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   156
    cl <- thisClient
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   157
    return [BanNick n (readInt_ duration) reason | isAdministrator cl]
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
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 ["BANLIST"] = 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 [BanList | isAdministrator cl]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   162
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   163
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   164
handleCmd_lobby ["UNBAN", entry] = do
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   165
    cl <- thisClient
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   166
    return [Unban entry | isAdministrator cl]
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   167
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   168
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   169
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = 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 [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator cl]
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1905
diff changeset
   172
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   173
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = 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 [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
   176
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   177
handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = 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{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
   180
    where
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 4989
diff changeset
   181
        readNum = readInt_ protoNum
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
   182
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   183
handleCmd_lobby ["GET_SERVER_VAR"] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   184
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   185
    return [SendServerVars | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   186
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   187
handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   188
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   189
    return [ClearAccountsCache | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   190
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5093
diff changeset
   191
handleCmd_lobby ["RESTART_SERVER"] = do
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   192
    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
   193
    return [RestartServer | isAdministrator cl]
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   194
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   195
handleCmd_lobby ["STATS"] = do
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   196
    cl <- thisClient
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   197
    return [Stats | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   198
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
   199
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]