gameServer/HWProtoLobbyState.hs
author koda
Sun, 03 Nov 2013 22:54:02 +0100
branchspacecampaign
changeset 9647 2898b802a49e
parent 9448 04e0acfa7c2c
child 9702 27006953d901
permissions -rw-r--r--
close branch
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
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
    24
    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
    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
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
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
    29
    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
    30
    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
    31
    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
    32
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    33
handleCmd_lobby ["CREATE_ROOM", rName, roomPassword]
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    34
    | 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
    35
    | 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
    36
        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
    37
        cl <- thisClient
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    38
        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
    39
            [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
    40
            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
    41
            [
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    42
                AddRoom rName roomPassword
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    43
                , 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
    44
                , ModifyClient (\c -> c{isMaster = True, isReady = True, isJoinedMidGame = False})
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    45
                , 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
    46
            ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    48
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    49
handleCmd_lobby ["CREATE_ROOM", rName] =
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    50
    handleCmd_lobby ["CREATE_ROOM", rName, ""]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    51
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
    52
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
    53
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    54
    (_, 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
    55
    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
    56
    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
    57
    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
    58
    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
    59
    let jRoom = irnc `room` jRI
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
    60
    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
    61
    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
    62
    let nicks = map nick jRoomClients
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    63
    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
    64
    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
    65
    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
    66
    return $
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
    67
        if isNothing maybeRI || not sameProto then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    68
            [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
    69
            else if isRestrictedJoins jRoom then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    70
            [Warning $ loc "Joining restricted"]
9303
457efde100b5 Fix "registered only" option
unc0rr
parents: 9109
diff changeset
    71
            else if isRegisteredOnly jRoom && (B.null . webPassword $ cl) then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    72
            [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
    73
            else if isBanned then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    74
            [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
    75
            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
    76
            [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
    77
            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
    78
            [
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    79
                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
    80
                , ModifyClient (\c -> c{isJoinedMidGame = isJust $ gameInfo jRoom})
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    81
                , AnswerClients [sendChan cl] $ "JOINED" : nicks
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    82
                , AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl]
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
    83
                , 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
    84
            ]
8235
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
    85
            ++ (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
    86
            ++ answerFullConfig cl jRoom
8897
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8519
diff changeset
    87
            ++ answerTeams cl jRoom
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8519
diff changeset
    88
            ++ watchRound cl jRoom chans
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    89
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
    90
        where
8235
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
    91
        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
    92
        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
    93
                [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
    94
            where
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
    95
            (ready, unready) = partition isReady clients
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
    96
            (ingame, inroomlobby) = partition isInGame clients
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
    97
            f fl lst = ["CLIENT_FLAGS" : fl : map nick lst | not $ null lst]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    98
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
    99
        -- 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
   100
        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
   101
                                    in answerFullConfigParams cl (f mapParams giMapParams) (f params giParams)
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   102
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
   103
        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
   104
8237
4ab4f461086e Show others if spectator is in game
unc0rr
parents: 8235
diff changeset
   105
        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
   106
                    []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   107
                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
   108
                    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
   109
                    : 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
   110
                    : ModifyClient (\c -> c{isInGame = True})
9381
90f9d8046a86 Fix silliness from r3f4c3fc146c2 (was I sleepy?)
unc0rr
parents: 9304
diff changeset
   111
                    : [AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : (reverse . roundMsgs . fromJust . gameInfo $ jRoom)]
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   112
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   113
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
   114
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
   115
    handleCmd_lobby ["JOIN_ROOM", roomName, ""]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
   116
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   117
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   118
handleCmd_lobby ["FOLLOW", asknick] = do
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   119
    (_, 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
   120
    clChan <- liftM sendChan thisClient
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   121
    ci <- clientByNick asknick
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   122
    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
   123
    let roomName = name $ room rnc ri
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
   124
    if isNothing ci || ri == lobbyId then
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   125
        return []
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   126
        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
   127
        liftM ((:) (AnswerClients [clChan] ["JOINING", roomName])) $ handleCmd_lobby ["JOIN_ROOM", roomName]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   128
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   129
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   130
handleCmd_lobby ("RND":rs) = do
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   131
    c <- liftM sendChan thisClient
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   132
    return [Random [c] rs]
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   133
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   134
    ---------------------------
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   135
    -- Administrator's stuff --
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   136
4618
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   137
handleCmd_lobby ["KICK", kickNick] = do
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   138
    (ci, _) <- ask
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   139
    cl <- thisClient
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   140
    kickId <- clientByNick kickNick
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   141
    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
   142
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   143
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8154
diff changeset
   144
handleCmd_lobby ["BAN", banNick, reason, duration] = do
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   145
    (ci, _) <- ask
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   146
    cl <- thisClient
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   147
    banId <- clientByNick banNick
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8154
diff changeset
   148
    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
   149
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   150
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
   151
    cl <- thisClient
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   152
    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
   153
8154
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   154
handleCmd_lobby ["BANNICK", n, reason, duration] = do
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   155
    cl <- thisClient
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   156
    return [BanNick n (readInt_ duration) reason | isAdministrator cl]
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   157
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   158
handleCmd_lobby ["BANLIST"] = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   159
    cl <- thisClient
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   160
    return [BanList | isAdministrator cl]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   161
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   162
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   163
handleCmd_lobby ["UNBAN", entry] = do
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   164
    cl <- thisClient
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   165
    return [Unban entry | isAdministrator cl]
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   166
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   167
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   168
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   169
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   170
    return [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator cl]
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1905
diff changeset
   171
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   172
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   173
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   174
    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
   175
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   176
handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   177
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   178
    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
   179
    where
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 4989
diff changeset
   180
        readNum = readInt_ protoNum
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
   181
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   182
handleCmd_lobby ["GET_SERVER_VAR"] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   183
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   184
    return [SendServerVars | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   185
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   186
handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   187
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   188
    return [ClearAccountsCache | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   189
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5093
diff changeset
   190
handleCmd_lobby ["RESTART_SERVER"] = do
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   191
    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
   192
    return [RestartServer | isAdministrator cl]
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   193
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   194
handleCmd_lobby ["STATS"] = do
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   195
    cl <- thisClient
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   196
    return [Stats | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   197
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
   198
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]