gameServer/HWProtoLobbyState.hs
author Wuzzy <Wuzzy2@mail.ru>
Sat, 21 Oct 2017 02:28:36 +0200
changeset 12726 54300512e742
parent 12114 cdadc1d487f1
child 13079 81c154fd4380
permissions -rw-r--r--
Fix small German typo
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
     2
 * Hedgewars, a free turn based strategy game
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 11032
diff changeset
     3
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
     5
 * This program is free software; you can redistribute it and/or modify
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
     6
 * it under the terms of the GNU General Public License as published by
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
     9
 * This program is distributed in the hope that it will be useful,
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
    10
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
    14
 * You should have received a copy of the GNU General Public License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
    15
 * along with this program; if not, write to the Free Software
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
    16
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
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
{-# LANGUAGE OverloadedStrings #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
module HWProtoLobbyState where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
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
    22
import Data.Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
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
    24
import Control.Monad.Reader
9303
457efde100b5 Fix "registered only" option
unc0rr
parents: 9109
diff changeset
    25
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
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
    29
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
    30
import RoomsAndClients
6068
e18713ecf1e0 Introduce EngineInteraction module
unc0rr
parents: 5996
diff changeset
    31
import EngineInteraction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    33
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4984
diff changeset
    34
handleCmd_lobby :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    36
11464
a9957113404a Allow only one query per session
unc0rr
parents: 11463
diff changeset
    37
handleCmd_lobby ["LIST"] = do
a9957113404a Allow only one query per session
unc0rr
parents: 11463
diff changeset
    38
    (ci, irnc) <- ask
a9957113404a Allow only one query per session
unc0rr
parents: 11463
diff changeset
    39
    let cl = irnc `client` ci
a9957113404a Allow only one query per session
unc0rr
parents: 11463
diff changeset
    40
    rooms <- allRoomInfos
a9957113404a Allow only one query per session
unc0rr
parents: 11463
diff changeset
    41
    let roomsInfoList = concatMap (\r -> roomInfo (clientProto cl) (maybeNick . liftM (client irnc) $ masterID r) r) . filter (\r -> (roomProto r == clientProto cl))
a9957113404a Allow only one query per session
unc0rr
parents: 11463
diff changeset
    42
    return $ if hasAskedList cl then [] else
a9957113404a Allow only one query per session
unc0rr
parents: 11463
diff changeset
    43
        [ ModifyClient (\c -> c{hasAskedList = True})
a9957113404a Allow only one query per session
unc0rr
parents: 11463
diff changeset
    44
        , AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    45
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
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
    47
    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
    48
    s <- roomOthersChans
10092
a92a4ba39a79 Fix build
unc0rr
parents: 9787
diff changeset
    49
    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
    50
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    51
handleCmd_lobby ["CREATE_ROOM", rName, roomPassword]
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    52
    | 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
    53
    | 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
    54
        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
    55
        cl <- thisClient
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    56
        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
    57
            [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
    58
            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
    59
            [
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    60
                AddRoom rName roomPassword
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    61
                , 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
    62
                , ModifyClient (\c -> c{isMaster = True, isReady = True, isJoinedMidGame = False})
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    63
                , 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
    64
            ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    66
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    67
handleCmd_lobby ["CREATE_ROOM", rName] =
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    68
    handleCmd_lobby ["CREATE_ROOM", rName, ""]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    69
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
    70
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
    71
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    72
    (_, irnc) <- ask
10342
16122539d2ea Fix build, and also make protocol a bit more consistent and flexible (only in docs though, to be implemented)
unc0rr
parents: 10338
diff changeset
    73
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
    74
    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
    75
    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
    76
    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
    77
    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
    78
    let jRoom = irnc `room` jRI
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
    79
    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
    80
    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
    81
    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
    82
    let owner = find isMaster jRoomClients
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    83
    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
    84
    let isBanned = host cl `elem` roomBansList jRoom
10342
16122539d2ea Fix build, and also make protocol a bit more consistent and flexible (only in docs though, to be implemented)
unc0rr
parents: 10338
diff changeset
    85
    let clTeams =
12114
cdadc1d487f1 Only registered players regain their teams on rejoin
unc0rr
parents: 11467
diff changeset
    86
            if (clientProto cl >= 48) && (isJust $ gameInfo jRoom) && isRegistered cl then
11056
62cc7f67105f Restore player clan on rejoin (issue 934, not tested)
unc0rr
parents: 11055
diff changeset
    87
                filter (\t -> teamowner t == nick cl) . teamsAtStart . fromJust $ gameInfo jRoom 
10342
16122539d2ea Fix build, and also make protocol a bit more consistent and flexible (only in docs though, to be implemented)
unc0rr
parents: 10338
diff changeset
    88
                else
16122539d2ea Fix build, and also make protocol a bit more consistent and flexible (only in docs though, to be implemented)
unc0rr
parents: 10338
diff changeset
    89
                []
11056
62cc7f67105f Restore player clan on rejoin (issue 934, not tested)
unc0rr
parents: 11055
diff changeset
    90
    let clTeamsNames = map teamname clTeams
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
    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
    92
        if isNothing maybeRI then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    93
            [Warning $ loc "No such room"]
10337
05a5762ab12c Allow server admins to join room of another protocol version
unc0rr
parents: 10212
diff changeset
    94
            else if (not sameProto) && (not $ isAdministrator cl) then
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
    95
            [Warning $ loc "Room version incompatible to your hedgewars version"]
11467
f2c36df8c7b1 Allow server admins to join passworded/restricted rooms when it is really needed
unc0rr
parents: 11464
diff changeset
    96
            else if isRestrictedJoins jRoom && not (hasSuperPower cl) then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    97
            [Warning $ loc "Joining restricted"]
12114
cdadc1d487f1 Only registered players regain their teams on rejoin
unc0rr
parents: 11467
diff changeset
    98
            else if isRegisteredOnly jRoom && (not $ isRegistered cl) && not (isAdministrator cl) then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    99
            [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
   100
            else if isBanned then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
   101
            [Warning $ loc "You are banned in this room"]
11467
f2c36df8c7b1 Allow server admins to join passworded/restricted rooms when it is really needed
unc0rr
parents: 11464
diff changeset
   102
            else if roomPassword /= password jRoom  && not (hasSuperPower cl) 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
   103
            [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
   104
            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
   105
            (
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
   106
                MoveToRoom jRI
11056
62cc7f67105f Restore player clan on rejoin (issue 934, not tested)
unc0rr
parents: 11055
diff changeset
   107
                : ModifyClient (\c -> c{isJoinedMidGame = isJust $ gameInfo jRoom
62cc7f67105f Restore player clan on rejoin (issue 934, not tested)
unc0rr
parents: 11055
diff changeset
   108
                                        , teamsInGame = fromIntegral $ length clTeams
62cc7f67105f Restore player clan on rejoin (issue 934, not tested)
unc0rr
parents: 11055
diff changeset
   109
                                        , clientClan = teamcolor `fmap` listToMaybe clTeams})
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
   110
                : AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl]
9787
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
   111
                : [(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
   112
            )
11056
62cc7f67105f Restore player clan on rejoin (issue 934, not tested)
unc0rr
parents: 11055
diff changeset
   113
            ++ [ModifyRoom (\r -> let (t', g') = moveTeams clTeamsNames . fromJust $ gameInfo r in r{gameInfo = Just g', teams = t'}) | not $ null clTeams]
9787
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
   114
            ++ [AnswerClients [sendChan cl] ["CLIENT_FLAGS", "+h", nick $ fromJust owner] | isJust owner]
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
   115
            ++ [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
   116
            ++ answerFullConfig cl jRoom
8897
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8519
diff changeset
   117
            ++ answerTeams cl jRoom
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8519
diff changeset
   118
            ++ watchRound cl jRoom chans
9787
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
   119
            ++ [AnswerClients [sendChan cl] ["CHAT", "[greeting]", greeting jRoom] | greeting jRoom /= ""]
11056
62cc7f67105f Restore player clan on rejoin (issue 934, not tested)
unc0rr
parents: 11055
diff changeset
   120
            ++ map (\t -> AnswerClients chans ["EM", toEngineMsg $ 'G' `B.cons` t]) clTeamsNames
11055
c1c3f86af19e Fix inverse paused state for spectators joining paused game (not tested)
unc0rr
parents: 11046
diff changeset
   121
            ++ [AnswerClients [sendChan cl] ["EM", toEngineMsg "I"] | isPaused `fmap` gameInfo jRoom == Just True]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   122
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   123
        where
10351
0eff41e9f63f Restore teams in teams list on rejoin, should fix issues with second rejoin.
unc0rr
parents: 10349
diff changeset
   124
        moveTeams :: [B.ByteString] -> GameInfo -> ([TeamInfo], GameInfo)
0eff41e9f63f Restore teams in teams list on rejoin, should fix issues with second rejoin.
unc0rr
parents: 10349
diff changeset
   125
        moveTeams cts g = (deleteFirstsBy2 (\a b -> teamname a == b) (teamsAtStart g) (leftTeams g \\ cts)
10814
810ac1d21fd0 This should help with second rejoin bug. (reverting previous workaround over frontend bug and making a new one)
unc0rr
parents: 10734
diff changeset
   126
            , g{leftTeams = leftTeams g \\ cts, rejoinedTeams = rejoinedTeams g ++ cts, teamsInGameNumber = teamsInGameNumber g + length cts})
8235
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   127
        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
   128
                [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
   129
            where
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   130
            (ready, unready) = partition isReady clients
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   131
            (ingame, inroomlobby) = partition isInGame clients
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   132
            f fl lst = ["CLIENT_FLAGS" : fl : map nick lst | not $ null lst]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   133
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
   134
        -- 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
   135
        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
   136
                                    in answerFullConfigParams cl (f mapParams giMapParams) (f params giParams)
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   137
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
   138
        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
   139
8237
4ab4f461086e Show others if spectator is in game
unc0rr
parents: 8235
diff changeset
   140
        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
   141
                    []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   142
                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
   143
                    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
   144
                    : 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
   145
                    : ModifyClient (\c -> c{isInGame = True})
9381
90f9d8046a86 Fix silliness from r3f4c3fc146c2 (was I sleepy?)
unc0rr
parents: 9304
diff changeset
   146
                    : [AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : (reverse . roundMsgs . fromJust . gameInfo $ jRoom)]
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   147
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   148
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
   149
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
   150
    handleCmd_lobby ["JOIN_ROOM", roomName, ""]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
   151
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   152
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   153
handleCmd_lobby ["FOLLOW", asknick] = do
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   154
    (_, 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
   155
    clChan <- liftM sendChan thisClient
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   156
    ci <- clientByNick asknick
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   157
    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
   158
    let roomName = name $ room rnc ri
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
   159
    if isNothing ci || ri == lobbyId then
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   160
        return []
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   161
        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
   162
        liftM ((:) (AnswerClients [clChan] ["JOINING", roomName])) $ handleCmd_lobby ["JOIN_ROOM", roomName]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   163
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   164
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   165
handleCmd_lobby ("RND":rs) = do
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   166
    c <- liftM sendChan thisClient
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   167
    return [Random [c] rs]
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   168
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   169
    ---------------------------
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   170
    -- Administrator's stuff --
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   171
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   172
handleCmd_lobby ["KICK", kickNick] = serverAdminOnly $ do
4618
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   173
    (ci, _) <- ask
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   174
    kickId <- clientByNick kickNick
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   175
    return [KickClient $ fromJust kickId | isJust kickId && fromJust kickId /= ci]
1866
36aa0ca6e8af Cut the length of most used net packet
unc0rr
parents: 1862
diff changeset
   176
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   177
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   178
handleCmd_lobby ["BAN", banNick, reason, duration] = serverAdminOnly $ do
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   179
    (ci, _) <- ask
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   180
    banId <- clientByNick banNick
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   181
    return [BanClient (readInt_ duration) reason (fromJust banId) | isJust banId && fromJust banId /= ci]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
   182
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   183
handleCmd_lobby ["BANIP", ip, reason, duration] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   184
    return [BanIP ip (readInt_ duration) reason]
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
   185
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   186
handleCmd_lobby ["BANNICK", n, reason, duration] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   187
    return [BanNick n (readInt_ duration) reason]
8154
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   188
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   189
handleCmd_lobby ["BANLIST"] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   190
    return [BanList]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   191
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   192
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   193
handleCmd_lobby ["UNBAN", entry] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   194
    return [Unban entry]
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   195
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   196
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   197
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   198
    return [ModifyServerInfo (\si -> si{serverMessage = newMessage})]
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1905
diff changeset
   199
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   200
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   201
    return [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage})]
3260
b44b88908758 Allow to set motd for old client versions (not used yet, as server needs some refactoring)
unc0rr
parents: 2961
diff changeset
   202
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   203
handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   204
    return [ModifyServerInfo (\si -> si{latestReleaseVersion = readNum}) | 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
   205
    where
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 4989
diff changeset
   206
        readNum = readInt_ protoNum
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
   207
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   208
handleCmd_lobby ["GET_SERVER_VAR"] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   209
    return [SendServerVars]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   210
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   211
handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   212
    return [ClearAccountsCache]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   213
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   214
handleCmd_lobby ["RESTART_SERVER"] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   215
    return [RestartServer]
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   216
11032
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   217
handleCmd_lobby ["STATS"] = serverAdminOnly $
6aa31d7b1fa5 Use helper function instead of ton of copypasta
unc0rr
parents: 10814
diff changeset
   218
    return [Stats]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   219
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
   220
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]