gameServer/HWProtoInRoomState.hs
author nemo
Sat, 01 Mar 2014 14:52:36 -0500
changeset 10171 00f41ff0bf2d
parent 10095 003fc694c0c3
child 10194 7025bd3c3131
permissions -rw-r--r--
Script might well override a static map, but can't risk it not doing it, and preview completely failing. Better to just not try it for static maps. Some script cfg might help. Could also avoid unnnecessary preview regenerations even if the script was doing nothing at all.

{-# LANGUAGE OverloadedStrings #-}
module HWProtoInRoomState where

import qualified Data.Map as Map
import Data.List as L
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
import EngineInteraction
import Votes

startGame :: Reader (ClientIndex, IRnC) [Action]
startGame = do
    (ci, rnc) <- ask
    cl <- thisClient
    rm <- thisRoom
    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 (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)
                        }
                    )
                , AnswerClients chans ["RUN_GAME"]
                , SendUpdateOnThisRoom
                , AnswerClients chans $ "CLIENT_FLAGS" : "+g" : nicks
                , ModifyRoomClients (\c -> c{isInGame = True})
                ]
            else
            return [Warning $ loc "Less than two clans!"]
        else
        return []
    where
        enoughClans = not . null . drop 1 . group . map teamcolor . teams



handleCmd_inRoom :: CmdHandler

handleCmd_inRoom ["CHAT", msg] = do
    n <- clientNick
    s <- roomOthersChans
    return [AnswerClients s ["CHAT", n, msg]]

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 $ loc "Empty config entry"]
    | otherwise = do
        chans <- roomOthersChans
        cl <- thisClient
        rm <- thisRoom

        if isSpecial rm then
            return [Warning $ loc "Restricted"]
        else if isMaster cl then
           return [
                ModifyRoom f,
                AnswerClients chans ("CFG" : paramName : paramStrs)]
            else
            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 $ loc "Corrupted hedgehogs info"]
    | otherwise = do
        (ci, _) <- ask
        rm <- thisRoom
        clNick <- clientNick
        clChan <- thisClientChans
        othChans <- roomOthersChans
        roomChans <- roomClientsChans
        cl <- thisClient
        teamColor <-
            if clientProto cl < 42 then
                return color
                else
                liftM (head . (L.\\) (map B.singleton ['0'..]) . map teamcolor . teams) thisRoom
        let roomTeams = teams rm
        let hhNum = let p = if not $ null roomTeams then minimum [hhnum $ head roomTeams, canAddNumber 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) $ roomTeams then
                [Warning $ loc "too many teams"]
            else if canAddNumber roomTeams <= 0 then
                [Warning $ loc "too many hedgehogs"]
            else if isJust $ findTeam rm then
                [Warning $ loc "There's already a team with same name in the list"]
            else if isJust $ gameInfo rm then
                [Warning $ loc "round in progress"]
            else if isRestrictedTeams rm then
                [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 othChans $ teamToNet $ newTeam,
                AnswerClients roomChans ["TEAM_COLOR", tName, teamColor],
                AnswerClients roomChans ["HH_NUM", tName, showB $ hhnum newTeam]
                ]
        where
        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 rt p = min p (canAddNumber rt)
        maxTeams r
            | roomProto r < 38 = 6
            | otherwise = 8


handleCmd_inRoom ["REMOVE_TEAM", tName] = do
        (ci, _) <- ask
        r <- thisRoom

        let maybeTeam = findTeam r
        let team = fromJust maybeTeam

        return $
            if isNothing $ maybeTeam then
                [Warning $ loc "REMOVE_TEAM: no such team"]
            else if ci /= teamownerId team then
                [ProtocolError $ loc "Not team owner!"]
            else
                [RemoveTeam tName,
                ModifyClient
                    (\c -> c{
                        teamsInGame = teamsInGame c - 1,
                        clientClan = if teamsInGame c == 1 then Nothing else Just $ anotherTeamClan ci team r
                    })
                ]
    where
        anotherTeamClan ci team = teamcolor . fromMaybe (error "CHECKPOINT 011") . find (\t -> (teamownerId t == ci) && (t /= team)) . teams
        findTeam = find (\t -> tName == teamname t) . teams


handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do
    cl <- thisClient
    r <- thisRoom
    clChan <- thisClientChans
    others <- roomOthersChans

    let maybeTeam = findTeam r
    let team = fromJust maybeTeam

    return $
        if not $ isMaster cl then
            [ProtocolError $ loc "Not room master"]
        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]]
    where
        hhNumber = readInt_ numberStr
        findTeam = find (\t -> teamName == teamname t) . teams
        canAddNumber = (-) 48 . sum . map hhnum . teams



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 $ loc "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 = Just newColor})]
    where
        findTeam = find (\t -> teamName == teamname t) . teams


handleCmd_inRoom ["TOGGLE_READY"] = do
    cl <- thisClient
    rm <- thisRoom
    chans <- roomClientsChans

    (ci, rnc) <- ask
    let ri = clientRoom rnc ci
    let unreadyClients = filter (not . isReady) . map (client rnc) $ roomClients rnc ri

    gs <- if (not $ isReady cl) && (isSpecial rm) && (unreadyClients == [cl]) then startGame else return []

    return $
        ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)})
        : ModifyClient (\c -> c{isReady = not $ isReady cl})
        : (AnswerClients chans $ if clientProto cl < 38 then
                [if isReady cl then "NOT_READY" else "READY", nick cl]
                else
                ["CLIENT_FLAGS", if isReady cl then "-r" else "+r", nick cl])
        : gs


handleCmd_inRoom ["START_GAME"] = do
    cl <- thisClient
    if isMaster cl then startGame else return []

handleCmd_inRoom ["EM", msg] = do
    cl <- thisClient
    rm <- thisRoom
    chans <- roomOthersChans

    if teamsInGame cl > 0 && (isJust $ gameInfo rm) && (not $ B.null legalMsgs) then
        return $ AnswerClients chans ["EM", legalMsgs]
            : [ModifyRoom (\r -> r{gameInfo = liftM
                (\g -> g{
                    roundMsgs = if B.null nonEmptyMsgs then roundMsgs g else nonEmptyMsgs : roundMsgs g
                    , lastFilteredTimedMsg = fromMaybe (lastFilteredTimedMsg g) lastFTMsg})
                $ gameInfo r}), RegisterEvent EngineMessage]
        else
        return []
    where
        (legalMsgs, nonEmptyMsgs, lastFTMsg) = checkNetCmd msg


handleCmd_inRoom ["ROUNDFINISHED", _] = do
    cl <- thisClient
    rm <- thisRoom
    chans <- roomClientsChans

    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
            return $ unsetInGameState ++ map SendTeamRemovalMessage clTeams
            else
            return unsetInGameState
        else
        return [] -- don't accept this message twice
    where
--        isCorrect = correctly == "1"

-- compatibility with clients with protocol < 38
handleCmd_inRoom ["ROUNDFINISHED"] =
    handleCmd_inRoom ["ROUNDFINISHED", "1"]

handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do
    cl <- thisClient
    return $
        if not $ isMaster cl then
            [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 $ 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 $ loc "Not room master"]
        else
            [ModifyRoom (\r -> r{isRegisteredOnly = not $ isRegisteredOnly r})]


handleCmd_inRoom ["ROOM_NAME", newName] = do
    cl <- thisClient
    rs <- allRoomInfos
    rm <- thisRoom
    chans <- sameProtoChans

    return $
        if not $ isMaster cl then
            [ProtocolError $ loc "Not room master"]
        else
        if illegalName newName then
            [Warning $ loc "Illegal room name"]
        else
        if isSpecial rm then
            [Warning $ loc "Restricted"]
        else
        if isJust $ find (\r -> newName == name r) rs then
            [Warning $ loc "Room with such name already exists"]
        else
            [ModifyRoom roomUpdate,
            AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo (clientProto cl) (nick cl) (roomUpdate rm))]
    where
        roomUpdate r = r{name = newName}


handleCmd_inRoom ["KICK", kickNick] = do
    (thisClientId, rnc) <- ask
    maybeClientId <- clientByNick kickNick
    master <- liftM isMaster thisClient
    rm <- thisRoom
    let kickId = fromJust maybeClientId
    let kickCl = rnc `client` kickId
    let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId
    let notOnly2Players = (length . group . sort . map teamowner . teams $ rm) > 2
    return
        [KickRoomClient kickId |
            master
            && isJust maybeClientId
            && (kickId /= thisClientId)
            && sameRoom
            && ((isNothing $ gameInfo rm) || notOnly2Players || teamsInGame kickCl == 0)
        ]


