gameServer/HWProtoInRoomState.hs
changeset 4588 5ef5415c4ee1
parent 4568 f85243bf890e
child 4681 f2c30204a3fd
equal deleted inserted replaced
4529:467ab0685890 4588:5ef5415c4ee1
     1 {-# LANGUAGE OverloadedStrings #-}
       
     2 module HWProtoInRoomState where
     1 module HWProtoInRoomState where
     3 
     2 
     4 import qualified Data.Foldable as Foldable
     3 import qualified Data.Foldable as Foldable
       
     4 import qualified Data.IntMap as IntMap
     5 import qualified Data.Map as Map
     5 import qualified Data.Map as Map
     6 import Data.Sequence(Seq, (|>), (><), fromList, empty)
     6 import Data.Sequence(Seq, (|>), (><), fromList, empty)
     7 import Data.List
     7 import Data.List
     8 import Data.Maybe
     8 import Data.Maybe
     9 import qualified Data.ByteString.Char8 as B
       
    10 import Control.Monad
       
    11 import Control.Monad.Reader
       
    12 --------------------------------------
     9 --------------------------------------
    13 import CoreTypes
    10 import CoreTypes
    14 import Actions
    11 import Actions
    15 import Utils
    12 import Utils
    16 import HandlerUtils
    13 
    17 import RoomsAndClients
       
    18 
    14 
    19 handleCmd_inRoom :: CmdHandler
    15 handleCmd_inRoom :: CmdHandler
    20 
    16 
    21 handleCmd_inRoom ["CHAT", msg] = do
    17 handleCmd_inRoom clID clients _ ["CHAT", msg] =
    22     n <- clientNick
    18     [AnswerOthersInRoom ["CHAT", clientNick, msg]]
    23     s <- roomOthersChans
    19     where
    24     return [AnswerClients s ["CHAT", n, msg]]
    20         clientNick = nick $ clients IntMap.! clID
    25 
    21 
    26 handleCmd_inRoom ["PART"] = return [MoveToLobby "part"]
    22 handleCmd_inRoom clID clients rooms ["PART"] =
    27 handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg]
    23     [RoomRemoveThisClient "part"]
       
    24     where
       
    25         client = clients IntMap.! clID
    28 
    26 
    29 
    27 
    30 handleCmd_inRoom ("CFG" : paramName : paramStrs)
    28 handleCmd_inRoom clID clients rooms ("CFG" : paramName : paramStrs)
    31     | null paramStrs = return [ProtocolError "Empty config entry"]
    29     | null paramStrs = [ProtocolError "Empty config entry"]
    32     | otherwise = do
    30     | isMaster client =
    33         chans <- roomOthersChans
    31         [ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}),
    34         cl <- thisClient
    32         AnswerOthersInRoom ("CFG" : paramName : paramStrs)]
    35         if isMaster cl then
    33     | otherwise = [ProtocolError "Not room master"]
    36            return [
    34     where
    37                 ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}),
    35         client = clients IntMap.! clID
    38                 AnswerClients chans ("CFG" : paramName : paramStrs)]
       
    39             else
       
    40             return [ProtocolError "Not room master"]
       
    41 
    36 
    42 handleCmd_inRoom ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo)
    37 handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo)
    43     | length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"]
    38     | length hhsInfo == 15 && clientProto client < 30 = handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : " " : flag : difStr : hhsInfo)
    44     | otherwise = do
    39     | length hhsInfo /= 16 = [ProtocolError "Corrupted hedgehogs info"]
    45         (ci, rnc) <- ask
    40     | length (teams room) == 6 = [Warning "too many teams"]
    46         r <- thisRoom
    41     | canAddNumber <= 0 = [Warning "too many hedgehogs"]
    47         clNick <- clientNick
    42     | isJust findTeam = [Warning "There's already a team with same name in the list"]
    48         clChan <- thisClientChans
    43     | gameinprogress room = [Warning "round in progress"]
    49         othersChans <- roomOthersChans
    44     | isRestrictedTeams room = [Warning "restricted"]
    50         return $
    45     | otherwise =
    51             if not . null . drop 5 $ teams r then
    46         [ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}),
    52                 [Warning "too many teams"]
    47         ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}),
    53             else if canAddNumber r <= 0 then
    48         AnswerThisClient ["TEAM_ACCEPTED", name],
    54                 [Warning "too many hedgehogs"]
    49         AnswerOthersInRoom $ teamToNet (clientProto client) newTeam,
    55             else if isJust $ findTeam r then
    50         AnswerOthersInRoom ["TEAM_COLOR", name, color]
    56                 [Warning "There's already a team with same name in the list"]
    51         ]
    57             else if gameinprogress r then
    52     where
    58                 [Warning "round in progress"]
    53         client = clients IntMap.! clID
    59             else if isRestrictedTeams r then
    54         room = rooms IntMap.! (roomID client)
    60                 [Warning "restricted"]
    55         canAddNumber = 48 - (sum . map hhnum $ teams room)
    61             else
    56         findTeam = find (\t -> name == teamname t) $ teams room
    62                 [ModifyRoom (\r -> r{teams = teams r ++ [newTeam ci clNick r]}),
    57         newTeam = (TeamInfo clID (nick client) name color grave fort voicepack flag difficulty newTeamHHNum (hhsList hhsInfo))
    63                 ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}),
    58         difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int)
    64                 AnswerClients clChan ["TEAM_ACCEPTED", name],
       
    65                 AnswerClients othersChans $ teamToNet $ newTeam ci clNick r,
       
    66                 AnswerClients othersChans ["TEAM_COLOR", name, color]
       
    67                 ]
       
    68         where
       
    69         canAddNumber r = 48 - (sum . map hhnum $ teams r)
       
    70         findTeam = find (\t -> name == teamname t) . teams
       
    71         newTeam ci clNick r = (TeamInfo ci clNick name color grave fort voicepack flag difficulty (newTeamHHNum r) (hhsList hhsInfo))
       
    72         difficulty = case B.readInt difStr of
       
    73                            Just (i, t) | B.null t -> fromIntegral i
       
    74                            otherwise -> 0
       
    75         hhsList [] = []
    59         hhsList [] = []
    76         hhsList [_] = error "Hedgehogs list with odd elements number"
       
    77         hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
    60         hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
    78         newTeamHHNum r = min 4 (canAddNumber r)
    61         newTeamHHNum = min 4 canAddNumber
    79 
    62 
    80 handleCmd_inRoom ["REMOVE_TEAM", name] = do
    63 handleCmd_inRoom clID clients rooms ["REMOVE_TEAM", teamName]
    81         (ci, rnc) <- ask
    64     | noSuchTeam = [Warning "REMOVE_TEAM: no such team"]
    82         r <- thisRoom
    65     | nick client /= teamowner team = [ProtocolError "Not team owner!"]
    83         clNick <- clientNick
    66     | otherwise =
    84 
    67             [RemoveTeam teamName,
    85         let maybeTeam = findTeam r
    68             ModifyClient (\c -> c{teamsInGame = teamsInGame c - 1, clientClan = if teamsInGame client == 1 then undefined else anotherTeamClan})
    86         let team = fromJust maybeTeam
    69             ]
    87 
       
    88         return $
       
    89             if isNothing $ findTeam r then
       
    90                 [Warning "REMOVE_TEAM: no such team"]
       
    91             else if clNick /= teamowner team then
       
    92                 [ProtocolError "Not team owner!"]
       
    93             else
       
    94                 [RemoveTeam name,
       
    95                 ModifyClient
       
    96                     (\c -> c{
       
    97                         teamsInGame = teamsInGame c - 1,
       
    98                         clientClan = if teamsInGame c == 1 then undefined else anotherTeamClan ci r
       
    99                         })
       
   100                 ]
       
   101     where
    70     where
   102         anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams
    71         client = clients IntMap.! clID
   103         findTeam = find (\t -> name == teamname t) . teams
    72         room = rooms IntMap.! (roomID client)
       
    73         noSuchTeam = isNothing findTeam
       
    74         team = fromJust findTeam
       
    75         findTeam = find (\t -> teamName == teamname t) $ teams room
       
    76         anotherTeamClan = teamcolor $ fromJust $ find (\t -> teamownerId t == clID) $ teams room
   104 
    77 
   105 
    78 
   106 handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do
    79 handleCmd_inRoom clID clients rooms ["HH_NUM", teamName, numberStr]
   107     cl <- thisClient
    80     | not $ isMaster client = [ProtocolError "Not room master"]
   108     others <- roomOthersChans
    81     | hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) = []
   109     r <- thisRoom
    82     | otherwise =
   110 
    83         [ModifyRoom $ modifyTeam team{hhnum = hhNumber},
   111     let maybeTeam = findTeam r
    84         AnswerOthersInRoom ["HH_NUM", teamName, show hhNumber]]
   112     let team = fromJust maybeTeam
       
   113 
       
   114     return $
       
   115         if not $ isMaster cl then
       
   116             [ProtocolError "Not room master"]
       
   117         else if hhNumber < 1 || hhNumber > 8 || isNothing maybeTeam || hhNumber > (canAddNumber r) + (hhnum team) then
       
   118             []
       
   119         else
       
   120             [ModifyRoom $ modifyTeam team{hhnum = hhNumber},
       
   121             AnswerClients others ["HH_NUM", teamName, B.pack $ show hhNumber]]
       
   122     where
    85     where
   123         hhNumber = case B.readInt numberStr of
    86         client = clients IntMap.! clID
   124                            Just (i, t) | B.null t -> fromIntegral i
    87         room = rooms IntMap.! (roomID client)
   125                            otherwise -> 0
    88         hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
   126         findTeam = find (\t -> teamName == teamname t) . teams
    89         noSuchTeam = isNothing findTeam
   127         canAddNumber = (-) 48 . sum . map hhnum . teams
    90         team = fromJust findTeam
       
    91         findTeam = find (\t -> teamName == teamname t) $ teams room
       
    92         canAddNumber = 48 - (sum . map hhnum $ teams room)
   128 
    93 
   129 
    94 
   130 
    95 handleCmd_inRoom clID clients rooms ["TEAM_COLOR", teamName, newColor]
   131 handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do
    96     | not $ isMaster client = [ProtocolError "Not room master"]
   132     cl <- thisClient
    97     | noSuchTeam = []
   133     others <- roomOthersChans
    98     | otherwise = [ModifyRoom $ modifyTeam team{teamcolor = newColor},
   134     r <- thisRoom
    99             AnswerOthersInRoom ["TEAM_COLOR", teamName, newColor],
   135 
       
   136     let maybeTeam = findTeam r
       
   137     let team = fromJust maybeTeam
       
   138 
       
   139     return $
       
   140         if not $ isMaster cl then
       
   141             [ProtocolError "Not room master"]
       
   142         else if isNothing maybeTeam then
       
   143             []
       
   144         else
       
   145             [ModifyRoom $ modifyTeam team{teamcolor = newColor},
       
   146             AnswerClients others ["TEAM_COLOR", teamName, newColor],
       
   147             ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})]
   100             ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})]
   148     where
   101     where
   149         findTeam = find (\t -> teamName == teamname t) . teams
   102         noSuchTeam = isNothing findTeam
       
   103         team = fromJust findTeam
       
   104         findTeam = find (\t -> teamName == teamname t) $ teams room
       
   105         client = clients IntMap.! clID
       
   106         room = rooms IntMap.! (roomID client)
   150 
   107 
   151 
   108 
   152 handleCmd_inRoom ["TOGGLE_READY"] = do
   109 handleCmd_inRoom clID clients rooms ["TOGGLE_READY"] =
   153     cl <- thisClient
   110     [ModifyClient (\c -> c{isReady = not $ isReady client}),
   154     chans <- roomClientsChans
   111     ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady client then -1 else 1)}),
   155     return [
   112     AnswerThisRoom [if isReady client then "NOT_READY" else "READY", nick client]]
   156         ModifyClient (\c -> c{isReady = not $ isReady cl}),
   113     where
   157         ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)}),
   114         client = clients IntMap.! clID
   158         AnswerClients chans [if isReady cl then "NOT_READY" else "READY", nick cl]
       
   159         ]
       
   160 
   115 
   161 handleCmd_inRoom ["START_GAME"] = do
       
   162     cl <- thisClient
       
   163     r <- thisRoom
       
   164     chans <- roomClientsChans
       
   165 
   116 
   166     if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then
   117 handleCmd_inRoom clID clients rooms ["START_GAME"] =
   167         if enoughClans r then
   118     if isMaster client && (playersIn room == readyPlayers room) && (not . gameinprogress) room then
   168             return [
   119         if enoughClans then
   169                 ModifyRoom
   120             [ModifyRoom
   170                     (\r -> r{
   121                     (\r -> r{
   171                         gameinprogress = True,
   122                         gameinprogress = True,
   172                         roundMsgs = empty,
   123                         roundMsgs = empty,
   173                         leftTeams = [],
   124                         leftTeams = [],
   174                         teamsAtStart = teams r}
   125                         teamsAtStart = teams r}
   175                     ),
   126                     ),
   176                 AnswerClients chans ["RUN_GAME"]
   127             AnswerThisRoom ["RUN_GAME"]]
   177                 ]
       
   178             else
       
   179             return [Warning "Less than two clans!"]
       
   180         else
   128         else
   181         return []
   129             [Warning "Less than two clans!"]
       
   130     else
       
   131         []
   182     where
   132     where
   183         enoughClans = not . null . drop 1 . group . map teamcolor . teams
   133         client = clients IntMap.! clID
       
   134         room = rooms IntMap.! (roomID client)
       
   135         enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room
   184 
   136 
   185 
   137 
   186 handleCmd_inRoom ["EM", msg] = do
   138 handleCmd_inRoom clID clients rooms ["EM", msg] =
   187     cl <- thisClient
   139     if (teamsInGame client > 0) && isLegal then
   188     r <- thisRoom
   140         (AnswerOthersInRoom ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive]
   189     chans <- roomOthersChans
   141     else
   190     
   142         []
   191     if (teamsInGame cl > 0) && isLegal then
       
   192         return $ (AnswerClients chans ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive]
       
   193         else
       
   194         return []
       
   195     where
   143     where
       
   144         client = clients IntMap.! clID
   196         (isLegal, isKeepAlive) = checkNetCmd msg
   145         (isLegal, isKeepAlive) = checkNetCmd msg
   197 
   146 
   198 
   147 handleCmd_inRoom clID clients rooms ["ROUNDFINISHED"] =
   199 handleCmd_inRoom ["ROUNDFINISHED"] = do
   148     if isMaster client then
   200     cl <- thisClient
   149         [ModifyRoom
   201     r <- thisRoom
       
   202     chans <- roomClientsChans
       
   203 
       
   204     if isMaster cl && (gameinprogress r) then
       
   205         return $ (ModifyRoom
       
   206                 (\r -> r{
   150                 (\r -> r{
   207                     gameinprogress = False,
   151                     gameinprogress = False,
   208                     readyPlayers = 0,
   152                     readyPlayers = 0,
   209                     roundMsgs = empty,
   153                     roundMsgs = empty,
   210                     leftTeams = [],
   154                     leftTeams = [],
   211                     teamsAtStart = []}
   155                     teamsAtStart = []}
   212                 ))
   156                 ),
   213             : UnreadyRoomClients
   157         UnreadyRoomClients
   214             : answerRemovedTeams chans r
   158         ] ++ answerRemovedTeams
   215         else
   159     else
   216         return []
   160         []
   217     where
   161     where
   218         answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams
   162         client = clients IntMap.! clID
   219 
   163         room = rooms IntMap.! (roomID client)
   220 handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do
   164         answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room
   221     cl <- thisClient
       
   222     return $
       
   223         if not $ isMaster cl then
       
   224             [ProtocolError "Not room master"]
       
   225         else
       
   226             [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
       
   227 
   165 
   228 
   166 
   229 handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do
   167 handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_JOINS"]
   230     cl <- thisClient
   168     | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
   231     return $
   169     | otherwise = [ProtocolError "Not room master"]
   232         if not $ isMaster cl then
   170     where
   233             [ProtocolError "Not room master"]
   171         client = clients IntMap.! clID
   234         else
       
   235             [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
       
   236 
   172 
   237 {-
   173 
       
   174 handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_TEAMS"]
       
   175     | isMaster client = [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
       
   176     | otherwise = [ProtocolError "Not room master"]
       
   177     where
       
   178         client = clients IntMap.! clID
       
   179 
   238 handleCmd_inRoom clID clients rooms ["KICK", kickNick] =
   180 handleCmd_inRoom clID clients rooms ["KICK", kickNick] =
   239     [KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)]
   181     [KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)]
   240     where
   182     where
   241         client = clients IntMap.! clID
   183         client = clients IntMap.! clID
   242         maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients
   184         maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients
   248 handleCmd_inRoom clID clients _ ["TEAMCHAT", msg] =
   190 handleCmd_inRoom clID clients _ ["TEAMCHAT", msg] =
   249     [AnswerSameClan ["EM", engineMsg]]
   191     [AnswerSameClan ["EM", engineMsg]]
   250     where
   192     where
   251         client = clients IntMap.! clID
   193         client = clients IntMap.! clID
   252         engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20")
   194         engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20")
   253 -}
   195 
   254 handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"]
   196 handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"]