12 ----------------------------- |
12 ----------------------------- |
13 import CoreTypes |
13 import CoreTypes |
14 import Utils |
14 import Utils |
15 |
15 |
16 data Action = |
16 data Action = |
17 AnswerThisClient [String] |
17 AnswerThisClient [String] |
18 | AnswerAll [String] |
18 | AnswerAll [String] |
19 | AnswerAllOthers [String] |
19 | AnswerAllOthers [String] |
20 | AnswerThisRoom [String] |
20 | AnswerThisRoom [String] |
21 | AnswerOthersInRoom [String] |
21 | AnswerOthersInRoom [String] |
22 | AnswerSameClan [String] |
22 | AnswerSameClan [String] |
23 | AnswerLobby [String] |
23 | AnswerLobby [String] |
24 | SendServerMessage |
24 | SendServerMessage |
25 | RoomAddThisClient Int -- roomID |
25 | RoomAddThisClient Int -- roomID |
26 | RoomRemoveThisClient String |
26 | RoomRemoveThisClient String |
27 | RemoveTeam String |
27 | RemoveTeam String |
28 | RemoveRoom |
28 | RemoveRoom |
29 | UnreadyRoomClients |
29 | UnreadyRoomClients |
30 | MoveToLobby |
30 | MoveToLobby |
31 | ProtocolError String |
31 | ProtocolError String |
32 | Warning String |
32 | Warning String |
33 | ByeClient String |
33 | ByeClient String |
34 | KickClient Int -- clID |
34 | KickClient Int -- clID |
35 | KickRoomClient Int -- clID |
35 | KickRoomClient Int -- clID |
36 | BanClient String -- nick |
36 | BanClient String -- nick |
37 | RemoveClientTeams Int -- clID |
37 | RemoveClientTeams Int -- clID |
38 | ModifyClient (ClientInfo -> ClientInfo) |
38 | ModifyClient (ClientInfo -> ClientInfo) |
39 | ModifyClient2 Int (ClientInfo -> ClientInfo) |
39 | ModifyClient2 Int (ClientInfo -> ClientInfo) |
40 | ModifyRoom (RoomInfo -> RoomInfo) |
40 | ModifyRoom (RoomInfo -> RoomInfo) |
41 | ModifyServerInfo (ServerInfo -> ServerInfo) |
41 | ModifyServerInfo (ServerInfo -> ServerInfo) |
42 | AddRoom String String |
42 | AddRoom String String |
43 | CheckRegistered |
43 | CheckRegistered |
44 | ClearAccountsCache |
44 | ClearAccountsCache |
45 | ProcessAccountInfo AccountInfo |
45 | ProcessAccountInfo AccountInfo |
46 | Dump |
46 | Dump |
47 | AddClient ClientInfo |
47 | AddClient ClientInfo |
48 | PingAll |
48 | PingAll |
49 | StatsAction |
49 | StatsAction |
50 |
50 |
51 type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action] |
51 type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action] |
52 |
52 |
53 replaceID a (b, c, d, e) = (a, c, d, e) |
53 replaceID a (b, c, d, e) = (a, c, d, e) |
54 |
54 |
55 processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms) |
55 processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms) |
56 |
56 |
57 |
57 |
58 processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do |
58 processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do |
59 writeChan (sendChan $ clients ! clID) msg |
59 writeChan (sendChan $ clients ! clID) msg |
60 return (clID, serverInfo, clients, rooms) |
60 return (clID, serverInfo, clients, rooms) |
61 |
61 |
62 |
62 |
63 processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do |
63 processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do |
64 mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients) |
64 mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients) |
65 return (clID, serverInfo, clients, rooms) |
65 return (clID, serverInfo, clients, rooms) |
66 |
66 |
67 |
67 |
68 processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do |
68 processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do |
69 mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ |
69 mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ |
70 Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients) |
70 Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients) |
71 return (clID, serverInfo, clients, rooms) |
71 return (clID, serverInfo, clients, rooms) |
72 |
72 |
73 |
73 |
74 processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do |
74 processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do |
75 mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients |
75 mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients |
76 return (clID, serverInfo, clients, rooms) |
76 return (clID, serverInfo, clients, rooms) |
77 where |
77 where |
78 roomClients = IntSet.elems $ playersIDs room |
78 roomClients = IntSet.elems $ playersIDs room |
79 room = rooms ! rID |
79 room = rooms ! rID |
80 rID = roomID client |
80 rID = roomID client |
81 client = clients ! clID |
81 client = clients ! clID |
82 |
82 |
83 |
83 |
84 processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do |
84 processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do |
85 mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ Prelude.filter (/= clID) roomClients |
85 mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ Prelude.filter (/= clID) roomClients |
86 return (clID, serverInfo, clients, rooms) |
86 return (clID, serverInfo, clients, rooms) |
87 where |
87 where |
88 roomClients = IntSet.elems $ playersIDs room |
88 roomClients = IntSet.elems $ playersIDs room |
89 room = rooms ! rID |
89 room = rooms ! rID |
90 rID = roomID client |
90 rID = roomID client |
91 client = clients ! clID |
91 client = clients ! clID |
92 |
92 |
93 |
93 |
94 processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do |
94 processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do |
95 mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients |
95 mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients |
96 return (clID, serverInfo, clients, rooms) |
96 return (clID, serverInfo, clients, rooms) |
97 where |
97 where |
98 roomClients = IntSet.elems $ playersIDs room |
98 roomClients = IntSet.elems $ playersIDs room |
99 room = rooms ! 0 |
99 room = rooms ! 0 |
100 |
100 |
101 |
101 |
102 processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do |
102 processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do |
103 mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec |
103 mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec |
104 return (clID, serverInfo, clients, rooms) |
104 return (clID, serverInfo, clients, rooms) |
105 where |
105 where |
106 otherRoomClients = Prelude.map ((!) clients) $ IntSet.elems $ clID `IntSet.delete` (playersIDs room) |
106 otherRoomClients = Prelude.map ((!) clients) $ IntSet.elems $ clID `IntSet.delete` (playersIDs room) |
107 sameClanOrSpec = if teamsInGame client > 0 then sameClanClients else spectators |
107 sameClanOrSpec = if teamsInGame client > 0 then sameClanClients else spectators |
108 spectators = Prelude.filter (\cl -> teamsInGame cl == 0) otherRoomClients |
108 spectators = Prelude.filter (\cl -> teamsInGame cl == 0) otherRoomClients |
109 sameClanClients = Prelude.filter (\cl -> teamsInGame cl > 0 && clientClan cl == thisClan) otherRoomClients |
109 sameClanClients = Prelude.filter (\cl -> teamsInGame cl > 0 && clientClan cl == thisClan) otherRoomClients |
110 thisClan = clientClan client |
110 thisClan = clientClan client |
111 room = rooms ! rID |
111 room = rooms ! rID |
112 rID = roomID client |
112 rID = roomID client |
113 client = clients ! clID |
113 client = clients ! clID |
114 |
114 |
115 |
115 |
116 processAction (clID, serverInfo, clients, rooms) SendServerMessage = do |
116 processAction (clID, serverInfo, clients, rooms) SendServerMessage = do |
117 writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo] |
117 writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo] |
118 return (clID, serverInfo, clients, rooms) |
118 return (clID, serverInfo, clients, rooms) |
119 where |
119 where |
120 client = clients ! clID |
120 client = clients ! clID |
121 message = if clientProto client < 29 then |
121 message = if clientProto client < 29 then |
122 serverMessageForOldVersions |
122 serverMessageForOldVersions |
123 else |
123 else |
124 serverMessage |
124 serverMessage |
125 |
125 |
126 |
126 |
127 processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do |
127 processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do |
128 writeChan (sendChan $ clients ! clID) ["ERROR", msg] |
128 writeChan (sendChan $ clients ! clID) ["ERROR", msg] |
129 return (clID, serverInfo, clients, rooms) |
129 return (clID, serverInfo, clients, rooms) |
130 |
130 |
131 |
131 |
132 processAction (clID, serverInfo, clients, rooms) (Warning msg) = do |
132 processAction (clID, serverInfo, clients, rooms) (Warning msg) = do |
133 writeChan (sendChan $ clients ! clID) ["WARNING", msg] |
133 writeChan (sendChan $ clients ! clID) ["WARNING", msg] |
134 return (clID, serverInfo, clients, rooms) |
134 return (clID, serverInfo, clients, rooms) |
135 |
135 |
136 |
136 |
137 processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do |
137 processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do |
138 infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg) |
138 infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg) |
139 (_, _, newClients, newRooms) <- |
139 (_, _, newClients, newRooms) <- |
140 if roomID client /= 0 then |
140 if roomID client /= 0 then |
141 processAction (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit" |
141 processAction (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit" |
142 else |
142 else |
143 return (clID, serverInfo, clients, rooms) |
143 return (clID, serverInfo, clients, rooms) |
144 |
144 |
145 mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom |
145 mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom |
146 writeChan (sendChan $ clients ! clID) ["BYE", msg] |
146 writeChan (sendChan $ clients ! clID) ["BYE", msg] |
147 return ( |
147 return ( |
148 0, |
148 0, |
149 serverInfo, |
149 serverInfo, |
150 delete clID newClients, |
150 delete clID newClients, |
151 adjust (\r -> r{ |
151 adjust (\r -> r{ |
152 playersIDs = IntSet.delete clID (playersIDs r), |
152 playersIDs = IntSet.delete clID (playersIDs r), |
153 playersIn = (playersIn r) - 1, |
153 playersIn = (playersIn r) - 1, |
154 readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r |
154 readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r |
155 }) (roomID $ newClients ! clID) newRooms |
155 }) (roomID $ newClients ! clID) newRooms |
156 ) |
156 ) |
157 where |
157 where |
158 client = clients ! clID |
158 client = clients ! clID |
159 clientNick = nick client |
159 clientNick = nick client |
160 answerInformRoom = |
160 answerInformRoom = |
161 if roomID client /= 0 then |
161 if roomID client /= 0 then |
162 if not $ Prelude.null msg then |
162 if not $ Prelude.null msg then |
163 [AnswerThisRoom ["LEFT", clientNick, msg]] |
163 [AnswerThisRoom ["LEFT", clientNick, msg]] |
164 else |
164 else |
165 [AnswerThisRoom ["LEFT", clientNick]] |
165 [AnswerThisRoom ["LEFT", clientNick]] |
166 else |
166 else |
167 [] |
167 [] |
168 answerOthersQuit = |
168 answerOthersQuit = |
169 if logonPassed client then |
169 if logonPassed client then |
170 if not $ Prelude.null msg then |
170 if not $ Prelude.null msg then |
171 [AnswerAll ["LOBBY:LEFT", clientNick, msg]] |
171 [AnswerAll ["LOBBY:LEFT", clientNick, msg]] |
172 else |
172 else |
173 [AnswerAll ["LOBBY:LEFT", clientNick]] |
173 [AnswerAll ["LOBBY:LEFT", clientNick]] |
174 else |
174 else |
175 [] |
175 [] |
176 |
176 |
177 |
177 |
178 processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = |
178 processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = |
179 return (clID, serverInfo, adjust func clID clients, rooms) |
179 return (clID, serverInfo, adjust func clID clients, rooms) |
180 |
180 |
181 |
181 |
182 processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) = |
182 processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) = |
183 return (clID, serverInfo, adjust func cl2ID clients, rooms) |
183 return (clID, serverInfo, adjust func cl2ID clients, rooms) |
184 |
184 |
185 |
185 |
186 processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = |
186 processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = |
187 return (clID, serverInfo, clients, adjust func rID rooms) |
187 return (clID, serverInfo, clients, adjust func rID rooms) |
188 where |
188 where |
189 rID = roomID $ clients ! clID |
189 rID = roomID $ clients ! clID |
190 |
190 |
191 |
191 |
192 processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) = |
192 processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) = |
193 return (clID, func serverInfo, clients, rooms) |
193 return (clID, func serverInfo, clients, rooms) |
194 |
194 |
195 |
195 |
196 processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) = |
196 processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) = |
197 processAction ( |
197 processAction ( |
198 clID, |
198 clID, |
199 serverInfo, |
199 serverInfo, |
200 adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients, |
200 adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients, |
201 adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $ |
201 adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $ |
202 adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms |
202 adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms |
203 ) joinMsg |
203 ) joinMsg |
204 where |
204 where |
205 client = clients ! clID |
205 client = clients ! clID |
206 joinMsg = if rID == 0 then |
206 joinMsg = if rID == 0 then |
207 AnswerAllOthers ["LOBBY:JOINED", nick client] |
207 AnswerAllOthers ["LOBBY:JOINED", nick client] |
208 else |
208 else |
209 AnswerThisRoom ["JOINED", nick client] |
209 AnswerThisRoom ["JOINED", nick client] |
210 |
210 |
211 |
211 |
212 processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do |
212 processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do |
213 (_, _, newClients, newRooms) <- |
213 (_, _, newClients, newRooms) <- |
214 if roomID client /= 0 then |
214 if roomID client /= 0 then |
215 if isMaster client then |
215 if isMaster client then |
216 if (gameinprogress room) && (playersIn room > 1) then |
216 if (gameinprogress room) && (playersIn room > 1) then |
217 (changeMaster >>= (\state -> foldM processAction state |
217 (changeMaster >>= (\state -> foldM processAction state |
218 [AnswerOthersInRoom ["LEFT", nick client, msg], |
218 [AnswerOthersInRoom ["LEFT", nick client, msg], |
219 AnswerOthersInRoom ["WARNING", "Admin left the room"], |
219 AnswerOthersInRoom ["WARNING", "Admin left the room"], |
220 RemoveClientTeams clID])) |
220 RemoveClientTeams clID])) |
221 else -- not in game |
221 else -- not in game |
222 processAction (clID, serverInfo, clients, rooms) RemoveRoom |
222 processAction (clID, serverInfo, clients, rooms) RemoveRoom |
223 else -- not master |
223 else -- not master |
224 foldM |
224 foldM |
225 processAction |
225 processAction |
226 (clID, serverInfo, clients, rooms) |
226 (clID, serverInfo, clients, rooms) |
227 [AnswerOthersInRoom ["LEFT", nick client, msg], |
227 [AnswerOthersInRoom ["LEFT", nick client, msg], |
228 RemoveClientTeams clID] |
228 RemoveClientTeams clID] |
229 else -- in lobby |
229 else -- in lobby |
230 return (clID, serverInfo, clients, rooms) |
230 return (clID, serverInfo, clients, rooms) |
231 |
231 |
232 return ( |
232 return ( |
233 clID, |
233 clID, |
234 serverInfo, |
234 serverInfo, |
235 adjust resetClientFlags clID newClients, |
235 adjust resetClientFlags clID newClients, |
236 adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms |
236 adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms |
237 ) |
237 ) |
238 where |
238 where |
239 rID = roomID client |
239 rID = roomID client |
240 client = clients ! clID |
240 client = clients ! clID |
241 room = rooms ! rID |
241 room = rooms ! rID |
242 resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} |
242 resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} |
243 removeClientFromRoom r = r{ |
243 removeClientFromRoom r = r{ |
244 playersIDs = otherPlayersSet, |
244 playersIDs = otherPlayersSet, |
245 playersIn = (playersIn r) - 1, |
245 playersIn = (playersIn r) - 1, |
246 readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r |
246 readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r |
247 } |
247 } |
248 insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)} |
248 insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)} |
249 changeMaster = do |
249 changeMaster = do |
250 processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] |
250 processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] |
251 return ( |
251 return ( |
252 clID, |
252 clID, |
253 serverInfo, |
253 serverInfo, |
254 adjust (\cl -> cl{isMaster = True}) newMasterId clients, |
254 adjust (\cl -> cl{isMaster = True}) newMasterId clients, |
255 adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms |
255 adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms |
256 ) |
256 ) |
257 newRoomName = nick newMasterClient |
257 newRoomName = nick newMasterClient |
258 otherPlayersSet = IntSet.delete clID (playersIDs room) |
258 otherPlayersSet = IntSet.delete clID (playersIDs room) |
259 newMasterId = IntSet.findMin otherPlayersSet |
259 newMasterId = IntSet.findMin otherPlayersSet |
260 newMasterClient = clients ! newMasterId |
260 newMasterClient = clients ! newMasterId |
261 |
261 |
262 |
262 |
263 processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do |
263 processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do |
264 let newServerInfo = serverInfo {nextRoomID = newID} |
264 let newServerInfo = serverInfo {nextRoomID = newID} |
265 let room = newRoom{ |
265 let room = newRoom{ |
266 roomUID = newID, |
266 roomUID = newID, |
267 masterID = clID, |
267 masterID = clID, |
268 name = roomName, |
268 name = roomName, |
269 password = roomPassword, |
269 password = roomPassword, |
270 roomProto = (clientProto client) |
270 roomProto = (clientProto client) |
271 } |
271 } |
272 |
272 |
273 processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName] |
273 processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName] |
274 |
274 |
275 processAction ( |
275 processAction ( |
276 clID, |
276 clID, |
277 newServerInfo, |
277 newServerInfo, |
278 adjust (\cl -> cl{isMaster = True}) clID clients, |
278 adjust (\cl -> cl{isMaster = True}) clID clients, |
279 insert newID room rooms |
279 insert newID room rooms |
280 ) $ RoomAddThisClient newID |
280 ) $ RoomAddThisClient newID |
281 where |
281 where |
282 newID = (nextRoomID serverInfo) - 1 |
282 newID = (nextRoomID serverInfo) - 1 |
283 client = clients ! clID |
283 client = clients ! clID |
284 |
284 |
285 |
285 |
286 processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do |
286 processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do |
287 processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room] |
287 processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room] |
288 processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room] |
288 processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room] |
289 return (clID, |
289 return (clID, |
290 serverInfo, |
290 serverInfo, |
291 Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients, |
291 Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients, |
292 delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms |
292 delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms |
293 ) |
293 ) |
294 where |
294 where |
295 room = rooms ! rID |
295 room = rooms ! rID |
296 rID = roomID client |
296 rID = roomID client |
297 client = clients ! clID |
297 client = clients ! clID |
298 |
298 |
299 |
299 |
300 processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do |
300 processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do |
301 processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers) |
301 processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers) |
302 return (clID, |
302 return (clID, |
303 serverInfo, |
303 serverInfo, |
304 Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients, |
304 Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients, |
305 adjust (\r -> r{readyPlayers = 0}) rID rooms) |
305 adjust (\r -> r{readyPlayers = 0}) rID rooms) |
306 where |
306 where |
307 room = rooms ! rID |
307 room = rooms ! rID |
308 rID = roomID client |
308 rID = roomID client |
309 client = clients ! clID |
309 client = clients ! clID |
310 roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs |
310 roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs |
311 roomPlayersIDs = IntSet.elems $ playersIDs room |
311 roomPlayersIDs = IntSet.elems $ playersIDs room |
312 |
312 |
313 |
313 |
314 processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do |
314 processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do |
315 newRooms <- if not $ gameinprogress room then |
315 newRooms <- if not $ gameinprogress room then |
316 do |
316 do |
317 processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName] |
317 processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName] |
318 return $ |
318 return $ |
319 adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms |
319 adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms |
320 else |
320 else |
321 do |
321 do |
322 processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg] |
322 processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg] |
323 return $ |
323 return $ |
324 adjust (\r -> r{ |
324 adjust (\r -> r{ |
325 teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, |
325 teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, |
326 leftTeams = teamName : leftTeams r, |
326 leftTeams = teamName : leftTeams r, |
327 roundMsgs = roundMsgs r Seq.|> rmTeamMsg |
327 roundMsgs = roundMsgs r Seq.|> rmTeamMsg |
328 }) rID rooms |
328 }) rID rooms |
329 return (clID, serverInfo, clients, newRooms) |
329 return (clID, serverInfo, clients, newRooms) |
330 where |
330 where |
331 room = rooms ! rID |
331 room = rooms ! rID |
332 rID = roomID client |
332 rID = roomID client |
333 client = clients ! clID |
333 client = clients ! clID |
334 rmTeamMsg = toEngineMsg $ 'F' : teamName |
334 rmTeamMsg = toEngineMsg $ 'F' : teamName |
335 |
335 |
336 |
336 |
337 processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do |
337 processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do |
338 writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client) |
338 writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client) |
339 return (clID, serverInfo, clients, rooms) |
339 return (clID, serverInfo, clients, rooms) |
340 where |
340 where |
341 client = clients ! clID |
341 client = clients ! clID |
342 |
342 |
343 |
343 |
344 processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do |
344 processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do |
345 writeChan (dbQueries serverInfo) ClearCache |
345 writeChan (dbQueries serverInfo) ClearCache |
346 return (clID, serverInfo, clients, rooms) |
346 return (clID, serverInfo, clients, rooms) |
347 where |
347 where |
348 client = clients ! clID |
348 client = clients ! clID |
349 |
349 |
350 |
350 |
351 processAction (clID, serverInfo, clients, rooms) (Dump) = do |
351 processAction (clID, serverInfo, clients, rooms) (Dump) = do |
352 writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] |
352 writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] |
353 return (clID, serverInfo, clients, rooms) |
353 return (clID, serverInfo, clients, rooms) |
354 |
354 |
355 |
355 |
356 processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) = |
356 processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) = |
357 case info of |
357 case info of |
358 HasAccount passwd isAdmin -> do |
358 HasAccount passwd isAdmin -> do |
359 infoM "Clients" $ show clID ++ " has account" |
359 infoM "Clients" $ show clID ++ " has account" |
360 writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"] |
360 writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"] |
361 return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms) |
361 return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms) |
362 Guest -> do |
362 Guest -> do |
363 infoM "Clients" $ show clID ++ " is guest" |
363 infoM "Clients" $ show clID ++ " is guest" |
364 processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby |
364 processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby |
365 Admin -> do |
365 Admin -> do |
366 infoM "Clients" $ show clID ++ " is admin" |
366 infoM "Clients" $ show clID ++ " is admin" |
367 foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]] |
367 foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]] |
368 |
368 |
369 |
369 |
370 processAction (clID, serverInfo, clients, rooms) (MoveToLobby) = |
370 processAction (clID, serverInfo, clients, rooms) (MoveToLobby) = |
371 foldM processAction (clID, serverInfo, clients, rooms) $ |
371 foldM processAction (clID, serverInfo, clients, rooms) $ |
372 (RoomAddThisClient 0) |
372 (RoomAddThisClient 0) |
373 : answerLobbyNicks |
373 : answerLobbyNicks |
374 ++ [SendServerMessage] |
374 ++ [SendServerMessage] |
375 |
375 |
376 -- ++ (answerServerMessage client clients) |
376 -- ++ (answerServerMessage client clients) |
377 where |
377 where |
378 lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients |
378 lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients |
379 answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks] |
379 answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks] |
380 |
380 |
381 |
381 |
382 processAction (clID, serverInfo, clients, rooms) (KickClient kickID) = |
382 processAction (clID, serverInfo, clients, rooms) (KickClient kickID) = |
383 liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked") |
383 liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked") |
384 |
384 |
385 |
385 |
386 processAction (clID, serverInfo, clients, rooms) (BanClient banNick) = |
386 processAction (clID, serverInfo, clients, rooms) (BanClient banNick) = |
387 return (clID, serverInfo, clients, rooms) |
387 return (clID, serverInfo, clients, rooms) |
388 |
388 |
389 |
389 |
390 processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do |
390 processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do |
391 writeChan (sendChan $ clients ! kickID) ["KICKED"] |
391 writeChan (sendChan $ clients ! kickID) ["KICKED"] |
392 liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked") |
392 liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked") |
393 |
393 |
394 |
394 |
395 processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) = |
395 processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) = |
396 liftM2 replaceID (return clID) $ |
396 liftM2 replaceID (return clID) $ |
397 foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions |
397 foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions |
398 where |
398 where |
399 client = clients ! teamsClID |
399 client = clients ! teamsClID |
400 room = rooms ! (roomID client) |
400 room = rooms ! (roomID client) |
401 teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room |
401 teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room |
402 removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove |
402 removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove |
403 |
403 |
404 |
404 |
405 processAction (clID, serverInfo, clients, rooms) (AddClient client) = do |
405 processAction (clID, serverInfo, clients, rooms) (AddClient client) = do |
406 let updatedClients = insert (clientUID client) client clients |
406 let updatedClients = insert (clientUID client) client clients |
407 infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client)) |
407 infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client)) |
408 writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
408 writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
409 |
409 |
410 let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo |
410 let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo |
411 |
411 |
412 if isJust $ host client `Prelude.lookup` newLogins then |
412 if isJust $ host client `Prelude.lookup` newLogins then |
413 processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast" |
413 processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast" |
414 else |
414 else |
415 return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms) |
415 return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms) |
416 |
416 |
417 |
417 |
418 processAction (clID, serverInfo, clients, rooms) PingAll = do |
418 processAction (clID, serverInfo, clients, rooms) PingAll = do |
419 (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients |
419 (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients |
420 processAction (clID, |
420 processAction (clID, |
421 serverInfo, |
421 serverInfo, |
422 Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients, |
422 Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients, |
423 newRooms) $ AnswerAll ["PING"] |
423 newRooms) $ AnswerAll ["PING"] |
424 where |
424 where |
425 kickTimeouted (clID, serverInfo, clients, rooms) client = |
425 kickTimeouted (clID, serverInfo, clients, rooms) client = |
426 if pingsQueue client > 0 then |
426 if pingsQueue client > 0 then |
427 processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout" |
427 processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout" |
428 else |
428 else |
429 return (clID, serverInfo, clients, rooms) |
429 return (clID, serverInfo, clients, rooms) |
430 |
430 |
431 |
431 |
432 processAction (clID, serverInfo, clients, rooms) (StatsAction) = do |
432 processAction (clID, serverInfo, clients, rooms) (StatsAction) = do |
433 writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1) |
433 writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1) |
434 return (clID, serverInfo, clients, rooms) |
434 return (clID, serverInfo, clients, rooms) |