gameServer/HWProtoLobbyState.hs
author nemo
Mon, 08 Dec 2014 09:35:14 -0500
changeset 10634 35d059bd0932
parent 10460 8dcea9087d75
child 10734 8fadc4305df0
permissions -rw-r--r--
Use FreeAndNil across the board. Even if we are immediately assigning after, probably avoids accidental mistakes. Also free neglected owner tex on shutdown, and delete hog gears using the normal deletion procedure if for any reason they still exist (EndGame call?).
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
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10351
diff changeset
     3
 * Copyright (c) 2004-2014 Andrey Korotaev <unC0Rr@gmail.com>
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
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    37
handleCmd_lobby ["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
    38
    (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
    39
    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
    40
    rooms <- allRoomInfos
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9729
diff changeset
    41
    let roomsInfoList = concatMap (\r -> roomInfo (clientProto cl) (maybeNick . liftM (client irnc) $ masterID r) r) . filter (\r -> (roomProto r == clientProto cl))
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    42
    return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    43
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    44
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
    45
    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
    46
    s <- roomOthersChans
10092
a92a4ba39a79 Fix build
unc0rr
parents: 9787
diff changeset
    47
    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
    48
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    49
handleCmd_lobby ["CREATE_ROOM", rName, roomPassword]
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    50
    | 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
    51
    | 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
    52
        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
    53
        cl <- thisClient
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    54
        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
    55
            [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
    56
            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
    57
            [
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    58
                AddRoom rName roomPassword
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    59
                , 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
    60
                , ModifyClient (\c -> c{isMaster = True, isReady = True, isJoinedMidGame = False})
7775
835ad028fb66 Keep room admin ready status always set
unc0rr
parents: 7766
diff changeset
    61
                , 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
    62
            ]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    63
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    64
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    65
handleCmd_lobby ["CREATE_ROOM", rName] =
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    66
    handleCmd_lobby ["CREATE_ROOM", rName, ""]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
    67
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
    68
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
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4917
diff changeset
    70
    (_, 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
    71
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
    72
    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
    73
    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
    74
    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
    75
    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
    76
    let jRoom = irnc `room` jRI
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
    77
    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
    78
    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
    79
    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
    80
    let owner = find isMaster jRoomClients
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4595
diff changeset
    81
    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
    82
    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
    83
    let clTeams =
10351
0eff41e9f63f Restore teams in teams list on rejoin, should fix issues with second rejoin.
unc0rr
parents: 10349
diff changeset
    84
            if (clientProto cl >= 48) && (isJust $ gameInfo jRoom) then
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
                map teamname . filter (\t -> teamowner t == nick cl) . teamsAtStart . fromJust $ gameInfo jRoom 
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
    86
                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
    87
                []
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
    88
    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
    89
        if isNothing maybeRI then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    90
            [Warning $ loc "No such room"]
10337
05a5762ab12c Allow server admins to join room of another protocol version
unc0rr
parents: 10212
diff changeset
    91
            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
    92
            [Warning $ loc "Room version incompatible to your hedgewars version"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    93
            else if isRestrictedJoins jRoom then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    94
            [Warning $ loc "Joining restricted"]
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9729
diff changeset
    95
            else if isRegisteredOnly jRoom && (B.null . webPassword $ cl) && not (isAdministrator cl) then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    96
            [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
    97
            else if isBanned then
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8369
diff changeset
    98
            [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
    99
            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
   100
            [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
   101
            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
   102
            (
7682
f6bfbe829008 'h' status for room admins
unc0rr
parents: 7677
diff changeset
   103
                MoveToRoom jRI
10349
a51de45dcc42 Fix some issues with rejoining (rejoining client still desyncs though)
unc0rr
parents: 10342
diff changeset
   104
                : ModifyClient (\c -> c{isJoinedMidGame = isJust $ gameInfo jRoom, teamsInGame = fromIntegral $ length 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
   105
                : AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl]
9787
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
   106
                : [(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
   107
            )
10351
0eff41e9f63f Restore teams in teams list on rejoin, should fix issues with second rejoin.
unc0rr
parents: 10349
diff changeset
   108
                ++ [ModifyRoom (\r -> let (t', g') = moveTeams clTeams . 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
   109
            ++ [AnswerClients [sendChan cl] ["CLIENT_FLAGS", "+h", nick $ fromJust owner] | isJust owner]
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
   110
            ++ [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
   111
            ++ answerFullConfig cl jRoom
8897
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8519
diff changeset
   112
            ++ answerTeams cl jRoom
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8519
diff changeset
   113
            ++ watchRound cl jRoom chans
9787
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9753
diff changeset
   114
            ++ [AnswerClients [sendChan cl] ["CHAT", "[greeting]", greeting jRoom] | greeting 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
   115
            ++ map (\t -> AnswerClients chans ["EM", toEngineMsg $ 'G' `B.cons` t]) clTeams
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   116
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   117
        where
10351
0eff41e9f63f Restore teams in teams list on rejoin, should fix issues with second rejoin.
unc0rr
parents: 10349
diff changeset
   118
        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
   119
        moveTeams cts g = (deleteFirstsBy2 (\a b -> teamname a == b) (teamsAtStart g) (leftTeams g \\ cts)
0eff41e9f63f Restore teams in teams list on rejoin, should fix issues with second rejoin.
unc0rr
parents: 10349
diff changeset
   120
            , g{leftTeams = leftTeams g \\ cts, teamsInGameNumber = teamsInGameNumber g + length cts})
8235
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   121
        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
   122
                [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
   123
            where
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   124
            (ready, unready) = partition isReady clients
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   125
            (ingame, inroomlobby) = partition isInGame clients
f29c55ea93ed Show who's in game to spectators
unc0rr
parents: 8232
diff changeset
   126
            f fl lst = ["CLIENT_FLAGS" : fl : map nick lst | not $ null lst]
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   127
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 9035
diff changeset
   128
        -- 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
   129
        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
   130
                                    in answerFullConfigParams cl (f mapParams giMapParams) (f params giParams)
4587
adf64662b6a8 Send room config to client
unc0rr
parents: 4571
diff changeset
   131
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
   132
        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
   133
8237
4ab4f461086e Show others if spectator is in game
unc0rr
parents: 8235
diff changeset
   134
        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
   135
                    []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   136
                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
   137
                    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
   138
                    : 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
   139
                    : ModifyClient (\c -> c{isInGame = True})
9381
90f9d8046a86 Fix silliness from r3f4c3fc146c2 (was I sleepy?)
unc0rr
parents: 9304
diff changeset
   140
                    : [AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : (reverse . roundMsgs . fromJust . gameInfo $ jRoom)]
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   141
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3502
diff changeset
   142
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
   143
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
   144
    handleCmd_lobby ["JOIN_ROOM", roomName, ""]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
   145
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   146
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   147
handleCmd_lobby ["FOLLOW", asknick] = do
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   148
    (_, 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
   149
    clChan <- liftM sendChan thisClient
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   150
    ci <- clientByNick asknick
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   151
    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
   152
    let roomName = name $ room rnc ri
5931
184057074257 - Allow 8 teams in game on 0.9.16-dev
unc0rr
parents: 5573
diff changeset
   153
    if isNothing ci || ri == lobbyId then
4616
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   154
        return []
cc3485866b93 Reimplement FOLLOW
unc0rr
parents: 4597
diff changeset
   155
        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
   156
        liftM ((:) (AnswerClients [clChan] ["JOINING", roomName])) $ handleCmd_lobby ["JOIN_ROOM", roomName]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   157
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   158
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   159
handleCmd_lobby ("RND":rs) = do
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   160
    c <- liftM sendChan thisClient
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   161
    return [Random [c] rs]
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 8897
diff changeset
   162
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   163
    ---------------------------
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2408
diff changeset
   164
    -- Administrator's stuff --
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1815
diff changeset
   165
4618
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   166
handleCmd_lobby ["KICK", kickNick] = do
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   167
    (ci, _) <- ask
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   168
    cl <- thisClient
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   169
    kickId <- clientByNick kickNick
0f56fa511f65 Reimplement KICK
unc0rr
parents: 4616
diff changeset
   170
    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
   171
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   172
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8154
diff changeset
   173
handleCmd_lobby ["BAN", banNick, reason, duration] = do
4909
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   174
    (ci, _) <- ask
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   175
    cl <- thisClient
dc6482438674 - Implement BAN protocol command
unc0rr
parents: 4904
diff changeset
   176
    banId <- clientByNick banNick
8156
3ccc61102b58 - Fix UNBAN bug
unc0rr
parents: 8154
diff changeset
   177
    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
   178
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   179
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
   180
    cl <- thisClient
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   181
    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
   182
8154
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   183
handleCmd_lobby ["BANNICK", n, reason, duration] = do
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   184
    cl <- thisClient
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   185
    return [BanNick n (readInt_ duration) reason | isAdministrator cl]
0ea76ea45e6a Implement ban by nickname
unc0rr
parents: 7862
diff changeset
   186
5426
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   187
handleCmd_lobby ["BANLIST"] = do
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   188
    cl <- thisClient
109e9b5761c2 Implement command for banning by ip and a command for bans list
unc0rr
parents: 5209
diff changeset
   189
    return [BanList | isAdministrator cl]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   190
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   191
7748
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   192
handleCmd_lobby ["UNBAN", entry] = do
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   193
    cl <- thisClient
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   194
    return [Unban entry | isAdministrator cl]
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   195
f160fbc139b1 UNBAN implementation
unc0rr
parents: 7682
diff changeset
   196
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   197
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   198
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   199
    return [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator cl]
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1905
diff changeset
   200
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   201
handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   202
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   203
    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
   204
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   205
handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   206
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   207
    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
   208
    where
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 4989
diff changeset
   209
        readNum = readInt_ protoNum
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 6912
diff changeset
   210
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   211
handleCmd_lobby ["GET_SERVER_VAR"] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   212
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   213
    return [SendServerVars | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   214
4620
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   215
handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   216
    cl <- thisClient
6122a43d3424 Reimplement a bunch of administrator commands
unc0rr
parents: 4618
diff changeset
   217
    return [ClearAccountsCache | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   218
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5093
diff changeset
   219
handleCmd_lobby ["RESTART_SERVER"] = do
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   220
    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
   221
    return [RestartServer | isAdministrator cl]
4914
5c33bb53c1e5 Stub for server restart command
unc0rr
parents: 4909
diff changeset
   222
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   223
handleCmd_lobby ["STATS"] = do
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   224
    cl <- thisClient
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
   225
    return [Stats | isAdministrator cl]
3283
18ee933a5864 Some stuff for game server administration task
unc0rr
parents: 3277
diff changeset
   226
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
   227
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]