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