hedgewars: comparison gameServer/HWProtoInRoomState.hs

equal deleted inserted replaced

-:46a9fde631f4
+:75db7bb8dce8
 {-# LANGUAGE OverloadedStrings #-}
 module HWProtoInRoomState where
 import qualified Data.Map as Map
-import Data.Sequence((|>))
 import Data.List as L
 import Data.Maybe
 import qualified Data.ByteString.Char8 as B
 import Control.Monad
 import Control.Monad.Reader
-import Control.DeepSeq
 --------------------------------------
 import CoreTypes
 import Actions
 import Utils
 import HandlerUtils
 handleCmd_inRoom ["PART"] = return [MoveToLobby "part"]
 handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg]
 handleCmd_inRoom ("CFG" : paramName : paramStrs)
-| null paramStrs = return [ProtocolError "Empty config entry"]
+| null paramStrs = return [ProtocolError $ loc "Empty config entry"]
 | otherwise = do
 chans <- roomOthersChans
 cl <- thisClient
 if isMaster cl then
 return [
 ModifyRoom f,
 AnswerClients chans ("CFG" : paramName : paramStrs)]
 else
-return [ProtocolError "Not room master"]
+return [ProtocolError $ loc "Not room master"]
 where
 f r = if paramName `Map.member` (mapParams r) then
 r{mapParams = Map.insert paramName (head paramStrs) (mapParams r)}
 else
 r{params = Map.insert paramName paramStrs (params r)}
 handleCmd_inRoom ("ADD_TEAM" : tName : color : grave : fort : voicepack : flag : difStr : hhsInfo)
-| length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"]
+| length hhsInfo /= 16 = return [ProtocolError $ loc "Corrupted hedgehogs info"]
 | otherwise = do
 (ci, _) <- ask
 rm <- thisRoom
 clNick <- clientNick
 clChan <- thisClientChans
 teamColor <-
 if clientProto cl < 42 then
 return color
 else
 liftM (head . (L.\\) (map B.singleton ['0'..]) . map teamcolor . teams) thisRoom
-let newTeam = clNick `seq` TeamInfo ci clNick tName teamColor grave fort voicepack flag dif (newTeamHHNum rm) (hhsList hhsInfo)
+let roomTeams = teams rm
+let hhNum = let p = if not $ null roomTeams then hhnum $ head roomTeams else 4 in newTeamHHNum roomTeams p
+let newTeam = clNick `seq` TeamInfo ci clNick tName teamColor grave fort voicepack flag dif hhNum (hhsList hhsInfo)
 return $
-if not . null . drop (maxTeams rm - 1) $ teams rm then
+if not . null . drop (maxTeams rm - 1) $ roomTeams then
-[Warning "too many teams"]
+[Warning $ loc "too many teams"]
-else if canAddNumber rm <= 0 then
+else if canAddNumber roomTeams <= 0 then
-[Warning "too many hedgehogs"]
+[Warning $ loc "too many hedgehogs"]
 else if isJust $ findTeam rm then
-[Warning "There's already a team with same name in the list"]
+[Warning $ loc "There's already a team with same name in the list"]
 else if isJust $ gameInfo rm then
-[Warning "round in progress"]
+[Warning $ loc "round in progress"]
 else if isRestrictedTeams rm then
-[Warning "restricted"]
+[Warning $ loc "restricted"]
 else
 [ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}),
 SendUpdateOnThisRoom,
 ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = Just teamColor}),
 AnswerClients clChan ["TEAM_ACCEPTED", tName],
+AnswerClients clChan ["HH_NUM", tName, showB $ hhnum newTeam],
 AnswerClients othChans $ teamToNet $ newTeam,
 AnswerClients roomChans ["TEAM_COLOR", tName, teamColor]
 ]
 where
-canAddNumber r = 48 - (sum . map hhnum $ teams r)
+canAddNumber rt = (48::Int) - (sum $ map hhnum rt)
 findTeam = find (\t -> tName == teamname t) . teams
 dif = readInt_ difStr
 hhsList [] = []
 hhsList [_] = error "Hedgehogs list with odd elements number"
 hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
-newTeamHHNum r = min 4 (canAddNumber r)
+newTeamHHNum rt p = min p (canAddNumber rt)
 maxTeams r
 | roomProto r < 38 = 6
 | otherwise = 8
 let maybeTeam = findTeam r
 let team = fromJust maybeTeam
 return $
-if isNothing $ findTeam r then
+if isNothing $ maybeTeam then
-[Warning "REMOVE_TEAM: no such team"]
+[Warning $ loc "REMOVE_TEAM: no such team"]
 else if clNick /= teamowner team then