handleCmd_inRoom ["DELEGATE", newAdmin] = do
    (thisClientId, rnc) <- ask
    maybeClientId <- clientByNick newAdmin
    master <- liftM isMaster thisClient
    serverAdmin <- liftM isAdministrator thisClient
    thisRoomMasterId <- liftM masterID thisRoom
    let newAdminId = fromJust maybeClientId
    let sameRoom = clientRoom rnc thisClientId == clientRoom rnc newAdminId
    return
        [ChangeMaster (Just newAdminId) |
            (master || serverAdmin)
                && isJust maybeClientId
                && (Just newAdminId /= thisRoomMasterId)
                && sameRoom]


handleCmd_inRoom ["TEAMCHAT", msg] = do
    cl <- thisClient
    chans <- roomSameClanChans
    return [AnswerClients chans ["EM", engineMsg cl]]
    where
        engineMsg cl = toEngineMsg $ B.concat ["b", nick cl, " (team): ", msg, "\x20\x20"]


handleCmd_inRoom ["BAN", banNick] = do
    (thisClientId, rnc) <- ask
    maybeClientId <- clientByNick banNick
    master <- liftM isMaster thisClient
    let banId = fromJust maybeClientId
    let sameRoom = clientRoom rnc thisClientId == clientRoom rnc banId
    if master && isJust maybeClientId && (banId /= thisClientId) && sameRoom then
        return [
--                ModifyRoom (\r -> r{roomBansList = let h = host $ rnc `client` banId in h `deepseq` h : roomBansList r})
                KickRoomClient banId
            ]
        else
        return []

handleCmd_inRoom ("RND":rs) = do
    n <- clientNick
    s <- roomClientsChans
    return [AnswerClients s ["CHAT", n, B.unwords $ "/rnd" : rs], Random s rs]

handleCmd_inRoom ["FIX"] = do
    cl <- thisClient
    return [ModifyRoom (\r -> r{isSpecial = True}) | isAdministrator cl]

handleCmd_inRoom ["UNFIX"] = do
    cl <- thisClient
    return [ModifyRoom (\r -> r{isSpecial = False}) | isAdministrator cl]

handleCmd_inRoom ["GREETING", msg] = do
    cl <- thisClient
    rm <- thisRoom
    return [ModifyRoom (\r -> r{greeting = msg}) | isAdministrator cl || (isMaster cl && (not $ isSpecial rm))]


handleCmd_inRoom ["CALLVOTE"] = do
    cl <- thisClient
    return [AnswerClients [sendChan cl] ["CHAT", "[server]", "Available callvote commands: kick <nickname>"]]

handleCmd_inRoom ["CALLVOTE", "KICK"] = do
    cl <- thisClient
    return [AnswerClients [sendChan cl] ["CHAT", "[server]", "callvote kick: specify nickname"]]

handleCmd_inRoom ["CALLVOTE", "KICK", nickname] = do
    (thisClientId, rnc) <- ask
    cl <- thisClient
    rm <- thisRoom
    maybeClientId <- clientByNick nickname
    let kickId = fromJust maybeClientId
    let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId

    if isNothing $ masterID rm then
        return []
        else
        if isJust maybeClientId && sameRoom then
            startVote $ VoteKick nickname
            else
            return [AnswerClients [sendChan cl] ["CHAT", "[server]", "callvote kick: no such user"]]

handleCmd_inRoom ["VOTE", m] = do
    cl <- thisClient
    let b = if m == "YES" then Just True else if m == "NO" then Just False else Nothing
    if isJust b then
        voted (fromJust b)
        else
        return [AnswerClients [sendChan cl] ["CHAT", "[server]", "vote: 'yes' or 'no'"]]

handleCmd_inRoom ["LIST"] = return [] -- for old clients (<= 0.9.17)

handleCmd_inRoom (s:_) = return [ProtocolError $ "Incorrect command '" `B.append` s `B.append` "' (state: in room)"]

handleCmd_inRoom [] = return [ProtocolError "Empty command (state: in room)"]