--- a/gameServer/HWProtoLobbyState.hs Sun Oct 28 15:18:26 2012 +0100
+++ b/gameServer/HWProtoLobbyState.hs Fri Dec 06 22:20:53 2019 +0100
@@ -1,29 +1,36 @@
+{-
+ * Hedgewars, a free turn based strategy game
+ * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; version 2 of the License
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ \-}
+
{-# LANGUAGE OverloadedStrings #-}
module HWProtoLobbyState where
-import qualified Data.Map as Map
-import qualified Data.Foldable as Foldable
import Data.Maybe
import Data.List
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B
--------------------------------------
import CoreTypes
-import Actions
import Utils
+import Consts
import HandlerUtils
import RoomsAndClients
import EngineInteraction
-
-
-answerAllTeams :: ClientInfo -> [TeamInfo] -> [Action]
-answerAllTeams cl = concatMap toAnswer
- where
- clChan = sendChan cl
- toAnswer team =
- [AnswerClients [clChan] $ teamToNet team,
- AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team],
- AnswerClients [clChan] ["HH_NUM", teamname team, showB $ hhnum team]]
+import CommandHelp
handleCmd_lobby :: CmdHandler
@@ -33,27 +40,28 @@
(ci, irnc) <- ask
let cl = irnc `client` ci
rooms <- allRoomInfos
- let roomsInfoList = concatMap (\r -> roomInfo (nick $ irnc `client` masterID r) r) . filter (\r -> (roomProto r == clientProto cl))
- return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
-
+ let roomsInfoList = concatMap (\r -> roomInfo (clientProto cl) (maybeNick . liftM (client irnc) $ masterID r) r) . filter (\r -> (roomProto r == clientProto cl))
+ return $ if hasAskedList cl then [] else
+ [ ModifyClient (\c -> c{hasAskedList = True})
+ , AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
handleCmd_lobby ["CHAT", msg] = do
n <- clientNick
s <- roomOthersChans
- return [AnswerClients s ["CHAT", n, msg]]
+ return [AnswerClients s ["CHAT", n, msg], RegisterEvent LobbyChatMessage]
handleCmd_lobby ["CREATE_ROOM", rName, roomPassword]
- | illegalName rName = return [Warning "Illegal room name"]
+ | illegalName rName = return [Warning $ loc "Illegal room name! A room name must be between 1-40 characters long, must not have a trailing or leading space and must not have any of these characters: $()*+?[]^{|}"]
| otherwise = do
rs <- allRoomInfos
cl <- thisClient
return $ if isJust $ find (\r -> rName == name r) rs then
- [Warning "Room exists"]
+ [Warning $ loc "A room with the same name already exists."]
else
[
AddRoom rName roomPassword
, AnswerClients [sendChan cl] ["CLIENT_FLAGS", "+hr", nick cl]
- , ModifyClient (\cl -> cl{isMaster = True, isReady = True})
+ , ModifyClient (\c -> c{isMaster = True, isReady = True, isJoinedMidGame = False})
, ModifyRoom (\r -> r{readyPlayers = 1})
]
@@ -64,6 +72,7 @@
handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
(_, irnc) <- ask
+
let ris = allRooms irnc
cl <- thisClient
let maybeRI = find (\ri -> roomName == name (irnc `room` ri)) ris
@@ -72,58 +81,71 @@
let sameProto = clientProto cl == roomProto jRoom
let jRoomClients = map (client irnc) $ roomClients irnc jRI
let nicks = map nick jRoomClients
- let ownerNick = nick . fromJust $ find isMaster jRoomClients
+ let owner = find isMaster jRoomClients
let chans = map sendChan (cl : jRoomClients)
let isBanned = host cl `elem` roomBansList jRoom
+ let clTeams =
+ if (clientProto cl >= 48) && (isJust $ gameInfo jRoom) && isRegistered cl then
+ filter (\t -> teamowner t == nick cl) . teamsAtStart . fromJust $ gameInfo jRoom
+ else
+ []
+ let clTeamsNames = map teamname clTeams
return $
- if isNothing maybeRI || not sameProto then
- [Warning "No such room"]
- else if isRestrictedJoins jRoom then
- [Warning "Joining restricted"]
+ if isNothing maybeRI then
+ [Warning $ loc "No such room."]
+ else if (not sameProto) && (not $ isAdministrator cl) then
+ [Warning $ loc "Room version incompatible to your Hedgewars version!"]
+ else if isRestrictedJoins jRoom && not (hasSuperPower cl) then
+ [Warning $ loc "Access denied. This room currently doesn't allow joining."]
+ else if isRegisteredOnly jRoom && (not $ isRegistered cl) && not (isAdministrator cl) then
+ [Warning $ loc "Access denied. This room is for registered users only."]
else if isBanned then
- [Warning "You are banned in this room"]
- else if roomPassword /= password jRoom then
+ [Warning $ loc "You are banned from this room."]
+ else if roomPassword /= password jRoom && not (hasSuperPower cl) then
[NoticeMessage WrongPassword]
else
- [
+ (
MoveToRoom jRI
- , AnswerClients [sendChan cl] $ "JOINED" : nicks
- , AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl]
- , AnswerClients [sendChan cl] $ ["WARNING", "Room admin is " `B.append` ownerNick]
- , AnswerClients [sendChan cl] $ ["CLIENT_FLAGS", "+h", ownerNick]
- ]
- ++ map (readynessMessage cl) jRoomClients
- ++ answerFullConfig cl (mapParams jRoom) (params jRoom)
+ : ModifyClient (\c -> c{isJoinedMidGame = isJust $ gameInfo jRoom
+ , teamsInGame = fromIntegral $ length clTeams
+ , clientClan = teamcolor `fmap` listToMaybe clTeams})
+ : AnswerClients chans ["CLIENT_FLAGS", "-r", nick cl]
+ : [(AnswerClients [sendChan cl] $ "JOINED" : nicks) | not $ null nicks]
+ )
+ ++ [ModifyRoom (\r -> let (t', g') = moveTeams clTeamsNames . fromJust $ gameInfo r in r{gameInfo = Just g', teams = t'}) | not $ null clTeams]
+ ++ [AnswerClients [sendChan cl] ["CLIENT_FLAGS", "+h", nick $ fromJust owner] | isJust owner]
+ ++ [sendStateFlags cl jRoomClients | not $ null jRoomClients]
+ ++ answerFullConfig cl jRoom
++ answerTeams cl jRoom
- ++ watchRound cl jRoom
+ ++ watchRound cl jRoom chans
+ ++ [AnswerClients [sendChan cl] ["CHAT", nickGreeting, greeting jRoom] | greeting jRoom /= ""]
+ ++ map (\t -> AnswerClients chans ["EM", toEngineMsg $ 'G' `B.cons` t]) clTeamsNames
+ ++ [AnswerClients [sendChan cl] ["EM", toEngineMsg "I"] | isPaused `fmap` gameInfo jRoom == Just True]
where
- readynessMessage cl c = AnswerClients [sendChan cl] $
- if clientProto cl < 38 then
- [if isReady c then "READY" else "NOT_READY", nick c]
- else
- ["CLIENT_FLAGS", if isReady c then "+r" else "-r", nick c]
-
- toAnswer cl (paramName, paramStrs) = AnswerClients [sendChan cl] $ "CFG" : paramName : paramStrs
+ moveTeams :: [B.ByteString] -> GameInfo -> ([TeamInfo], GameInfo)
+ moveTeams cts g = (deleteFirstsBy2 (\a b -> teamname a == b) (teamsAtStart g) (leftTeams g \\ cts)
+ , g{leftTeams = leftTeams g \\ cts, rejoinedTeams = rejoinedTeams g ++ cts, teamsInGameNumber = teamsInGameNumber g + length cts})
+ sendStateFlags cl clients = AnswerClients [sendChan cl] . concat . intersperse [""] . filter (not . null) . concat $
+ [f "+r" ready, f "-r" unready, f "+g" ingame, f "-g" inroomlobby]
+ where
+ (ready, unready) = partition isReady clients
+ (ingame, inroomlobby) = partition isInGame clients
+ f fl lst = ["CLIENT_FLAGS" : fl : map nick lst | not $ null lst]
- answerFullConfig cl mpr pr
- | clientProto cl < 38 = map (toAnswer cl) $
- (reverse . map (\(a, b) -> (a, [b])) $ Map.toList mpr)
- ++ (("SCHEME", pr Map.! "SCHEME")
- : (filter (\(p, _) -> p /= "SCHEME") $ Map.toList pr))
-
- | otherwise = map (toAnswer cl) $
- ("FULLMAPCONFIG", Map.elems mpr)
- : ("SCHEME", pr Map.! "SCHEME")
- : (filter (\(p, _) -> p /= "SCHEME") $ Map.toList pr)
+ -- get config from gameInfo if possible, otherwise from room
+ answerFullConfig cl jRoom = let f r g = (if isJust $ gameInfo jRoom then g . fromJust . gameInfo else r) jRoom
+ in answerFullConfigParams cl (f mapParams giMapParams) (f params giParams)
answerTeams cl jRoom = let f = if isJust $ gameInfo jRoom then teamsAtStart . fromJust . gameInfo else teams in answerAllTeams cl $ f jRoom
- watchRound cl jRoom = if isNothing $ gameInfo jRoom then
+ watchRound cl jRoom chans = if isNothing $ gameInfo jRoom then
[]
else
- [AnswerClients [sendChan cl] ["RUN_GAME"],
- AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs . fromJust . gameInfo $ jRoom)]
+ AnswerClients [sendChan cl] ["RUN_GAME"]
+ : AnswerClients chans ["CLIENT_FLAGS", "+g", nick cl]
+ : ModifyClient (\c -> c{isInGame = True})
+ : [AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : (reverse . roundMsgs . fromJust . gameInfo $ jRoom)]
handleCmd_lobby ["JOIN_ROOM", roomName] =
@@ -132,69 +154,84 @@
handleCmd_lobby ["FOLLOW", asknick] = do
(_, rnc) <- ask
+ clChan <- liftM sendChan thisClient
ci <- clientByNick asknick
let ri = clientRoom rnc $ fromJust ci
- let clRoom = room rnc ri
+ let roomName = name $ room rnc ri
if isNothing ci || ri == lobbyId then
return []
else
- handleCmd_lobby ["JOIN_ROOM", name clRoom]
+ liftM ((:) (AnswerClients [clChan] ["JOINING", roomName])) $ handleCmd_lobby ["JOIN_ROOM", roomName]
+
+
+handleCmd_lobby ("RND":rs) = do
+ c <- liftM sendChan thisClient
+ return [Random [c] rs]
+
+handleCmd_lobby ["HELP"] = do
+ cl <- thisClient
+ if isAdministrator cl then
+ return (cmdHelpActionList [sendChan cl] cmdHelpLobbyAdmin)
+ else
+ return (cmdHelpActionList [sendChan cl] cmdHelpLobbyPlayer)
---------------------------
-- Administrator's stuff --
-handleCmd_lobby ["KICK", kickNick] = do
+handleCmd_lobby ["KICK", kickNick] = serverAdminOnly $ do
(ci, _) <- ask
- cl <- thisClient
kickId <- clientByNick kickNick
- return [KickClient $ fromJust kickId | isAdministrator cl && isJust kickId && fromJust kickId /= ci]
+ return [KickClient $ fromJust kickId | isJust kickId && fromJust kickId /= ci]
-handleCmd_lobby ["BAN", banNick, reason] = do
+handleCmd_lobby ["BAN", banNick, reason, duration] = serverAdminOnly $ do
(ci, _) <- ask
- cl <- thisClient
banId <- clientByNick banNick
- return [BanClient 60 reason (fromJust banId) | isAdministrator cl && isJust banId && fromJust banId /= ci]
+ return [BanClient (readInt_ duration) reason (fromJust banId) | isJust banId && fromJust banId /= ci]
-handleCmd_lobby ["BANIP", ip, reason, duration] = do
- cl <- thisClient
- return [BanIP ip (readInt_ duration) reason | isAdministrator cl]
+handleCmd_lobby ["BANIP", ip, reason, duration] = serverAdminOnly $
+ return [BanIP ip (readInt_ duration) reason]
-handleCmd_lobby ["BANLIST"] = do
- cl <- thisClient
- return [BanList | isAdministrator cl]
+handleCmd_lobby ["BANNICK", n, reason, duration] = serverAdminOnly $
+ return [BanNick n (readInt_ duration) reason]
+
+handleCmd_lobby ["BANLIST"] = serverAdminOnly $
+ return [BanList]
-handleCmd_lobby ["UNBAN", entry] = do
- cl <- thisClient
- return [Unban entry | isAdministrator cl]
+handleCmd_lobby ["UNBAN", entry] = serverAdminOnly $
+ return [Unban entry]
-handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = do
- cl <- thisClient
- return [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator cl]
+handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = serverAdminOnly $
+ return [ModifyServerInfo (\si -> si{serverMessage = newMessage})]
-handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do
- cl <- thisClient
- return [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage}) | isAdministrator cl]
+handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = serverAdminOnly $
+ return [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage})]
-handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do
- cl <- thisClient
- return [ModifyServerInfo (\si -> si{latestReleaseVersion = readNum}) | isAdministrator cl && readNum > 0]
+handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = serverAdminOnly $
+ return [ModifyServerInfo (\si -> si{latestReleaseVersion = readNum}) | readNum > 0]
where
readNum = readInt_ protoNum
-handleCmd_lobby ["GET_SERVER_VAR"] = do
- cl <- thisClient
- return [SendServerVars | isAdministrator cl]
+handleCmd_lobby ["GET_SERVER_VAR"] = serverAdminOnly $
+ return [SendServerVars]
+
+handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = serverAdminOnly $
+ return [ClearAccountsCache]
-handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do
- cl <- thisClient
- return [ClearAccountsCache | isAdministrator cl]
+handleCmd_lobby ["RESTART_SERVER", "YES"] = serverAdminOnly $
+ return [RestartServer]
-handleCmd_lobby ["RESTART_SERVER"] = do
- cl <- thisClient
- return [RestartServer | isAdministrator cl]
+handleCmd_lobby ["RESTART_SERVER"] = serverAdminOnly $
+ return [Warning $ loc "Please confirm server restart with '/restart_server yes'."]
+
+handleCmd_lobby ["RESTART_SERVER", _] = handleCmd_lobby ["RESTART_SERVER"]
-handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]
+handleCmd_lobby ["STATS"] = serverAdminOnly $
+ return [Stats]
+
+handleCmd_lobby (s:_) = return [ProtocolError $ "Incorrect command '" `B.append` s `B.append` "' (state: in lobby)"]
+
+handleCmd_lobby [] = return [ProtocolError "Empty command (state: in lobby)"]