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