+
−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 Maybe
+
−--------------------------------------
+
−import CoreTypes
+
−import Actions
+
−import Utils
+
−
+
−
+
−handleCmd_inRoom :: CmdHandler
+
−
+
−handleCmd_inRoom clID clients _ ["CHAT", msg] =
+
−    [AnswerOthersInRoom ["CHAT", clientNick, msg]]
+
−    where
+
−        clientNick = nick $ clients IntMap.! clID
+
−
+
−handleCmd_inRoom clID clients rooms ["PART"] =
+
−    [RoomRemoveThisClient "part"]
+
−    where
+
−        client = clients IntMap.! clID
+
−
+
−
+
−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 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 (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
+
−
+
−
+
−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
+
−        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 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
+
−        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 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 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}
+
−                    ),
+
−            AnswerThisRoom ["RUN_GAME"]]
+
−        else
+
−            [Warning "Less than two clans!"]
+
−    else
+
−        []
+
−    where
+
−        client = clients IntMap.! clID
+
−        room = rooms IntMap.! (roomID client)
+
−        enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room
+
−
+
−
+
−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 clID clients rooms ["ROUNDFINISHED"] =
+
−    if isMaster client then
+
−        [ModifyRoom
+
−                (\r -> r{
+
−                    gameinprogress = False,
+
−                    readyPlayers = 0,
+
−                    roundMsgs = empty,
+
−                    leftTeams = [],
+
−                    teamsAtStart = []}
+
−                ),
+
−        UnreadyRoomClients
+
−        ] ++ answerRemovedTeams
+
−    else
+
−        []
+
−    where
+
−        client = clients IntMap.! clID
+
−        room = rooms IntMap.! (roomID client)
+
−        answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room
+
−
+
−
+
−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
+
−        client = clients IntMap.! clID
+
−        maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients
+
−        noSuchClient = isNothing maybeClient
+
−        kickClient = fromJust maybeClient
+
−        kickID = clientUID kickClient
+
−
+
−
+
−handleCmd_inRoom clID clients _ ["TEAMCHAT", msg] =
+
−    [AnswerSameClan ["EM", engineMsg]]
+
−    where
+
−        client = clients IntMap.! clID
+
−        engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20")
+
−
+
−handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"]