22 |
22 |
23 import Control.Concurrent |
23 import Control.Concurrent |
24 import qualified Data.Set as Set |
24 import qualified Data.Set as Set |
25 import qualified Data.Map as Map |
25 import qualified Data.Map as Map |
26 import qualified Data.List as L |
26 import qualified Data.List as L |
|
27 import Data.Word |
27 import qualified Control.Exception as Exception |
28 import qualified Control.Exception as Exception |
28 import System.Log.Logger |
29 import System.Log.Logger |
29 import Control.Monad |
30 import Control.Monad |
30 import Data.Time |
31 import Data.Time |
31 import Data.Maybe |
32 import Data.Maybe |
63 othersChans = do |
64 othersChans = do |
64 cl <- client's id |
65 cl <- client's id |
65 ri <- clientRoomA |
66 ri <- clientRoomA |
66 liftM (map sendChan . filter (/= cl)) $ roomClientsS ri |
67 liftM (map sendChan . filter (/= cl)) $ roomClientsS ri |
67 |
68 |
|
69 othersChansProto :: StateT ServerState IO [(ClientChan, Word16)] |
|
70 othersChansProto = do |
|
71 cl <- client's id |
|
72 ri <- clientRoomA |
|
73 map (\ci -> (sendChan ci, clientProto ci)) . filter (/= cl) <$> roomClientsS ri |
|
74 |
68 processAction :: Action -> StateT ServerState IO () |
75 processAction :: Action -> StateT ServerState IO () |
69 |
76 |
70 |
77 |
71 processAction (AnswerClients chans msg) = |
78 processAction (AnswerClients chans msg) = |
72 io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans) |
79 io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans) |
|
80 |
|
81 |
|
82 processAction (AnswerClientsByProto chansProto msgFunc) = |
|
83 io $ mapM_ (\(chan, proto) -> writeChan chan (msgFunc proto)) chansProto |
73 |
84 |
74 |
85 |
75 processAction SendServerMessage = do |
86 processAction SendServerMessage = do |
76 chan <- client's sendChan |
87 chan <- client's sendChan |
77 protonum <- client's clientProto |
88 protonum <- client's clientProto |
277 , isRestrictedTeams = False |
288 , isRestrictedTeams = False |
278 , isRegisteredOnly = isSpecial r} |
289 , isRegisteredOnly = isSpecial r} |
279 ) |
290 ) |
280 |
291 |
281 newRoom' <- io $ room'sM rnc id ri |
292 newRoom' <- io $ room'sM rnc id ri |
282 chans <- liftM (map sendChan) $! sameProtoClientsS proto |
293 chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS |
283 processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo proto (maybeNick newMaster) newRoom') |
294 let oldRoomNameByProto = roomNameByProto oldRoomName (roomProto newRoom') |
|
295 processAction $ AnswerClientsByProto chansProto (\p -> "ROOM" : "UPD" : oldRoomNameByProto p : roomInfo p (maybeNick newMaster) newRoom') |
284 |
296 |
285 |
297 |
286 processAction (AddRoom roomName roomPassword) = do |
298 processAction (AddRoom roomName roomPassword) = do |
287 Just clId <- gets clientIndex |
299 Just clId <- gets clientIndex |
288 rnc <- gets roomsClients |
300 rnc <- gets roomsClients |
298 |
310 |
299 rId <- io $ addRoom rnc rm |
311 rId <- io $ addRoom rnc rm |
300 |
312 |
301 processAction $ MoveToRoom rId |
313 processAction $ MoveToRoom rId |
302 |
314 |
303 chans <- liftM (map sendChan) $! sameProtoClientsS proto |
315 chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS |
304 |
316 |
305 mapM_ processAction [ |
317 mapM_ processAction [ |
306 AnswerClients chans ("ROOM" : "ADD" : roomInfo proto n rm{playersIn = 1}) |
318 AnswerClientsByProto chansProto (\p -> "ROOM" : "ADD" : roomInfo p n rm{playersIn = 1}) |
307 ] |
319 ] |
308 |
320 |
309 |
321 |
310 processAction RemoveRoom = do |
322 processAction RemoveRoom = do |
311 Just clId <- gets clientIndex |
323 Just clId <- gets clientIndex |
312 rnc <- gets roomsClients |
324 rnc <- gets roomsClients |
313 ri <- io $ clientRoomM rnc clId |
325 ri <- io $ clientRoomM rnc clId |
314 roomName <- io $ room'sM rnc name ri |
326 roomName <- io $ room'sM rnc name ri |
315 others <- othersChans |
327 roomProto <- io $ room'sM rnc roomProto ri |
316 proto <- client's clientProto |
328 others <- othersChansProto |
317 chans <- liftM (map sendChan) $! sameProtoClientsS proto |
329 chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS |
318 |
330 |
319 mapM_ processAction [ |
331 mapM_ processAction [ |
320 AnswerClients chans ["ROOM", "DEL", roomName], |
332 AnswerClientsByProto chansProto (\p -> ["ROOM", "DEL", roomNameByProto roomName roomProto p]), |
321 AnswerClients others ["ROOMABANDONED", roomName] |
333 AnswerClientsByProto others (\p -> ["ROOMABANDONED", roomNameByProto roomName roomProto p]) |
322 ] |
334 ] |
323 |
335 |
324 io $ removeRoom rnc ri |
336 io $ removeRoom rnc ri |
325 |
337 |
326 |
338 |
329 proto <- client's clientProto |
341 proto <- client's clientProto |
330 rnc <- gets roomsClients |
342 rnc <- gets roomsClients |
331 ri <- io $ clientRoomM rnc clId |
343 ri <- io $ clientRoomM rnc clId |
332 rm <- io $ room'sM rnc id ri |
344 rm <- io $ room'sM rnc id ri |
333 masterCl <- io $ client'sM rnc id `DT.mapM` (masterID rm) |
345 masterCl <- io $ client'sM rnc id `DT.mapM` (masterID rm) |
334 chans <- liftM (map sendChan) $! sameProtoClientsS proto |
346 chansProto <- fmap (map (\c -> (sendChan c, clientProto c))) $! allClientsS |
335 processAction $ AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo proto (maybeNick masterCl) rm) |
347 let thisRoomNameByProto = roomNameByProto (name rm) (roomProto rm) |
|
348 processAction $ AnswerClientsByProto chansProto (\p -> "ROOM" : "UPD" : thisRoomNameByProto p : roomInfo p (maybeNick masterCl) rm) |
336 |
349 |
337 |
350 |
338 processAction UnreadyRoomClients = do |
351 processAction UnreadyRoomClients = do |
339 ri <- clientRoomA |
352 ri <- clientRoomA |
340 roomPlayers <- roomClientsS ri |
353 roomPlayers <- roomClientsS ri |
534 |
547 |
535 roomsInfoList <- io $ do |
548 roomsInfoList <- io $ do |
536 rooms <- roomsM rnc |
549 rooms <- roomsM rnc |
537 mapM (\r -> (mapM (client'sM rnc id) $ masterID r) |
550 mapM (\r -> (mapM (client'sM rnc id) $ masterID r) |
538 >>= \cn -> return $ roomInfo clProto (maybeNick cn) r) |
551 >>= \cn -> return $ roomInfo clProto (maybeNick cn) r) |
539 $ filter (\r -> (roomProto r == clProto)) rooms |
552 $ filter ((/=) 0 . roomProto) rooms |
540 |
553 |
541 mapM_ processAction . concat $ [ |
554 mapM_ processAction . concat $ [ |
542 [AnswerClients clientsChans ["LOBBY:JOINED", clientNick]] |
555 [AnswerClients clientsChans ["LOBBY:JOINED", clientNick]] |
543 , [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)] |
556 , [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)] |
544 , [AnswerClients [chan] ("CLIENT_FLAGS" : "+u" : authenticatedNicks) | not $ null authenticatedNicks] |
557 , [AnswerClients [chan] ("CLIENT_FLAGS" : "+u" : authenticatedNicks) | not $ null authenticatedNicks] |