1 module HWProto |
|
2 ( |
|
3 handleCmd |
|
4 ) where |
|
5 |
|
6 import IO |
|
7 import Data.List |
|
8 import Data.Word |
|
9 import Data.Sequence(Seq, (|>), (><), fromList, empty) |
|
10 import Data.Foldable(toList) |
|
11 import Miscutils |
|
12 import Maybe |
|
13 import qualified Data.Map as Map |
|
14 import Opts |
|
15 |
|
16 teamToNet protocol team = |
|
17 if protocol <= 21 then |
|
18 ["ADD_TEAM", teamname team, teamgrave team, teamfort team, show $ difficulty team] ++ hhsInfo |
|
19 else |
|
20 ["ADD_TEAM", teamname team, teamgrave team, teamfort team, teamvoicepack team, teamowner team, show $ difficulty team] ++ hhsInfo |
|
21 where |
|
22 hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team |
|
23 |
|
24 makeAnswer :: HandlesSelector -> [String] -> [Answer] |
|
25 makeAnswer func msg = [\_ -> (func, msg)] |
|
26 answerClientOnly, answerOthersRoom, answerSameRoom :: [String] -> [Answer] |
|
27 answerClientOnly = makeAnswer clientOnly |
|
28 answerOthersRoom = makeAnswer othersInRoom |
|
29 answerSameRoom = makeAnswer sameRoom |
|
30 answerSameProtoLobby = makeAnswer sameProtoLobbyClients |
|
31 answerOtherLobby = makeAnswer otherLobbyClients |
|
32 answerAll = makeAnswer allClients |
|
33 |
|
34 answerBadCmd = answerClientOnly ["ERROR", "Bad command, state or incorrect parameter"] |
|
35 answerNotMaster = answerClientOnly ["ERROR", "You cannot configure room parameters"] |
|
36 answerBadParam = answerClientOnly ["ERROR", "Bad parameter"] |
|
37 answerErrorMsg msg = answerClientOnly ["ERROR", msg] |
|
38 answerQuit msg = answerClientOnly ["BYE", msg] |
|
39 answerNickChosen = answerClientOnly ["ERROR", "The nick already chosen"] |
|
40 answerNickChooseAnother = answerClientOnly ["WARNING", "Choose another nick"] |
|
41 answerNick nick = answerClientOnly ["NICK", nick] |
|
42 answerProtocolKnown = answerClientOnly ["ERROR", "Protocol number already known"] |
|
43 answerBadInput = answerClientOnly ["ERROR", "Bad input"] |
|
44 answerProto protoNum = answerClientOnly ["PROTO", show protoNum] |
|
45 answerRoomsList list = answerClientOnly $ "ROOMS" : list |
|
46 answerRoomExists = answerClientOnly ["WARNING", "There's already a room with that name"] |
|
47 answerNoRoom = answerClientOnly ["WARNING", "There's no room with that name"] |
|
48 answerWrongPassword = answerClientOnly ["WARNING", "Wrong password"] |
|
49 answerCantAdd reason = answerClientOnly ["WARNING", "Cannot add team: " ++ reason] |
|
50 answerTeamAccepted team = answerClientOnly ["TEAM_ACCEPTED", teamname team] |
|
51 answerTooFewClans = answerClientOnly ["ERROR", "Too few clans in game"] |
|
52 answerRestricted = answerClientOnly ["WARNING", "Room joining restricted"] |
|
53 answerConnected = answerClientOnly ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
|
54 answerNotOwner = answerClientOnly ["ERROR", "You do not own this team"] |
|
55 answerCannotCreateRoom = answerClientOnly ["WARNING", "Cannot create more rooms"] |
|
56 answerInfo client = answerClientOnly ["INFO", nick client, host client, proto2ver $ protocol client, roomInfo] |
|
57 where |
|
58 roomInfo = if not $ null $ room client then "room " ++ (room client) else "lobby" |
|
59 |
|
60 answerAbandoned protocol = |
|
61 if protocol < 20 then |
|
62 answerOthersRoom ["BYE", "Room abandoned"] |
|
63 else |
|
64 answerOthersRoom ["ROOMABANDONED"] |
|
65 |
|
66 answerChatString nick msg = answerOthersRoom ["CHAT_STRING", nick, msg] |
|
67 answerAddTeam protocol team = answerOthersRoom $ teamToNet protocol team |
|
68 answerRemoveTeam teamName = answerOthersRoom ["REMOVE_TEAM", teamName] |
|
69 answerMap mapName = answerOthersRoom ["MAP", mapName] |
|
70 answerHHNum teamName hhNumber = answerOthersRoom ["HH_NUM", teamName, show hhNumber] |
|
71 answerTeamColor teamName newColor = answerOthersRoom ["TEAM_COLOR", teamName, newColor] |
|
72 answerConfigParam paramName paramStrs = answerOthersRoom $ "CONFIG_PARAM" : paramName : paramStrs |
|
73 answerQuitInform nick msg = |
|
74 if not $ null msg then |
|
75 answerOthersRoom ["LEFT", nick, msg] |
|
76 else |
|
77 answerOthersRoom ["LEFT", nick] |
|
78 |
|
79 answerPartInform nick = answerOthersRoom ["LEFT", nick, "bye room"] |
|
80 answerQuitLobby nick msg = |
|
81 if not $ null nick then |
|
82 if not $ null msg then |
|
83 answerAll ["LOBBY:LEFT", nick, msg] |
|
84 else |
|
85 answerAll ["LOBBY:LEFT", nick] |
|
86 else |
|
87 [] |
|
88 |
|
89 answerJoined nick = answerSameRoom ["JOINED", nick] |
|
90 answerRunGame = answerSameRoom ["RUN_GAME"] |
|
91 answerIsReady nick = answerSameRoom ["READY", nick] |
|
92 answerNotReady nick = answerSameRoom ["NOT_READY", nick] |
|
93 |
|
94 answerRoomAdded name = answerSameProtoLobby ["ROOM", "ADD", name] |
|
95 answerRoomDeleted name = answerSameProtoLobby ["ROOM", "DEL", name] |
|
96 |
|
97 answerFullConfig room = concatMap toAnswer (Map.toList $ params room) ++ (answerClientOnly ["MAP", gamemap room]) |
|
98 where |
|
99 toAnswer (paramName, paramStrs) = |
|
100 answerClientOnly $ "CONFIG_PARAM" : paramName : paramStrs |
|
101 |
|
102 answerAllTeams protocol teams = concatMap toAnswer teams |
|
103 where |
|
104 toAnswer team = |
|
105 (answerClientOnly $ teamToNet protocol team) ++ |
|
106 (answerClientOnly ["TEAM_COLOR", teamname team, teamcolor team]) ++ |
|
107 (answerClientOnly ["HH_NUM", teamname team, show $ hhnum team]) |
|
108 |
|
109 answerServerMessage client clients = [\serverInfo -> (clientOnly, "SERVER_MESSAGE" : |
|
110 [(mainbody serverInfo) ++ updateInfo ++ clientsIn ++ (lastHour serverInfo)])] |
|
111 where |
|
112 mainbody serverInfo = serverMessage serverInfo ++ |
|
113 if isDedicated serverInfo then |
|
114 "<p align=center>Dedicated server</p>" |
|
115 else |
|
116 "<p align=center>Private server</p>" |
|
117 |
|
118 updateInfo = if protocol client < 23 then "<font color=yellow><h3>Hedgewars 0.9.9 is out!!! Please, update. Support for previous versions will be dropped soon</h3><p align=center><a href=http://hedgewars.org/download.html>Download page here</a></p><h4>New features are:</h4><ul><li>Voice packs</li><li>Precise aim</li><li>RC Plane weapon</li><li>...</li></ul></font>" else "" |
|
119 clientsIn = if protocol client < 20 then "<p align=left>" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "</p>" else [] |
|
120 clientslist = if not $ null nicks then foldr1 (\a b -> a ++ ", " ++ b) nicks else "" |
|
121 lastHour serverInfo = |
|
122 if isDedicated serverInfo then |
|
123 "<p align=left>" ++ (show $ length $ lastHourUsers serverInfo) ++ " user logins in last hour</p>" |
|
124 else |
|
125 "" |
|
126 nicks = filter (not . null) $ map nick clients |
|
127 |
|
128 answerPing = makeAnswer allClients ["PING"] |
|
129 |
|
130 -- Main state-independent cmd handler |
|
131 handleCmd :: CmdHandler |
|
132 handleCmd client _ rooms ("QUIT" : xs) = |
|
133 if null (room client) then |
|
134 (noChangeClients, noChangeRooms, answerQuit msg ++ (answerQuitLobby (nick client) msg) ) |
|
135 else if isMaster client then |
|
136 (modifyRoomClients clRoom (\cl -> cl{isReady = False, partRoom = True}), removeRoom (room client), (answerQuit msg) ++ (answerQuitLobby (nick client) msg) ++ (answerAbandoned $ protocol client) ++ (answerRoomDeleted $ room client)) -- core disconnects clients on ROOMABANDONED answer |
|
137 else |
|
138 if not $ gameinprogress clRoom then |
|
139 (noChangeClients, |
|
140 modifyRoom clRoom{ |
|
141 teams = othersTeams, |
|
142 playersIn = (playersIn clRoom) - 1, |
|
143 readyPlayers = newReadyPlayers |
|
144 }, |
|
145 (answerQuit msg) ++ |
|
146 (answerQuitInform (nick client) msg) ++ |
|
147 (answerQuitLobby (nick client) msg) ++ |
|
148 answerRemoveClientTeams) |
|
149 else |
|
150 (noChangeClients, |
|
151 modifyRoom clRoom{ |
|
152 teams = othersTeams, |
|
153 leftTeams = (map teamname clientTeams) ++ (leftTeams clRoom), |
|
154 roundMsgs = (roundMsgs clRoom) >< (fromList rmTeamsMsgs), |
|
155 playersIn = (playersIn clRoom) - 1, |
|
156 readyPlayers = newReadyPlayers |
|
157 }, |
|
158 (answerQuit msg) ++ |
|
159 (answerQuitInform (nick client) msg) ++ |
|
160 (answerQuitLobby (nick client) msg) ++ |
|
161 answerRemoveClientTeams ++ |
|
162 answerEngineTeamsRemoveMsg) |
|
163 where |
|
164 clRoom = roomByName (room client) rooms |
|
165 answerRemoveClientTeams = concatMap (\tn -> answerOthersRoom ["REMOVE_TEAM", teamname tn]) clientTeams |
|
166 (clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom |
|
167 newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom |
|
168 msg = if not $ null xs then head xs else "" |
|
169 rmTeamsMsgs = map (\team -> toEngineMsg $ 'F' : teamname team) clientTeams |
|
170 answerEngineTeamsRemoveMsg = |
|
171 if not $ null rmTeamsMsgs then |
|
172 answerOthersRoom $ "GAMEMSG" : rmTeamsMsgs |
|
173 else |
|
174 [] |
|
175 |
|
176 handleCmd _ _ _ ["PING"] = -- core requsted |
|
177 (noChangeClients, noChangeRooms, answerPing) |
|
178 |
|
179 handleCmd _ _ _ ["ASKME"] = -- core requsted |
|
180 (noChangeClients, noChangeRooms, answerConnected) |
|
181 |
|
182 handleCmd _ _ _ ["PONG"] = |
|
183 (noChangeClients, noChangeRooms, []) |
|
184 |
|
185 handleCmd _ _ _ ["ERROR", msg] = |
|
186 (noChangeClients, noChangeRooms, answerErrorMsg msg) |
|
187 |
|
188 handleCmd _ clients _ ["INFO", asknick] = |
|
189 if noSuchClient then |
|
190 (noChangeClients, noChangeRooms, []) |
|
191 else |
|
192 (noChangeClients, noChangeRooms, answerInfo client) |
|
193 where |
|
194 maybeClient = find (\cl -> asknick == nick cl) clients |
|
195 noSuchClient = isNothing maybeClient |
|
196 client = fromJust maybeClient |
|
197 |
|
198 |
|
199 -- check state and call state-dependent commmand handlers |
|
200 handleCmd client clients rooms cmd = |
|
201 if null (nick client) || protocol client == 0 then |
|
202 handleCmd_noInfo client clients rooms cmd |
|
203 else if null (room client) then |
|
204 handleCmd_noRoom client clients rooms cmd |
|
205 else |
|
206 handleCmd_inRoom client clients rooms cmd |
|
207 |
|
208 |
|
209 -- 'no info' state - need to get protocol number and nickname |
|
210 onLoginFinished client clients = |
|
211 if (null $ nick client) || (protocol client == 0) then |
|
212 [] |
|
213 else |
|
214 answerLobbyNicks ++ |
|
215 (answerAll ["LOBBY:JOINED", nick client]) ++ |
|
216 (answerServerMessage client clients) |
|
217 where |
|
218 lobbyNicks = filter (\n -> (not (null n)) && n /= nick client) $ map nick $ clients |
|
219 answerLobbyNicks = if not $ null lobbyNicks then |
|
220 answerClientOnly $ ["LOBBY:JOINED"] ++ lobbyNicks |
|
221 else |
|
222 [] |
|
223 |
|
224 handleCmd_noInfo :: CmdHandler |
|
225 handleCmd_noInfo client clients _ ["NICK", newNick] = |
|
226 if not . null $ nick client then |
|
227 (noChangeClients, noChangeRooms, answerNickChosen) |
|
228 else if haveSameNick then |
|
229 (noChangeClients, noChangeRooms, answerNickChooseAnother) |
|
230 else |
|
231 (modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick ++ (onLoginFinished client{nick = newNick} clients)) |
|
232 where |
|
233 haveSameNick = isJust $ find (\cl -> newNick == nick cl) clients |
|
234 |
|
235 handleCmd_noInfo client clients _ ["PROTO", protoNum] = |
|
236 if protocol client > 0 then |
|
237 (noChangeClients, noChangeRooms, answerProtocolKnown) |
|
238 else if parsedProto == 0 then |
|
239 (noChangeClients, noChangeRooms, answerBadInput) |
|
240 else |
|
241 (modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto ++ (onLoginFinished client{protocol = parsedProto} clients)) |
|
242 where |
|
243 parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16) |
|
244 |
|
245 handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
|
246 |
|
247 |
|
248 -- 'noRoom' clients state command handlers |
|
249 handleCmd_noRoom :: CmdHandler |
|
250 handleCmd_noRoom client clients rooms ["LIST"] = |
|
251 (noChangeClients, noChangeRooms, (answerRoomsList $ concatMap roomInfo $ sameProtoRooms)) |
|
252 where |
|
253 roomInfo room = [ |
|
254 name room, |
|
255 (show $ playersIn room) ++ "(" ++ (show $ length $ teams room) ++ ")", |
|
256 show $ gameinprogress room |
|
257 ] |
|
258 sameProtoRooms = filter (\r -> (roomProto r == protocol client) && (not $ isRestrictedJoins r)) rooms |
|
259 |
|
260 handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] = |
|
261 if haveSameRoom then |
|
262 (noChangeClients, noChangeRooms, answerRoomExists) |
|
263 else |
|
264 (modifyClient client{room = newRoom, isMaster = True}, addRoom createRoom{name = newRoom, password = roomPassword, roomProto = (protocol client)}, (answerJoined $ nick client) ++ (answerNotReady $ nick client) ++ (answerRoomAdded newRoom)) |
|
265 where |
|
266 haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms |
|
267 |
|
268 handleCmd_noRoom client clients rooms ["CREATE", newRoom] = |
|
269 handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""] |
|
270 |
|
271 handleCmd_noRoom client clients rooms ["JOIN", roomName, roomPassword] = |
|
272 if noSuchRoom then |
|
273 (noChangeClients, noChangeRooms, answerNoRoom) |
|
274 else if roomPassword /= password clRoom then |
|
275 (noChangeClients, noChangeRooms, answerWrongPassword) |
|
276 else if isRestrictedJoins clRoom then |
|
277 (noChangeClients, noChangeRooms, answerRestricted) |
|
278 else |
|
279 (modifyClient client{room = roomName}, modifyRoom clRoom{playersIn = 1 + playersIn clRoom}, (answerJoined $ nick client) ++ answerNicks ++ answerReady ++ (answerNotReady $ nick client) ++ answerFullConfig clRoom ++ answerTeams ++ watchRound) |
|
280 where |
|
281 noSuchRoom = isNothing $ find (\room -> roomName == name room && roomProto room == protocol client) rooms |
|
282 answerNicks = if not $ null sameRoomClients then |
|
283 answerClientOnly $ ["JOINED"] ++ (map nick $ sameRoomClients) |
|
284 else |
|
285 [] |
|
286 answerReady = concatMap (\c -> answerClientOnly [if isReady c then "READY" else "NOT_READY", nick c]) sameRoomClients |
|
287 sameRoomClients = filter (\ci -> room ci == roomName) clients |
|
288 clRoom = roomByName roomName rooms |
|
289 watchRound = if (roomProto clRoom < 20) || (not $ gameinprogress clRoom) then |
|
290 [] |
|
291 else |
|
292 (answerClientOnly ["RUN_GAME"]) ++ |
|
293 answerClientOnly ("GAMEMSG" : toEngineMsg "e$spectate 1" : (toList $ roundMsgs clRoom)) |
|
294 answerTeams = if gameinprogress clRoom then |
|
295 answerAllTeams (protocol client) (teamsAtStart clRoom) |
|
296 else |
|
297 answerAllTeams (protocol client) (teams clRoom) |
|
298 |
|
299 handleCmd_noRoom client clients rooms ["JOIN", roomName] = |
|
300 handleCmd_noRoom client clients rooms ["JOIN", roomName, ""] |
|
301 |
|
302 handleCmd_noRoom client _ _ ["CHAT_STRING", msg] = |
|
303 (noChangeClients, noChangeRooms, answerChatString (nick client) msg) |
|
304 |
|
305 handleCmd_noRoom client _ _ ["GLOBALMSG", password, msg] = |
|
306 (noChangeClients, noChangeRooms, [answer]) |
|
307 where |
|
308 answer = \serverInfo -> |
|
309 if (not $ null password) && (adminPassword serverInfo == password) then |
|
310 (allClients, ["CHAT_STRING", nick client, msg]) |
|
311 else |
|
312 (clientOnly, ["ERROR", "Wrong password"]) |
|
313 |
|
314 handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
|
315 |
|
316 |
|
317 -- 'inRoom' clients state command handlers |
|
318 handleCmd_inRoom :: CmdHandler |
|
319 handleCmd_inRoom client _ _ ["CHAT_STRING", msg] = |
|
320 (noChangeClients, noChangeRooms, answerChatString (nick client) msg) |
|
321 |
|
322 handleCmd_inRoom client _ rooms ("CONFIG_PARAM" : paramName : paramStrs) = |
|
323 if isMaster client then |
|
324 (noChangeClients, modifyRoom clRoom{params = Map.insert paramName paramStrs (params clRoom)}, answerConfigParam paramName paramStrs) |
|
325 else |
|
326 (noChangeClients, noChangeRooms, answerNotMaster) |
|
327 where |
|
328 clRoom = roomByName (room client) rooms |
|
329 |
|
330 handleCmd_inRoom client _ rooms ["PART"] = |
|
331 if isMaster client then |
|
332 (modifyRoomClients clRoom (\cl -> cl{isReady = False, isMaster = False, partRoom = True}), removeRoom (room client), (answerAbandoned $ protocol client) ++ (answerRoomDeleted $ room client)) |
|
333 else |
|
334 if not $ gameinprogress clRoom then |
|
335 (modifyClient client{ |
|
336 isReady = False, |
|
337 partRoom = True |
|
338 }, |
|
339 modifyRoom clRoom{ |
|
340 teams = othersTeams, |
|
341 playersIn = (playersIn clRoom) - 1, |
|
342 readyPlayers = newReadyPlayers |
|
343 }, |
|
344 (answerPartInform (nick client)) ++ answerRemoveClientTeams) |
|
345 else |
|
346 (modifyClient client{ |
|
347 isReady = False, |
|
348 partRoom = True |
|
349 }, |
|
350 modifyRoom clRoom{ |
|
351 teams = othersTeams, |
|
352 leftTeams = (map teamname clientTeams) ++ (leftTeams clRoom), |
|
353 roundMsgs = (roundMsgs clRoom) >< (fromList rmTeamsMsgs), |
|
354 playersIn = (playersIn clRoom) - 1, |
|
355 readyPlayers = newReadyPlayers |
|
356 }, |
|
357 answerEngineTeamsRemoveMsg ++ |
|
358 (answerPartInform (nick client)) ++ |
|
359 answerRemoveClientTeams) |
|
360 where |
|
361 clRoom = roomByName (room client) rooms |
|
362 answerRemoveClientTeams = concatMap (\tn -> answerOthersRoom ["REMOVE_TEAM", teamname tn]) clientTeams |
|
363 (clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom |
|
364 newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom |
|
365 rmTeamsMsgs = map (\team -> toEngineMsg $ 'F' : teamname team) clientTeams |
|
366 answerEngineTeamsRemoveMsg = |
|
367 if not $ null rmTeamsMsgs then |
|
368 answerOthersRoom $ "GAMEMSG" : rmTeamsMsgs |
|
369 else |
|
370 [] |
|
371 |
|
372 |
|
373 handleCmd_inRoom client _ rooms ["MAP", mapName] = |
|
374 if isMaster client then |
|
375 (noChangeClients, modifyRoom clRoom{gamemap = mapName}, answerMap mapName) |
|
376 else |
|
377 (noChangeClients, noChangeRooms, answerNotMaster) |
|
378 where |
|
379 clRoom = roomByName (room client) rooms |
|
380 |
|
381 handleCmd_inRoom client _ rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : difStr : hhsInfo) |
|
382 | length hhsInfo == 16 = |
|
383 if length (teams clRoom) == 6 then |
|
384 (noChangeClients, noChangeRooms, answerCantAdd "too many teams") |
|
385 else if canAddNumber <= 0 then |
|
386 (noChangeClients, noChangeRooms, answerCantAdd "too many hedgehogs") |
|
387 else if isJust findTeam then |
|
388 (noChangeClients, noChangeRooms, answerCantAdd "already has a team with same name") |
|
389 else if gameinprogress clRoom then |
|
390 (noChangeClients, noChangeRooms, answerCantAdd "round in progress") |
|
391 else if isRestrictedTeams clRoom then |
|
392 (noChangeClients, noChangeRooms, answerCantAdd "restricted") |
|
393 else |
|
394 (noChangeClients, modifyRoom clRoom{teams = teams clRoom ++ [newTeam]}, answerTeamAccepted newTeam ++ answerAddTeam (protocol client) newTeam ++ answerTeamColor name color) |
|
395 where |
|
396 clRoom = roomByName (room client) rooms |
|
397 newTeam = (TeamInfo (nick client) name color grave fort voicepack difficulty newTeamHHNum (hhsList hhsInfo)) |
|
398 findTeam = find (\t -> name == teamname t) $ teams clRoom |
|
399 difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int) |
|
400 hhsList [] = [] |
|
401 hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs |
|
402 canAddNumber = 48 - (sum . map hhnum $ teams clRoom) |
|
403 newTeamHHNum = min 4 canAddNumber |
|
404 |
|
405 handleCmd_inRoom client clients rooms ("ADD_TEAM" : name : color : grave : fort : difStr : hhsInfo) = |
|
406 handleCmd_inRoom client clients rooms ("ADD_TEAM" : name : color : grave : fort : "Default" : difStr : hhsInfo) |
|
407 |
|
408 |
|
409 handleCmd_inRoom client _ rooms ["HH_NUM", teamName, numberStr] = |
|
410 if not $ isMaster client then |
|
411 (noChangeClients, noChangeRooms, answerNotMaster) |
|
412 else |
|
413 if hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) then |
|
414 (noChangeClients, noChangeRooms, []) |
|
415 else |
|
416 (noChangeClients, modifyRoom $ modifyTeam clRoom team{hhnum = hhNumber}, answerHHNum teamName hhNumber) |
|
417 where |
|
418 hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int) |
|
419 noSuchTeam = isNothing findTeam |
|
420 team = fromJust findTeam |
|
421 findTeam = find (\t -> teamName == teamname t) $ teams clRoom |
|
422 clRoom = roomByName (room client) rooms |
|
423 canAddNumber = 48 - (sum . map hhnum $ teams clRoom) |
|
424 |
|
425 handleCmd_inRoom client _ rooms ["TEAM_COLOR", teamName, newColor] = |
|
426 if not $ isMaster client then |
|
427 (noChangeClients, noChangeRooms, answerNotMaster) |
|
428 else |
|
429 if noSuchTeam then |
|
430 (noChangeClients, noChangeRooms, []) |
|
431 else |
|
432 (noChangeClients, modifyRoom $ modifyTeam clRoom team{teamcolor = newColor}, answerTeamColor teamName newColor) |
|
433 where |
|
434 noSuchTeam = isNothing findTeam |
|
435 team = fromJust findTeam |
|
436 findTeam = find (\t -> teamName == teamname t) $ teams clRoom |
|
437 clRoom = roomByName (room client) rooms |
|
438 |
|
439 handleCmd_inRoom client _ rooms ["REMOVE_TEAM", teamName] = |
|
440 if noSuchTeam then |
|
441 (noChangeClients, noChangeRooms, []) |
|
442 else |
|
443 if not $ nick client == teamowner team then |
|
444 (noChangeClients, noChangeRooms, answerNotOwner) |
|
445 else |
|
446 if not $ gameinprogress clRoom then |
|
447 (noChangeClients, modifyRoom clRoom{teams = filter (\t -> teamName /= teamname t) $ teams clRoom}, answerRemoveTeam teamName) |
|
448 else |
|
449 (noChangeClients, |
|
450 modifyRoom clRoom{ |
|
451 teams = filter (\t -> teamName /= teamname t) $ teams clRoom, |
|
452 leftTeams = teamName : leftTeams clRoom, |
|
453 roundMsgs = roundMsgs clRoom |> rmTeamMsg |
|
454 }, |
|
455 answerOthersRoom ["GAMEMSG", rmTeamMsg]) |
|
456 where |
|
457 noSuchTeam = isNothing findTeam |
|
458 team = fromJust findTeam |
|
459 findTeam = find (\t -> teamName == teamname t) $ teams clRoom |
|
460 clRoom = roomByName (room client) rooms |
|
461 rmTeamMsg = toEngineMsg $ 'F' : teamName |
|
462 |
|
463 handleCmd_inRoom client _ rooms ["TOGGLE_READY"] = |
|
464 if isReady client then |
|
465 (modifyClient client{isReady = False}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerNotReady $ nick client) |
|
466 else |
|
467 (modifyClient client{isReady = True}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerIsReady $ nick client) |
|
468 where |
|
469 clRoom = roomByName (room client) rooms |
|
470 newReadyPlayers = (readyPlayers clRoom) + if isReady client then -1 else 1 |
|
471 |
|
472 handleCmd_inRoom client _ rooms ["START_GAME"] = |
|
473 if isMaster client && (playersIn clRoom == readyPlayers clRoom) && (not $ gameinprogress clRoom) then |
|
474 if enoughClans then |
|
475 (noChangeClients, modifyRoom clRoom{gameinprogress = True, roundMsgs = empty, leftTeams = [], teamsAtStart = teams clRoom}, answerRunGame) |
|
476 else |
|
477 (noChangeClients, noChangeRooms, answerTooFewClans) |
|
478 else |
|
479 (noChangeClients, noChangeRooms, []) |
|
480 where |
|
481 clRoom = roomByName (room client) rooms |
|
482 enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams clRoom |
|
483 |
|
484 handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_JOINS"] = |
|
485 if isMaster client then |
|
486 (noChangeClients, modifyRoom clRoom{isRestrictedJoins = newStatus}, []) |
|
487 else |
|
488 (noChangeClients, noChangeRooms, answerNotMaster) |
|
489 where |
|
490 clRoom = roomByName (room client) rooms |
|
491 newStatus = not $ isRestrictedJoins clRoom |
|
492 |
|
493 handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_TEAMS"] = |
|
494 if isMaster client then |
|
495 (noChangeClients, modifyRoom clRoom{isRestrictedTeams = newStatus}, []) |
|
496 else |
|
497 (noChangeClients, noChangeRooms, answerNotMaster) |
|
498 where |
|
499 clRoom = roomByName (room client) rooms |
|
500 newStatus = not $ isRestrictedTeams clRoom |
|
501 |
|
502 handleCmd_inRoom client clients rooms ["ROUNDFINISHED"] = |
|
503 if isMaster client then |
|
504 (modifyRoomClients clRoom (\cl -> cl{isReady = False}), modifyRoom clRoom{gameinprogress = False, readyPlayers = 0, roundMsgs = empty, leftTeams = [], teamsAtStart = []}, answerAllNotReady ++ answerRemovedTeams) |
|
505 else |
|
506 (noChangeClients, noChangeRooms, []) |
|
507 where |
|
508 clRoom = roomByName (room client) rooms |
|
509 sameRoomClients = filter (\ci -> room ci == name clRoom) clients |
|
510 answerAllNotReady = concatMap (\cl -> answerSameRoom ["NOT_READY", nick cl]) sameRoomClients |
|
511 answerRemovedTeams = concatMap (\t -> answerSameRoom ["REMOVE_TEAM", t]) $ leftTeams clRoom |
|
512 |
|
513 handleCmd_inRoom client _ rooms ["GAMEMSG", msg] = |
|
514 (noChangeClients, addMsg, answerOthersRoom ["GAMEMSG", msg]) |
|
515 where |
|
516 addMsg = if roomProto clRoom < 20 then |
|
517 noChangeRooms |
|
518 else |
|
519 modifyRoom clRoom{roundMsgs = roundMsgs clRoom |> msg} |
|
520 clRoom = roomByName (room client) rooms |
|
521 |
|
522 handleCmd_inRoom client clients rooms ["KICK", kickNick] = |
|
523 if isMaster client then |
|
524 if noSuchClient || (kickClient == client) then |
|
525 (noChangeClients, noChangeRooms, []) |
|
526 else |
|
527 (modifyClient kickClient{forceQuit = True}, noChangeRooms, []) |
|
528 else |
|
529 (noChangeClients, noChangeRooms, []) |
|
530 where |
|
531 clRoom = roomByName (room client) rooms |
|
532 noSuchClient = isNothing findClient |
|
533 kickClient = fromJust findClient |
|
534 findClient = find (\t -> ((room t) == (room client)) && ((nick t) == kickNick)) $ clients |
|
535 |
|
536 handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
|