1 {-# LANGUAGE OverloadedStrings #-} |
1 {-# LANGUAGE OverloadedStrings #-} |
2 module Actions where |
2 module Actions where |
3 |
3 |
4 import Control.Concurrent |
4 import Control.Concurrent |
5 import Control.Concurrent.Chan |
|
6 import qualified Data.IntSet as IntSet |
|
7 import qualified Data.Set as Set |
5 import qualified Data.Set as Set |
8 import qualified Data.Sequence as Seq |
6 import qualified Data.Sequence as Seq |
9 import System.Log.Logger |
7 import System.Log.Logger |
10 import Control.Monad |
8 import Control.Monad |
11 import Data.Time |
9 import Data.Time |
12 import Data.Maybe |
10 import Data.Maybe |
13 import Control.Monad.Reader |
11 import Control.Monad.Reader |
14 import Control.Monad.State.Strict |
12 import Control.Monad.State.Strict |
15 import qualified Data.ByteString.Char8 as B |
13 import qualified Data.ByteString.Char8 as B |
16 import Control.DeepSeq |
14 import Control.DeepSeq |
17 import Data.Time |
|
18 import Text.Printf |
|
19 import Data.Unique |
15 import Data.Unique |
|
16 import Control.Arrow |
20 ----------------------------- |
17 ----------------------------- |
21 import CoreTypes |
18 import CoreTypes |
22 import Utils |
19 import Utils |
23 import ClientIO |
20 import ClientIO |
24 import ServerState |
21 import ServerState |
63 rnf a = a `seq` () |
60 rnf a = a `seq` () |
64 |
61 |
65 instance NFData B.ByteString |
62 instance NFData B.ByteString |
66 instance NFData (Chan a) |
63 instance NFData (Chan a) |
67 |
64 |
|
65 |
|
66 othersChans :: StateT ServerState IO [ClientChan] |
68 othersChans = do |
67 othersChans = do |
69 cl <- client's id |
68 cl <- client's id |
70 ri <- clientRoomA |
69 ri <- clientRoomA |
71 liftM (map sendChan . filter (/= cl)) $ roomClientsS ri |
70 liftM (map sendChan . filter (/= cl)) $ roomClientsS ri |
72 |
71 |
73 processAction :: Action -> StateT ServerState IO () |
72 processAction :: Action -> StateT ServerState IO () |
74 |
73 |
75 |
74 |
76 processAction (AnswerClients chans msg) = do |
75 processAction (AnswerClients chans msg) = |
77 io $ mapM_ (flip writeChan (msg `deepseq` msg)) (chans `deepseq` chans) |
76 io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans) |
78 |
77 |
79 |
78 |
80 processAction SendServerMessage = do |
79 processAction SendServerMessage = do |
81 chan <- client's sendChan |
80 chan <- client's sendChan |
82 protonum <- client's clientProto |
81 protonum <- client's clientProto |
113 chan <- client's sendChan |
112 chan <- client's sendChan |
114 processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n] |
113 processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n] |
115 |
114 |
116 processAction (ByeClient msg) = do |
115 processAction (ByeClient msg) = do |
117 (Just ci) <- gets clientIndex |
116 (Just ci) <- gets clientIndex |
118 rnc <- gets roomsClients |
|
119 ri <- clientRoomA |
117 ri <- clientRoomA |
120 |
118 |
121 chan <- client's sendChan |
119 chan <- client's sendChan |
122 clNick <- client's nick |
120 clNick <- client's nick |
123 |
121 |
124 when (ri /= lobbyId) $ do |
122 when (ri /= lobbyId) $ do |
125 processAction $ MoveToLobby ("quit: " `B.append` msg) |
123 processAction $ MoveToLobby ("quit: " `B.append` msg) |
126 return () |
124 return () |
127 |
125 |
128 clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS |
126 clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS |
129 io $ do |
127 io $ |
130 infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg)) |
128 infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg) |
131 |
129 |
132 processAction $ AnswerClients [chan] ["BYE", msg] |
130 processAction $ AnswerClients [chan] ["BYE", msg] |
133 processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg] |
131 processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg] |
134 |
132 |
135 s <- get |
133 s <- get |
169 (Just ci) <- gets clientIndex |
167 (Just ci) <- gets clientIndex |
170 rnc <- gets roomsClients |
168 rnc <- gets roomsClients |
171 |
169 |
172 io $ do |
170 io $ do |
173 modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci |
171 modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci |
174 modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri |
172 modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri |
175 moveClientToRoom rnc ri ci |
173 moveClientToRoom rnc ri ci |
176 |
174 |
177 chans <- liftM (map sendChan) $ roomClientsS ri |
175 chans <- liftM (map sendChan) $ roomClientsS ri |
178 clNick <- client's nick |
176 clNick <- client's nick |
179 |
177 |
182 |
180 |
183 processAction (MoveToLobby msg) = do |
181 processAction (MoveToLobby msg) = do |
184 (Just ci) <- gets clientIndex |
182 (Just ci) <- gets clientIndex |
185 ri <- clientRoomA |
183 ri <- clientRoomA |
186 rnc <- gets roomsClients |
184 rnc <- gets roomsClients |
187 (gameProgress, playersNum) <- io $ room'sM rnc (\r -> (gameinprogress r, playersIn r)) ri |
185 (gameProgress, playersNum) <- io $ room'sM rnc (gameinprogress &&& playersIn) ri |
188 ready <- client's isReady |
186 ready <- client's isReady |
189 master <- client's isMaster |
187 master <- client's isMaster |
190 -- client <- client's id |
188 -- client <- client's id |
191 clNick <- client's nick |
189 clNick <- client's nick |
192 chans <- othersChans |
190 chans <- othersChans |
199 else |
197 else |
200 mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci] |
198 mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci] |
201 |
199 |
202 io $ do |
200 io $ do |
203 modifyRoom rnc (\r -> r{ |
201 modifyRoom rnc (\r -> r{ |
204 playersIn = (playersIn r) - 1, |
202 playersIn = playersIn r - 1, |
205 readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r |
203 readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r |
206 }) ri |
204 }) ri |
207 moveClientToLobby rnc ci |
205 moveClientToLobby rnc ci |
208 |
206 |
209 processAction ChangeMaster = do |
207 processAction ChangeMaster = do |
221 processAction (AddRoom roomName roomPassword) = do |
219 processAction (AddRoom roomName roomPassword) = do |
222 Just clId <- gets clientIndex |
220 Just clId <- gets clientIndex |
223 rnc <- gets roomsClients |
221 rnc <- gets roomsClients |
224 proto <- io $ client'sM rnc clientProto clId |
222 proto <- io $ client'sM rnc clientProto clId |
225 |
223 |
226 let room = newRoom{ |
224 let rm = newRoom{ |
227 masterID = clId, |
225 masterID = clId, |
228 name = roomName, |
226 name = roomName, |
229 password = roomPassword, |
227 password = roomPassword, |
230 roomProto = proto |
228 roomProto = proto |
231 } |
229 } |
232 |
230 |
233 rId <- io $ addRoom rnc room |
231 rId <- io $ addRoom rnc rm |
234 |
232 |
235 processAction $ MoveToRoom rId |
233 processAction $ MoveToRoom rId |
236 |
234 |
237 chans <- liftM (map sendChan) $! roomClientsS lobbyId |
235 chans <- liftM (map sendChan) $! roomClientsS lobbyId |
238 |
236 |
268 processAction $ ModifyRoom (\r -> r{readyPlayers = 0}) |
266 processAction $ ModifyRoom (\r -> r{readyPlayers = 0}) |
269 |
267 |
270 |
268 |
271 processAction (RemoveTeam teamName) = do |
269 processAction (RemoveTeam teamName) = do |
272 rnc <- gets roomsClients |
270 rnc <- gets roomsClients |
273 cl <- client's id |
|
274 ri <- clientRoomA |
271 ri <- clientRoomA |
275 inGame <- io $ room'sM rnc gameinprogress ri |
272 inGame <- io $ room'sM rnc gameinprogress ri |
276 chans <- othersChans |
273 chans <- othersChans |
277 if inGame then |
274 if inGame then |
278 mapM_ processAction [ |
275 mapM_ processAction [ |
287 leftTeams = teamName : leftTeams r, |
284 leftTeams = teamName : leftTeams r, |
288 roundMsgs = roundMsgs r Seq.|> rmTeamMsg |
285 roundMsgs = roundMsgs r Seq.|> rmTeamMsg |
289 }) |
286 }) |
290 ] |
287 ] |
291 where |
288 where |
292 rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName |
289 rmTeamMsg = toEngineMsg $ B.singleton 'F' `B.append` teamName |
293 |
290 |
294 |
291 |
295 processAction (RemoveClientTeams clId) = do |
292 processAction (RemoveClientTeams clId) = do |
296 rnc <- gets roomsClients |
293 rnc <- gets roomsClients |
297 |
294 |
324 processAction (ProcessAccountInfo info) = |
321 processAction (ProcessAccountInfo info) = |
325 case info of |
322 case info of |
326 HasAccount passwd isAdmin -> do |
323 HasAccount passwd isAdmin -> do |
327 chan <- client's sendChan |
324 chan <- client's sendChan |
328 mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})] |
325 mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})] |
329 Guest -> do |
326 Guest -> |
330 processAction JoinLobby |
327 processAction JoinLobby |
331 Admin -> do |
328 Admin -> do |
332 mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] |
329 mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] |
333 chan <- client's sendChan |
330 chan <- client's sendChan |
334 processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] |
331 processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] |
335 |
332 |
336 |
333 |
337 processAction JoinLobby = do |
334 processAction JoinLobby = do |
338 chan <- client's sendChan |
335 chan <- client's sendChan |
339 clientNick <- client's nick |
336 clientNick <- client's nick |
340 (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) $! allClientsS |
337 (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (nick &&& sendChan) . Prelude.filter logonPassed) $! allClientsS |
341 mapM_ processAction $ |
338 mapM_ processAction $ |
342 (AnswerClients clientsChans ["LOBBY:JOINED", clientNick]) |
339 AnswerClients clientsChans ["LOBBY:JOINED", clientNick] |
343 : [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)] |
340 : AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks) |
344 ++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage] |
341 : [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage] |
345 |
342 |
346 {- |
343 {- |
347 processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) = |
344 processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) = |
348 processAction ( |
345 processAction ( |
349 clID, |
346 clID, |
365 |
362 |
366 |
363 |
367 processAction (BanClient seconds reason banId) = do |
364 processAction (BanClient seconds reason banId) = do |
368 modify (\s -> s{clientIndex = Just banId}) |
365 modify (\s -> s{clientIndex = Just banId}) |
369 clHost <- client's host |
366 clHost <- client's host |
370 currentTime <- io $ getCurrentTime |
367 currentTime <- io getCurrentTime |
371 let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` msg` B.append` ")" |
368 let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` reason ` B.append` ")" |
372 mapM_ processAction [ |
369 mapM_ processAction [ |
373 ModifyServerInfo (\s -> s{lastLogins = (clHost, (addUTCTime seconds $ currentTime, msg)) : lastLogins s}) |
370 ModifyServerInfo (\s -> s{lastLogins = (clHost, (addUTCTime seconds currentTime, msg)) : lastLogins s}) |
374 , KickClient banId |
371 , KickClient banId |
375 ] |
372 ] |
376 |
373 |
377 |
374 |
378 processAction (KickRoomClient kickId) = do |
375 processAction (KickRoomClient kickId) = do |
385 rnc <- gets roomsClients |
382 rnc <- gets roomsClients |
386 si <- gets serverInfo |
383 si <- gets serverInfo |
387 newClId <- io $ do |
384 newClId <- io $ do |
388 ci <- addClient rnc cl |
385 ci <- addClient rnc cl |
389 t <- forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) ci |
386 t <- forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) ci |
390 forkIO $ clientSendLoop (clientSocket cl) t (coreChan si) (sendChan cl) ci |
387 _ <- forkIO $ clientSendLoop (clientSocket cl) t (coreChan si) (sendChan cl) ci |
391 |
388 |
392 infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl)) |
389 infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl)) |
393 |
390 |
394 return ci |
391 return ci |
395 |
392 |
396 modify (\s -> s{clientIndex = Just newClId}) |
393 modify (\s -> s{clientIndex = Just newClId}) |
397 processAction $ AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
394 processAction $ AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
398 |
395 |
399 si <- gets serverInfo |
396 let newLogins = takeWhile (\(_ , (time, _)) -> connectTime cl `diffUTCTime` time <= 0) $ lastLogins si |
400 let newLogins = takeWhile (\(_ , (time, _)) -> (connectTime cl) `diffUTCTime` time <= 0) $ lastLogins si |
|
401 let info = host cl `Prelude.lookup` newLogins |
397 let info = host cl `Prelude.lookup` newLogins |
402 if isJust info then |
398 if isJust info then |
403 mapM_ processAction [ModifyServerInfo (\s -> s{lastLogins = newLogins}), ByeClient (snd . fromJust $ info)] |
399 mapM_ processAction [ModifyServerInfo (\s -> s{lastLogins = newLogins}), ByeClient (snd . fromJust $ info)] |
404 else |
400 else |
405 processAction $ ModifyServerInfo (\s -> s{lastLogins = (host cl, (addUTCTime 10 $ connectTime cl, "Reconnected too fast")) : newLogins}) |
401 processAction $ ModifyServerInfo (\s -> s{lastLogins = (host cl, (addUTCTime 10 $ connectTime cl, "Reconnected too fast")) : newLogins}) |
421 |
417 |
422 |
418 |
423 processAction StatsAction = do |
419 processAction StatsAction = do |
424 rnc <- gets roomsClients |
420 rnc <- gets roomsClients |
425 si <- gets serverInfo |
421 si <- gets serverInfo |
426 (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc stats |
422 (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st |
427 io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1) |
423 io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1) |
428 where |
424 where |
429 stats irnc = (length $ allRooms irnc, length $ allClients irnc) |
425 st irnc = (length $ allRooms irnc, length $ allClients irnc) |
430 |
426 |
431 processAction (RestartServer useForce) = do |
427 processAction (RestartServer _) = |
432 return () |
428 return () |