diff -r 21dd1def5aaf -r 0eab727d4717 gameServer/HWProtoInRoomState.hs --- a/gameServer/HWProtoInRoomState.hs Wed Feb 02 09:05:48 2011 +0100 +++ b/gameServer/HWProtoInRoomState.hs Wed Feb 02 11:28:38 2011 +0300 @@ -1,196 +1,254 @@ +{-# LANGUAGE OverloadedStrings #-} module HWProtoInRoomState where -import qualified Data.Foldable as Foldable -import qualified Data.IntMap as IntMap import qualified Data.Map as Map -import Data.Sequence(Seq, (|>), (><), fromList, empty) +import Data.Sequence((|>), empty) import Data.List import Data.Maybe +import qualified Data.ByteString.Char8 as B +import Control.Monad +import Control.Monad.Reader -------------------------------------- import CoreTypes import Actions import Utils - +import HandlerUtils +import RoomsAndClients handleCmd_inRoom :: CmdHandler -handleCmd_inRoom clID clients _ ["CHAT", msg] = - [AnswerOthersInRoom ["CHAT", clientNick, msg]] - where - clientNick = nick $ clients IntMap.! clID +handleCmd_inRoom ["CHAT", msg] = do + n <- clientNick + s <- roomOthersChans + return [AnswerClients s ["CHAT", n, msg]] -handleCmd_inRoom clID clients rooms ["PART"] = - [RoomRemoveThisClient "part"] - where - client = clients IntMap.! clID +handleCmd_inRoom ["PART"] = return [MoveToLobby "part"] +handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg] -handleCmd_inRoom clID clients rooms ("CFG" : paramName : paramStrs) - | null paramStrs = [ProtocolError "Empty config entry"] - | isMaster client = - [ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}), - AnswerOthersInRoom ("CFG" : paramName : paramStrs)] - | otherwise = [ProtocolError "Not room master"] - where - client = clients IntMap.! clID +handleCmd_inRoom ("CFG" : paramName : paramStrs) + | null paramStrs = return [ProtocolError "Empty config entry"] + | otherwise = do + chans <- roomOthersChans + cl <- thisClient + if isMaster cl then + return [ + ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}), + AnswerClients chans ("CFG" : paramName : paramStrs)] + else + return [ProtocolError "Not room master"] -handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo) - | length hhsInfo == 15 && clientProto client < 30 = handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : " " : flag : difStr : hhsInfo) - | length hhsInfo /= 16 = [ProtocolError "Corrupted hedgehogs info"] - | length (teams room) == 8 = [Warning "too many teams"] - | canAddNumber <= 0 = [Warning "too many hedgehogs"] - | isJust findTeam = [Warning "There's already a team with same name in the list"] - | gameinprogress room = [Warning "round in progress"] - | isRestrictedTeams room = [Warning "restricted"] - | otherwise = - [ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}), - ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}), - AnswerThisClient ["TEAM_ACCEPTED", name], - AnswerOthersInRoom $ teamToNet (clientProto client) newTeam, - AnswerOthersInRoom ["TEAM_COLOR", name, color] - ] +handleCmd_inRoom ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo) + | length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"] + | otherwise = do + (ci, rnc) <- ask + r <- thisRoom + clNick <- clientNick + clChan <- thisClientChans + othersChans <- roomOthersChans + return $ + if not . null . drop 5 $ teams r then + [Warning "too many teams"] + else if canAddNumber r <= 0 then + [Warning "too many hedgehogs"] + else if isJust $ findTeam r then + [Warning "There's already a team with same name in the list"] + else if gameinprogress r then + [Warning "round in progress"] + else if isRestrictedTeams r then + [Warning "restricted"] + else + [ModifyRoom (\r -> r{teams = teams r ++ [newTeam ci clNick r]}), + ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}), + AnswerClients clChan ["TEAM_ACCEPTED", name], + AnswerClients othersChans $ teamToNet $ newTeam ci clNick r, + AnswerClients othersChans ["TEAM_COLOR", name, color] + ] + where + canAddNumber r = 48 - (sum . map hhnum $ teams r) + findTeam = find (\t -> name == teamname t) . teams + newTeam ci clNick r = (TeamInfo ci clNick name color grave fort voicepack flag difficulty (newTeamHHNum r) (hhsList hhsInfo)) + difficulty = case B.readInt difStr of + Just (i, t) | B.null t -> fromIntegral i + otherwise -> 0 + hhsList [] = [] + hhsList [_] = error "Hedgehogs list with odd elements number" + hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs + newTeamHHNum r = min 4 (canAddNumber r) + +handleCmd_inRoom ["REMOVE_TEAM", name] = do + (ci, rnc) <- ask + r <- thisRoom + clNick <- clientNick + + let maybeTeam = findTeam r + let team = fromJust maybeTeam + + return $ + if isNothing $ findTeam r then + [Warning "REMOVE_TEAM: no such team"] + else if clNick /= teamowner team then + [ProtocolError "Not team owner!"] + else + [RemoveTeam name, + ModifyClient + (\c -> c{ + teamsInGame = teamsInGame c - 1, + clientClan = if teamsInGame c == 1 then undefined else anotherTeamClan ci r + }) + ] where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - canAddNumber = 48 - (sum . map hhnum $ teams room) - findTeam = find (\t -> name == teamname t) $ teams room - newTeam = (TeamInfo clID (nick client) name color grave fort voicepack flag difficulty newTeamHHNum (hhsList hhsInfo)) - difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int) - hhsList [] = [] - hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs - newTeamHHNum = min 4 canAddNumber - -handleCmd_inRoom clID clients rooms ["REMOVE_TEAM", teamName] - | noSuchTeam = [Warning "REMOVE_TEAM: no such team"] - | nick client /= teamowner team = [ProtocolError "Not team owner!"] - | otherwise = - [RemoveTeam teamName, - ModifyClient (\c -> c{teamsInGame = teamsInGame c - 1, clientClan = if teamsInGame client == 1 then undefined else anotherTeamClan}) - ] - where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams room - anotherTeamClan = teamcolor $ fromJust $ find (\t -> teamownerId t == clID) $ teams room + anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams + findTeam = find (\t -> name == teamname t) . teams -handleCmd_inRoom clID clients rooms ["HH_NUM", teamName, numberStr] - | not $ isMaster client = [ProtocolError "Not room master"] - | hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) = [] - | otherwise = - [ModifyRoom $ modifyTeam team{hhnum = hhNumber}, - AnswerOthersInRoom ["HH_NUM", teamName, show hhNumber]] +handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do + cl <- thisClient + others <- roomOthersChans + r <- thisRoom + + let maybeTeam = findTeam r + let team = fromJust maybeTeam + + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else if hhNumber < 1 || hhNumber > 8 || isNothing maybeTeam || hhNumber > (canAddNumber r) + (hhnum team) then + [] + else + [ModifyRoom $ modifyTeam team{hhnum = hhNumber}, + AnswerClients others ["HH_NUM", teamName, B.pack $ show hhNumber]] where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int) - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams room - canAddNumber = 48 - (sum . map hhnum $ teams room) + hhNumber = case B.readInt numberStr of + Just (i, t) | B.null t -> fromIntegral i + otherwise -> 0 + findTeam = find (\t -> teamName == teamname t) . teams + canAddNumber = (-) 48 . sum . map hhnum . teams + -handleCmd_inRoom clID clients rooms ["TEAM_COLOR", teamName, newColor] - | not $ isMaster client = [ProtocolError "Not room master"] - | noSuchTeam = [] - | otherwise = [ModifyRoom $ modifyTeam team{teamcolor = newColor}, - AnswerOthersInRoom ["TEAM_COLOR", teamName, newColor], +handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do + cl <- thisClient + others <- roomOthersChans + r <- thisRoom + + let maybeTeam = findTeam r + let team = fromJust maybeTeam + + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else if isNothing maybeTeam then + [] + else + [ModifyRoom $ modifyTeam team{teamcolor = newColor}, + AnswerClients others ["TEAM_COLOR", teamName, newColor], ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})] where - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams room - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) + findTeam = find (\t -> teamName == teamname t) . teams -handleCmd_inRoom clID clients rooms ["TOGGLE_READY"] = - [ModifyClient (\c -> c{isReady = not $ isReady client}), - ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady client then -1 else 1)}), - AnswerThisRoom [if isReady client then "NOT_READY" else "READY", nick client]] - where - client = clients IntMap.! clID +handleCmd_inRoom ["TOGGLE_READY"] = do + cl <- thisClient + chans <- roomClientsChans + return [ + ModifyClient (\c -> c{isReady = not $ isReady cl}), + ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)}), + AnswerClients chans [if isReady cl then "NOT_READY" else "READY", nick cl] + ] +handleCmd_inRoom ["START_GAME"] = do + cl <- thisClient + r <- thisRoom + chans <- roomClientsChans -handleCmd_inRoom clID clients rooms ["START_GAME"] = - if isMaster client && (playersIn room == readyPlayers room) && (not . gameinprogress) room then - if enoughClans then - [ModifyRoom + if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then + if enoughClans r then + return [ + ModifyRoom (\r -> r{ gameinprogress = True, roundMsgs = empty, leftTeams = [], teamsAtStart = teams r} ), - AnswerThisRoom ["RUN_GAME"]] + AnswerClients chans ["RUN_GAME"] + ] + else + return [Warning "Less than two clans!"] else - [Warning "Less than two clans!"] - else - [] + return [] where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room + enoughClans = not . null . drop 1 . group . map teamcolor . teams -handleCmd_inRoom clID clients rooms ["EM", msg] = - if (teamsInGame client > 0) && isLegal then - (AnswerOthersInRoom ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive] - else - [] +handleCmd_inRoom ["EM", msg] = do + cl <- thisClient + r <- thisRoom + chans <- roomOthersChans + + if (teamsInGame cl > 0) && isLegal then + return $ (AnswerClients chans ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive] + else + return [] where - client = clients IntMap.! clID (isLegal, isKeepAlive) = checkNetCmd msg -handleCmd_inRoom clID clients rooms ["ROUNDFINISHED"] = - if isMaster client then - [ModifyRoom + +handleCmd_inRoom ["ROUNDFINISHED"] = do + cl <- thisClient + r <- thisRoom + chans <- roomClientsChans + + if isMaster cl && (gameinprogress r) then + return $ (ModifyRoom (\r -> r{ gameinprogress = False, readyPlayers = 0, roundMsgs = empty, leftTeams = [], teamsAtStart = []} - ), - UnreadyRoomClients - ] ++ answerRemovedTeams - else - [] + )) + : UnreadyRoomClients + : answerRemovedTeams chans r + else + return [] where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room - + answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams -handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_JOINS"] - | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})] - | otherwise = [ProtocolError "Not room master"] - where - client = clients IntMap.! clID +handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do + cl <- thisClient + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else + [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})] -handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_TEAMS"] - | isMaster client = [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})] - | otherwise = [ProtocolError "Not room master"] - where - client = clients IntMap.! clID - -handleCmd_inRoom clID clients rooms ["KICK", kickNick] = - [KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)] - where - client = clients IntMap.! clID - maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients - noSuchClient = isNothing maybeClient - kickClient = fromJust maybeClient - kickID = clientUID kickClient +handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do + cl <- thisClient + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else + [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})] -handleCmd_inRoom clID clients _ ["TEAMCHAT", msg] = - [AnswerSameClan ["EM", engineMsg]] +handleCmd_inRoom ["KICK", kickNick] = do + (thisClientId, rnc) <- ask + maybeClientId <- clientByNick kickNick + master <- liftM isMaster thisClient + let kickId = fromJust maybeClientId + let sameRoom = (clientRoom rnc thisClientId) == (clientRoom rnc kickId) + return + [KickRoomClient kickId | master && isJust maybeClientId && (kickId /= thisClientId) && sameRoom] + + +handleCmd_inRoom ["TEAMCHAT", msg] = do + cl <- thisClient + chans <- roomSameClanChans + return [AnswerClients chans ["EM", engineMsg cl]] where - client = clients IntMap.! clID - engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20") + engineMsg cl = toEngineMsg $ "b" `B.append` (nick cl) `B.append` "(team): " `B.append` msg `B.append` "\x20\x20" -handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"] +handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"]