1 module Actions where |
1 module Actions where |
2 |
2 |
3 import Control.Concurrent |
3 import Control.Concurrent |
4 import Control.Concurrent.STM |
|
5 import Control.Concurrent.Chan |
4 import Control.Concurrent.Chan |
6 import qualified Data.IntSet as IntSet |
5 import qualified Data.IntSet as IntSet |
7 import qualified Data.Sequence as Seq |
6 import qualified Data.Sequence as Seq |
8 import System.Log.Logger |
7 import System.Log.Logger |
9 import Monad |
8 import Monad |
10 import Data.Time |
9 import Data.Time |
11 import Maybe |
10 import Maybe |
|
11 import Control.Monad.Reader |
12 |
12 |
13 ----------------------------- |
13 ----------------------------- |
14 import CoreTypes |
14 import CoreTypes |
15 import Utils |
15 import Utils |
16 import ClientIO |
16 import ClientIO |
17 import RoomsAndClients |
17 import RoomsAndClients |
18 |
18 |
19 data Action = |
19 data Action = |
20 AnswerClients [Chan [String]] [String] |
20 AnswerClients [ClientChan] [String] |
21 | SendServerMessage |
21 | SendServerMessage |
22 | SendServerVars |
22 | SendServerVars |
23 | RoomAddThisClient Int -- roomID |
23 | RoomAddThisClient Int -- roomID |
24 | RoomRemoveThisClient String |
24 | RoomRemoveThisClient String |
25 | RemoveTeam String |
25 | RemoveTeam String |
44 | Dump |
44 | Dump |
45 | AddClient ClientInfo |
45 | AddClient ClientInfo |
46 | PingAll |
46 | PingAll |
47 | StatsAction |
47 | StatsAction |
48 |
48 |
49 type CmdHandler = Int -> MRnC -> [String] -> [Action] |
49 type CmdHandler = [String] -> Reader (ClientIndex, IRnC) [Action] |
50 |
50 |
51 replaceID a (b, c, d, e) = (a, c, d, e) |
51 replaceID a (b, c, d, e) = (a, c, d, e) |
52 |
52 |
53 processAction :: (ClientIndex, ServerInfo, MRnC) -> Action -> IO (ClientIndex, ServerInfo) |
53 processAction :: (ClientIndex, ServerInfo, MRnC) -> Action -> IO (ClientIndex, ServerInfo) |
54 |
54 |
87 |
87 |
88 |
88 |
89 processAction (clID, serverInfo, rnc) (Warning msg) = do |
89 processAction (clID, serverInfo, rnc) (Warning msg) = do |
90 writeChan (sendChan $ clients ! clID) ["WARNING", msg] |
90 writeChan (sendChan $ clients ! clID) ["WARNING", msg] |
91 return (clID, serverInfo, rnc) |
91 return (clID, serverInfo, rnc) |
92 |
92 -} |
93 |
93 |
94 processAction (clID, serverInfo, rnc) (ByeClient msg) = do |
94 processAction (ci, serverInfo, rnc) (ByeClient msg) = do |
95 infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg) |
95 infoM "Clients" (show ci ++ " quits: " ++ msg) |
96 (_, _, newClients, newRooms) <- |
96 |
97 if roomID client /= 0 then |
97 ri <- clientRoomM rnc ci |
98 processAction (clID, serverInfo, rnc) $ RoomRemoveThisClient "quit" |
98 when (ri /= lobbyId) |
99 else |
99 processAction (ci, serverInfo, rnc) $ RoomRemoveThisClient ("quit: " ++ msg) |
100 return (clID, serverInfo, rnc) |
100 |
101 |
101 mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom |
102 mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom |
|
103 writeChan (sendChan $ clients ! clID) ["BYE", msg] |
102 writeChan (sendChan $ clients ! clID) ["BYE", msg] |
104 return ( |
103 return ( |
105 0, |
104 0, |
106 serverInfo, |
105 serverInfo, |
107 delete clID newClients, |
106 delete clID newClients, |
128 [AnswerAll ["LOBBY:LEFT", clientNick, msg]] |
127 [AnswerAll ["LOBBY:LEFT", clientNick, msg]] |
129 else |
128 else |
130 [AnswerAll ["LOBBY:LEFT", clientNick]] |
129 [AnswerAll ["LOBBY:LEFT", clientNick]] |
131 else |
130 else |
132 [] |
131 [] |
133 |
132 {- |
134 |
133 |
135 processAction (clID, serverInfo, rnc) (ModifyClient func) = |
134 processAction (clID, serverInfo, rnc) (ModifyClient func) = |
136 return (clID, serverInfo, adjust func clID rnc) |
135 return (clID, serverInfo, adjust func clID rnc) |
137 |
136 |
138 |
137 |
355 where |
354 where |
356 client = clients ! teamsClID |
355 client = clients ! teamsClID |
357 room = rooms ! (roomID client) |
356 room = rooms ! (roomID client) |
358 teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room |
357 teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room |
359 removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove |
358 removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove |
360 |
359 -} |
361 |
360 |
362 processAction (clID, serverInfo, rnc) (AddClient client) = do |
361 processAction (_, serverInfo, rnc) (AddClient client) = do |
363 forkIO $ clientRecvLoop (clientHandle client) (coreChan serverInfo) (clientUID client) |
362 ci <- addClient rnc client |
364 forkIO $ clientSendLoop (clientHandle client) (coreChan serverInfo) (sendChan client) (clientUID client) |
363 forkIO $ clientRecvLoop (clientHandle client) (coreChan serverInfo) ci |
365 |
364 forkIO $ clientSendLoop (clientHandle client) (coreChan serverInfo) (sendChan client) ci |
366 let updatedClients = insert (clientUID client) client clients |
365 |
367 infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client)) |
366 infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client)) |
368 writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
367 writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
369 |
368 |
370 let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo |
369 let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo |
371 |
370 |
372 if False && (isJust $ host client `Prelude.lookup` newLogins) then |
371 if False && (isJust $ host client `Prelude.lookup` newLogins) then |
373 processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast" |
372 processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast" |
374 else |
373 else |
375 return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms) |
374 return (ci, serverInfo) |
376 |
375 |
377 |
376 {- |
378 processAction (clID, serverInfo, rnc) PingAll = do |
377 processAction (clID, serverInfo, rnc) PingAll = do |
379 (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, rnc) $ elems clients |
378 (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, rnc) $ elems clients |
380 processAction (clID, |
379 processAction (clID, |
381 serverInfo, |
380 serverInfo, |
382 Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients, |
381 Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients, |