gameServer/HWProtoLobbyState.hs
author sheepluva
Wed, 05 Sep 2012 12:36:47 +0200
changeset 7673 e06b83cbde74
parent 7668 4cb423f42105
child 7677 f63c55db82eb
permissions -rw-r--r--
fix a segfault related to tcp servers deleting themselves without removing themselves from the internal server list first. (e.g. happens if game fails to start due to missing hwengine binary. a second start attempt will lead to a segfault, even if you correctly install the binary.)
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     1
{-# LANGUAGE OverloadedStrings #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module HWProtoLobbyState where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import qualified Data.Map as Map
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
     5
import qualified Data.Foldable as Foldable
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     6
import Data.Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Data.List
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     8
import Control.Monad.Reader
7668
4cb423f42105 Show who is the room admin on join (no tested, also I don't like how it is done via server warnings, but it seems there's no other solution compatible with .17)
unc0rr
parents: 7537
diff changeset
     9
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import Utils
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    14
import HandlerUtils
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    15
import RoomsAndClients
6068
e18713ecf1e0 Introduce EngineInteraction module
unc0rr
parents: 5996
diff changeset
    16
import EngineInteraction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    18
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4984
diff changeset
    19
answerAllTeams :: ClientInfo -> [TeamInfo] -> [Action]
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    20
answerAllTeams cl = concatMap toAnswer
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    21
    where
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    22
        clChan = sendChan cl
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
    23
        toAnswer team =
4591
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    24
            [AnswerClients [clChan] $ teamToNet team,
c91364bf6a69 Send teams info on join
unc0rr
parents: 4587
diff changeset
    25
            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
    26
            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
    27
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
    28
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4984
diff changeset
    29
handleCmd_lobby :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
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
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
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
    33
    (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
    34
    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
    35
    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
    36
    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
    37
    return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    38
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
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
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
    41
    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
    42
    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
    43
    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
    44
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    45
handleCmd_lobby ["CREATE_ROOM", rName, roomPassword]
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    46
    | illegalName rName = return [Warning "Illegal room name"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    47
    | 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
    48
        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
    49
        cl <- thisClient
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    50
        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
    51
            [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
    52
            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
    53
            [
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    54
                AddRoom rName roomPassword,
4917
8ff92bdc9f98 Convert READY and NOT_READY messages to CLIENT_FLAGS message
unc0rr
parents: 4914
diff changeset
    55
                AnswerClients [sendChan cl] ["CLIENT_FLAGS", "-r", nick cl]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    56
            ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    58
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    59
handleCmd_lobby ["CREATE_ROOM", rName] =
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    60
    handleCmd_lobby ["CREATE_ROOM", rName, ""]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    61
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
    62
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    63
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    64
    (_, 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
    65
    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
    66
    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
    67
    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
    68
    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
    69
    let jRoom = irnc `room` jRI
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
    70
    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
    71
    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
    72
    let nicks = map nick jRoomClients
7668
4cb423f42105 Show who is the room admin on join (no tested, also I don't like how it is done via server warnings, but it seems there's no other solution compatible with .17)
unc0rr
parents: 7537
diff changeset
    73
    let owner = fromJust $ find isMaster jRoomClients
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    74
    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
    75
    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
    76
    return $
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
    77
        if isNothing maybeRI || not sameProto then
6191
190a8e5d9956 Case-insensitive comparison of nicks
unc0rr
parents: 6068
diff changeset
    78
            [Warning "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
    79
            else if isRestrictedJoins jRoom then
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    80
            [Warning "Joining restricted"]
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
    81
            else if isBanned then
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
            [Warning "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
    83
            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
    84
            [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
    85
            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
    86
            [
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
                MoveToRoom jRI,
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    88
                AnswerClients [sendChan cl] $ "JOINED" : nicks,
7668
4cb423f42105 Show who is the room admin on join (no tested, also I don't like how it is done via server warnings, but it seems there's no other solution compatible with .17)
unc0rr
parents: 7537
diff changeset
    89
                AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl],
4cb423f42105 Show who is the room admin on join (no tested, also I don't like how it is done via server warnings, but it seems there's no other solution compatible with .17)
unc0rr
parents: 7537
diff changeset
    90
                AnswerClients [sendChan cl] $ ["WARNING", "Room owner is " `B.append` nick owner]
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
    91
            ]
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    92
            ++ map (readynessMessage cl) jRoomClients
4941
90572c338e60 Fix for my last commit (which was all nonsense)
unc0rr
parents: 4936
diff changeset
    93
            ++ answerFullConfig cl (mapParams jRoom) (params jRoom)
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    94
            ++ answerTeams cl jRoom
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    95
            ++ watchRound cl jRoom
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    96
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
    97
        where
4942
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
    98
        readynessMessage cl c = AnswerClients [sendChan cl] $
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
    99
                if clientProto cl < 38 then
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   100
                    [if isReady c then "READY" else "NOT_READY", nick c]
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   101
                    else
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   102
                    ["CLIENT_FLAGS", if isReady c then "+r" else "-r", nick c]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   103
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   104
        toAnswer cl (paramName, paramStrs) = AnswerClients [sendChan cl] $ "CFG" : paramName : paramStrs
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   105
4942
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   106
        answerFullConfig cl mpr pr
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   107
            | clientProto cl < 38 = map (toAnswer cl) $
4984
20da3c5c7dee Fix build
unc0rr
parents: 4983
diff changeset
   108
                 (reverse . map (\(a, b) -> (a, [b])) $ Map.toList mpr)
4942
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   109
                 ++ (("SCHEME", pr Map.! "SCHEME")
4984
20da3c5c7dee Fix build
unc0rr
parents: 4983
diff changeset
   110
                 : (filter (\(p, _) -> p /= "SCHEME") $ Map.toList pr))
4942
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   111
1c85a8e6e11c Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents: 4941
diff changeset
   112
            | otherwise = map (toAnswer cl) $
4941
90572c338e60 Fix for my last commit (which was all nonsense)
unc0rr
parents: 4936
diff changeset
   113
                 ("FULLMAPCONFIG", Map.elems mpr)
4936
d65d438acd23 Merge MAP, MAPGEN and SEED params into one on room join, so engine isn't spawned three times for a preview. Not tested as I'm unable to see my rooms (why?)
unc0rr
parents: 4932
diff changeset
   114
                 : ("SCHEME", pr Map.! "SCHEME")
4941
90572c338e60 Fix for my last commit (which was all nonsense)
unc0rr
parents: 4936
diff changeset
   115
                 : (filter (\(p, _) -> p /= "SCHEME") $ Map.toList pr)
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   116
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
   117
        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
   118
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
   119
        watchRound cl jRoom = if isNothing $ gameInfo jRoom then
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   120
                    []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   121
                else
4595
cd4433b44920 Send spectators info
unc0rr
parents: 4591
diff changeset
   122
                    [AnswerClients [sendChan cl]  ["RUN_GAME"],
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
   123
                    AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs . fromJust . gameInfo $ jRoom)]
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   124
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   125
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
   126
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
   127
    handleCmd_lobby ["JOIN_ROOM", roomName, ""]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
   128
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   129
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   130
handleCmd_lobby ["FOLLOW", asknick] = do
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   131
    (_, rnc) <- ask
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   132
    ci <- clientByNick asknick
5573
cc409ee3ad2e Don't allow to join other protocol room using FOLLOW command (not tested)
unc0rr
parents: 5426
diff changeset
   133
    cl <- thisClient
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   134
    let ri = clientRoom rnc $ fromJust ci
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   135
    let clRoom = room rnc ri
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
   136
    if isNothing ci || ri == lobbyId then
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   137
        return []
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   138
        else
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   139
        handleCmd_lobby ["JOIN_ROOM", name clRoom]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   140
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   141
    ---------------------------
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   142
    -- Administrator's stuff --
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   143
4618
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   144
handleCmd_lobby ["KICK", kickNick] = do
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   145
    (ci, _) <- ask
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   146
    cl <- thisClient
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   147
    kickId <- clientByNick kickNick
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   148
    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
   149
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   150
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   151
handleCmd_lobby ["BAN", banNick, reason] = do
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   152
    (ci, _) <- ask
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   153
    cl <- thisClient
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   154
    banId <- clientByNick banNick
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   155
    return [BanClient 60 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
   156
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   157
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
   158
    (ci, _) <- ask
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 [BanIP ip (readInt_ duration) reason | isAdministrator cl]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
   161
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   162
handleCmd_lobby ["BANLIST"] = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   163
    (ci, _) <- ask
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   164
    cl <- thisClient
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   165
    return [BanList | isAdministrator cl]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   166
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
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
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   194
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
   195
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]