-[ProtocolError "Not team owner!"]
+[ProtocolError $ loc "Not team owner!"]
 else
 [RemoveTeam tName,
 ModifyClient
 (\c -> c{
 teamsInGame = teamsInGame c - 1,
 findTeam = find (\t -> tName == teamname t) . teams
 handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do
 cl <- thisClient
-others <- roomOthersChans
 r <- thisRoom
+clChan <- thisClientChans
+roomChans <- roomClientsChans
 let maybeTeam = findTeam r
 let team = fromJust maybeTeam
 return $
 if not $ isMaster cl then
-[ProtocolError "Not room master"]
+[ProtocolError $ loc "Not room master"]
-else if hhNumber < 1 || hhNumber > 8 || isNothing maybeTeam || hhNumber > canAddNumber r + hhnum team then
+else if isNothing maybeTeam then
 []
+else if hhNumber < 1 || hhNumber > 8 || hhNumber > canAddNumber r + hhnum team then
+[AnswerClients clChan ["HH_NUM", teamName, showB $ hhnum team]]
 else
 [ModifyRoom $ modifyTeam team{hhnum = hhNumber},
-AnswerClients others ["HH_NUM", teamName, showB hhNumber]]
+AnswerClients roomChans ["HH_NUM", teamName, showB hhNumber]]
 where
 hhNumber = readInt_ numberStr
 findTeam = find (\t -> teamName == teamname t) . teams
 canAddNumber = (-) 48 . sum . map hhnum . teams
 let maybeTeam = findTeam r
 let team = fromJust maybeTeam
 return $
 if not $ isMaster cl then
-[ProtocolError "Not room master"]
+[ProtocolError $ loc "Not room master"]
 else if isNothing maybeTeam then
 []
 else
 [ModifyRoom $ modifyTeam team{teamcolor = newColor},
 AnswerClients others ["TEAM_COLOR", teamName, newColor],
 chans <- roomClientsChans
 let nicks = map (nick . client rnc) . roomClients rnc $ clientRoom rnc ci
 let allPlayersRegistered = all ((<) 0 . B.length . webPassword . client rnc . teamownerId) $ teams rm
-if isMaster cl && playersIn rm == readyPlayers rm && not (isJust $ gameInfo rm) then
+if isMaster cl && (playersIn rm == readyPlayers rm || clientProto cl > 43) && not (isJust $ gameInfo rm) then
 if enoughClans rm then
 return [
 ModifyRoom
 (\r -> r{
 gameInfo = Just $ newGameInfo (teams rm) (length $ teams rm) allPlayersRegistered (mapParams rm) (params rm)
 , SendUpdateOnThisRoom
 , AnswerClients chans $ "CLIENT_FLAGS" : "+g" : nicks
 , ModifyRoomClients (\c -> c{isInGame = True})
 ]
 else
-return [Warning "Less than two clans!"]
+return [Warning $ loc "Less than two clans!"]
 else
 return []
 where
 enoughClans = not . null . drop 1 . group . map teamcolor . teams
 cl <- thisClient
 rm <- thisRoom
 chans <- roomOthersChans
 if teamsInGame cl > 0 && (isJust $ gameInfo rm) && isLegal then
-return $ AnswerClients chans ["EM", msg] : [ModifyRoom (\r -> r{gameInfo = liftM (\g -> g{roundMsgs = roundMsgs g |> msg}) $ gameInfo r}) | not isKeepAlive]
+return $ AnswerClients chans ["EM", msg]
+: [ModifyRoom (\r -> r{gameInfo = liftM (\g -> g{roundMsgs = msg : roundMsgs g}) $ gameInfo r}) | not isKeepAlive]
 else
 return []
 where
 (isLegal, isKeepAlive) = checkNetCmd msg
 let clTeams = map teamname . filter (\t -> teamowner t == nick cl) . teams $ rm
 let unsetInGameState = [AnswerClients chans ["CLIENT_FLAGS", "-g", nick cl], ModifyClient (\c -> c{isInGame = False})]
 if isInGame cl then
 if isJust $ gameInfo rm then
-if (isMaster cl && isCorrect) then
+return $ unsetInGameState ++ map SendTeamRemovalMessage clTeams
-return $ FinishGame : unsetInGameState
-else
-return $ unsetInGameState ++ map SendTeamRemovalMessage clTeams
 else
 return unsetInGameState
 else
 return [] -- don't accept this message twice
 where
 handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do
 cl <- thisClient
 return $
 if not $ isMaster cl then
-[ProtocolError "Not room master"]
+[ProtocolError $ loc "Not room master"]
 else
 [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
 handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do
 cl <- thisClient
 return $
 if not $ isMaster cl then
-[ProtocolError "Not room master"]
+[ProtocolError $ loc "Not room master"]
 else
 [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
 handleCmd_inRoom ["TOGGLE_REGISTERED_ONLY"] = do
 cl <- thisClient
 return $
 if not $ isMaster cl then
-[ProtocolError "Not room master"]
+[ProtocolError $ loc "Not room master"]
 else
 [ModifyRoom (\r -> r{isRegisteredOnly = not $ isRegisteredOnly r})]
 handleCmd_inRoom ["ROOM_NAME", newName] = do
 cl <- thisClient
 rm <- thisRoom
 chans <- sameProtoChans
 return $
 if not $ isMaster cl then
-[ProtocolError "Not room master"]
+[ProtocolError $ loc "Not room master"]
 else
 if isJust $ find (\r -> newName == name r) rs then
-[Warning "Room with such name already exists"]
+[Warning $ loc "Room with such name already exists"]
 else
 [ModifyRoom roomUpdate,
 AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo (nick cl) (roomUpdate rm))]
 where
 roomUpdate r = r{name = newName}
 handleCmd_inRoom ["DELEGATE", newAdmin] = do
 (thisClientId, rnc) <- ask
 maybeClientId <- clientByNick newAdmin
 master <- liftM isMaster thisClient
+serverAdmin <- liftM isAdministrator thisClient
 let newAdminId = fromJust maybeClientId
 let sameRoom = clientRoom rnc thisClientId == clientRoom rnc newAdminId
 return
-[ChangeMaster (Just newAdminId) | master && isJust maybeClientId && (newAdminId /= thisClientId) && sameRoom]
+[ChangeMaster (Just newAdminId) |
+(master || serverAdmin)
+&& isJust maybeClientId
+&& ((newAdminId /= thisClientId) || (serverAdmin && not master))
+&& sameRoom]
 handleCmd_inRoom ["TEAMCHAT", msg] = do
 cl <- thisClient
 chans <- roomSameClanChans

branch	webgl
changeset 8444	75db7bb8dce8
parent 8330	aaefa587e277
parent 8429	f814a7c2a318
child 8833	c13ebed437cb