54 |
54 |
55 |
55 |
56 processAction :: Action -> StateT ServerState IO () |
56 processAction :: Action -> StateT ServerState IO () |
57 |
57 |
58 |
58 |
59 processAction (AnswerClients chans msg) = |
59 processAction (AnswerClients chans msg) = do |
60 liftIO $ mapM_ (flip writeChan msg) chans |
60 liftIO (putStr $ "AnswerClients... " ++ (show $ length chans) ++ " (" ++ (show msg) ++")") |
|
61 liftIO $ map (flip seq ()) chans `seq` mapM_ (flip writeChan msg) chans |
|
62 liftIO (putStrLn "done") |
61 |
63 |
62 |
64 |
63 processAction SendServerMessage = do |
65 processAction SendServerMessage = do |
64 chan <- client's sendChan |
66 chan <- client's sendChan |
65 protonum <- client's clientProto |
67 protonum <- client's clientProto |
66 si <- liftM serverInfo get |
68 si <- liftM serverInfo get |
67 let message = if protonum < latestReleaseVersion si then |
69 let message = if protonum < latestReleaseVersion si then |
68 serverMessageForOldVersions si |
70 serverMessageForOldVersions si |
69 else |
71 else |
70 serverMessage si |
72 serverMessage si |
71 liftIO $ writeChan chan ["SERVER_MESSAGE", message] |
73 processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message] |
72 {- |
74 {- |
73 |
75 |
74 processAction (clID, serverInfo, rnc) SendServerVars = do |
76 processAction (clID, serverInfo, rnc) SendServerVars = do |
75 writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars) |
77 writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars) |
76 return (clID, serverInfo, rnc) |
78 return (clID, serverInfo, rnc) |
85 |
87 |
86 -} |
88 -} |
87 |
89 |
88 processAction (ProtocolError msg) = do |
90 processAction (ProtocolError msg) = do |
89 chan <- client's sendChan |
91 chan <- client's sendChan |
90 liftIO $ writeChan chan ["ERROR", msg] |
92 processAction $ AnswerClients [chan] ["ERROR", msg] |
91 |
93 |
92 |
94 |
93 processAction (Warning msg) = do |
95 processAction (Warning msg) = do |
94 chan <- client's sendChan |
96 chan <- client's sendChan |
95 liftIO $ writeChan chan ["WARNING", msg] |
97 processAction $ AnswerClients [chan] ["WARNING", msg] |
96 |
98 |
97 processAction (ByeClient msg) = do |
99 processAction (ByeClient msg) = do |
98 (Just ci) <- gets clientIndex |
100 (Just ci) <- gets clientIndex |
99 rnc <- gets roomsClients |
101 rnc <- gets roomsClients |
100 ri <- clientRoomA |
102 ri <- clientRoomA |
107 |
109 |
108 liftIO $ do |
110 liftIO $ do |
109 infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg)) |
111 infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg)) |
110 |
112 |
111 --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom |
113 --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom |
112 writeChan chan ["BYE", msg] |
|
113 modifyRoom rnc (\r -> r{ |
114 modifyRoom rnc (\r -> r{ |
114 --playersIDs = IntSet.delete ci (playersIDs r) |
115 --playersIDs = IntSet.delete ci (playersIDs r) |
115 playersIn = (playersIn r) - 1, |
116 playersIn = (playersIn r) - 1, |
116 readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r |
117 readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r |
117 }) ri |
118 }) ri |
118 |
119 |
|
120 processAction $ AnswerClients [chan] ["BYE", msg] |
119 modify (\s -> s{removedClients = ci `Set.insert` removedClients s}) |
121 modify (\s -> s{removedClients = ci `Set.insert` removedClients s}) |
120 |
122 |
121 processAction (DeleteClient ci) = do |
123 processAction (DeleteClient ci) = do |
122 rnc <- gets roomsClients |
124 rnc <- gets roomsClients |
123 liftIO $ removeClient rnc ci |
125 liftIO $ removeClient rnc ci |
334 |
336 |
335 processAction (ProcessAccountInfo info) = |
337 processAction (ProcessAccountInfo info) = |
336 case info of |
338 case info of |
337 HasAccount passwd isAdmin -> do |
339 HasAccount passwd isAdmin -> do |
338 chan <- client's sendChan |
340 chan <- client's sendChan |
339 liftIO $ writeChan chan ["ASKPASSWORD"] |
341 processAction $ AnswerClients [chan] ["ASKPASSWORD"] |
340 Guest -> do |
342 Guest -> do |
341 processAction JoinLobby |
343 processAction JoinLobby |
342 Admin -> do |
344 Admin -> do |
343 mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] |
345 mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] |
344 chan <- client's sendChan |
346 chan <- client's sendChan |
345 liftIO $ writeChan chan ["ADMIN_ACCESS"] |
347 processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] |
346 |
348 |
347 |
349 |
348 processAction JoinLobby = do |
350 processAction JoinLobby = do |
349 chan <- client's sendChan |
351 chan <- client's sendChan |
350 clientNick <- client's nick |
352 clientNick <- client's nick |
400 ci <- addClient rnc client |
402 ci <- addClient rnc client |
401 forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci |
403 forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci |
402 forkIO $ clientSendLoop (clientSocket client) (coreChan si) (sendChan client) ci |
404 forkIO $ clientSendLoop (clientSocket client) (coreChan si) (sendChan client) ci |
403 |
405 |
404 infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client)) |
406 infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client)) |
405 writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
407 |
406 |
408 processAction $ AnswerClients [sendChan client] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
407 {- let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo |
409 {- let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo |
408 |
410 |
409 if False && (isJust $ host client `Prelude.lookup` newLogins) then |
411 if False && (isJust $ host client `Prelude.lookup` newLogins) then |
410 processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast" |
412 processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast" |
411 else |
413 else |