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