--- a/gameServer/HWProtoInRoomState.hs Sun Dec 19 20:45:15 2010 +0300
+++ b/gameServer/HWProtoInRoomState.hs Sun Dec 19 13:31:55 2010 -0500
@@ -1,240 +1,182 @@
-{-# 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.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 ["CHAT", msg] = do
- n <- clientNick
- s <- roomOthersChans
- return [AnswerClients s ["CHAT", n, msg]]
+handleCmd_inRoom clID clients _ ["CHAT", msg] =
+ [AnswerOthersInRoom ["CHAT", clientNick, msg]]
+ where
+ clientNick = nick $ clients IntMap.! clID
-handleCmd_inRoom ["PART"] = return [MoveToLobby "part"]
-handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg]
+handleCmd_inRoom clID clients rooms ["PART"] =
+ [RoomRemoveThisClient "part"]
+ 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 ("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 ("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
+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) == 6 = [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]
+ ]
+ 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 [_] = 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
+ newTeamHHNum = min 4 canAddNumber
- 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
- })
- ]
+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
- anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams
- findTeam = find (\t -> name == teamname t) . teams
+ 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
-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]]
+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]]
where
- 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
-
+ 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)
-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],
+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],
ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})]
where
- findTeam = find (\t -> teamName == teamname t) . teams
+ noSuchTeam = isNothing findTeam
+ team = fromJust findTeam
+ findTeam = find (\t -> teamName == teamname t) $ teams room
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
-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 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 ["START_GAME"] = do
- cl <- thisClient
- r <- thisRoom
- chans <- roomClientsChans
- if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then
- if enoughClans r then
- return [
- ModifyRoom
+handleCmd_inRoom clID clients rooms ["START_GAME"] =
+ if isMaster client && (playersIn room == readyPlayers room) && (not . gameinprogress) room then
+ if enoughClans then
+ [ModifyRoom
(\r -> r{
gameinprogress = True,
roundMsgs = empty,
leftTeams = [],
teamsAtStart = teams r}
),
- AnswerClients chans ["RUN_GAME"]
- ]
- else
- return [Warning "Less than two clans!"]
+ AnswerThisRoom ["RUN_GAME"]]
else
- return []
+ [Warning "Less than two clans!"]
+ else
+ []
where
- enoughClans = not . null . drop 1 . group . map teamcolor . teams
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
+ enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room
-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 []
+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
+ []
where
+ client = clients IntMap.! clID
(isLegal, isKeepAlive) = checkNetCmd msg
-
-handleCmd_inRoom ["ROUNDFINISHED"] = do
- cl <- thisClient
- r <- thisRoom
- chans <- roomClientsChans
-
- if isMaster cl && (gameinprogress r) then
- return $ (ModifyRoom
+handleCmd_inRoom clID clients rooms ["ROUNDFINISHED"] =
+ if isMaster client then
+ [ModifyRoom
(\r -> r{
gameinprogress = False,
readyPlayers = 0,
roundMsgs = empty,
leftTeams = [],
teamsAtStart = []}
- ))
- : UnreadyRoomClients
- : answerRemovedTeams chans r
- else
- return []
+ ),
+ UnreadyRoomClients
+ ] ++ answerRemovedTeams
+ else
+ []
where
- answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams
-
-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})]
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
+ answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room
-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 _ ["TOGGLE_RESTRICT_JOINS"]
+ | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
+ | otherwise = [ProtocolError "Not room master"]
+ where
+ client = clients IntMap.! clID
+
-{-
+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
@@ -250,5 +192,5 @@
where
client = clients IntMap.! clID
engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20")
--}
-handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"]
+
+handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"]