diff -r 835fd7a0e1bf -r 5e3c5fe2cb14 gameServer/Actions.hs --- a/gameServer/Actions.hs Thu Nov 11 11:04:24 2010 -0500 +++ b/gameServer/Actions.hs Thu Nov 11 22:17:54 2010 +0300 @@ -1,134 +1,171 @@ -{-# LANGUAGE OverloadedStrings #-} module Actions where -import Control.Concurrent +import Control.Concurrent.STM import Control.Concurrent.Chan +import Data.IntMap import qualified Data.IntSet as IntSet -import qualified Data.Set as Set import qualified Data.Sequence as Seq import System.Log.Logger -import Control.Monad +import Monad import Data.Time -import Data.Maybe -import Control.Monad.Reader -import Control.Monad.State.Strict -import qualified Data.ByteString.Char8 as B +import Maybe ----------------------------- import CoreTypes import Utils -import ClientIO -import ServerState data Action = - AnswerClients ![ClientChan] ![B.ByteString] + AnswerThisClient [String] + | AnswerAll [String] + | AnswerAllOthers [String] + | AnswerThisRoom [String] + | AnswerOthersInRoom [String] + | AnswerSameClan [String] + | AnswerLobby [String] | SendServerMessage | SendServerVars - | MoveToRoom RoomIndex - | MoveToLobby B.ByteString - | RemoveTeam B.ByteString + | RoomAddThisClient Int -- roomID + | RoomRemoveThisClient String + | RemoveTeam String | RemoveRoom | UnreadyRoomClients - | JoinLobby - | ProtocolError B.ByteString - | Warning B.ByteString - | ByeClient B.ByteString - | KickClient ClientIndex - | KickRoomClient ClientIndex - | BanClient B.ByteString -- nick - | RemoveClientTeams ClientIndex + | MoveToLobby + | ProtocolError String + | Warning String + | ByeClient String + | KickClient Int -- clID + | KickRoomClient Int -- clID + | BanClient String -- nick + | RemoveClientTeams Int -- clID | ModifyClient (ClientInfo -> ClientInfo) - | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo) + | ModifyClient2 Int (ClientInfo -> ClientInfo) | ModifyRoom (RoomInfo -> RoomInfo) | ModifyServerInfo (ServerInfo -> ServerInfo) - | AddRoom B.ByteString B.ByteString + | AddRoom String String | CheckRegistered | ClearAccountsCache | ProcessAccountInfo AccountInfo | Dump | AddClient ClientInfo - | DeleteClient ClientIndex | PingAll | StatsAction -type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] +type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action] + +replaceID a (b, c, d, e) = (a, c, d, e) + +processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms) + + +processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do + writeChan (sendChan $ clients ! clID) msg + return (clID, serverInfo, clients, rooms) -processAction :: Action -> StateT ServerState IO () +processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do + mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients) + return (clID, serverInfo, clients, rooms) + + +processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do + mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ + Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients) + return (clID, serverInfo, clients, rooms) + + +processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do + mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients + return (clID, serverInfo, clients, rooms) + where + roomClients = IntSet.elems $ playersIDs room + room = rooms ! rID + rID = roomID client + client = clients ! clID -processAction (AnswerClients chans msg) = do - liftIO $ map (flip seq ()) chans `seq` map (flip seq ()) msg `seq` mapM_ (flip writeChan msg) chans +processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do + mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ Prelude.filter (/= clID) roomClients + return (clID, serverInfo, clients, rooms) + where + roomClients = IntSet.elems $ playersIDs room + room = rooms ! rID + rID = roomID client + client = clients ! clID + + +processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do + mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients + return (clID, serverInfo, clients, rooms) + where + roomClients = IntSet.elems $ playersIDs room + room = rooms ! 0 -processAction SendServerMessage = do - chan <- client's sendChan - protonum <- client's clientProto - si <- liftM serverInfo get - let message = if protonum < latestReleaseVersion si then +processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do + mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec + return (clID, serverInfo, clients, rooms) + where + otherRoomClients = Prelude.map ((!) clients) $ IntSet.elems $ clID `IntSet.delete` (playersIDs room) + sameClanOrSpec = if teamsInGame client > 0 then sameClanClients else spectators + spectators = Prelude.filter (\cl -> teamsInGame cl == 0) otherRoomClients + sameClanClients = Prelude.filter (\cl -> teamsInGame cl > 0 && clientClan cl == thisClan) otherRoomClients + thisClan = clientClan client + room = rooms ! rID + rID = roomID client + client = clients ! clID + + +processAction (clID, serverInfo, clients, rooms) SendServerMessage = do + writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo] + return (clID, serverInfo, clients, rooms) + where + client = clients ! clID + message si = if clientProto client < latestReleaseVersion si then serverMessageForOldVersions si else serverMessage si - processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message] -{- -processAction (clID, serverInfo, rnc) SendServerVars = do +processAction (clID, serverInfo, clients, rooms) SendServerVars = do writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars) - return (clID, serverInfo, rnc) + return (clID, serverInfo, clients, rooms) where client = clients ! clID vars = [ - "MOTD_NEW", serverMessage serverInfo, - "MOTD_OLD", serverMessageForOldVersions serverInfo, + "MOTD_NEW", serverMessage serverInfo, + "MOTD_OLD", serverMessageForOldVersions serverInfo, "LATEST_PROTO", show $ latestReleaseVersion serverInfo ] --} +processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do + writeChan (sendChan $ clients ! clID) ["ERROR", msg] + return (clID, serverInfo, clients, rooms) -processAction (ProtocolError msg) = do - chan <- client's sendChan - processAction $ AnswerClients [chan] ["ERROR", msg] + +processAction (clID, serverInfo, clients, rooms) (Warning msg) = do + writeChan (sendChan $ clients ! clID) ["WARNING", msg] + return (clID, serverInfo, clients, rooms) -processAction (Warning msg) = do - chan <- client's sendChan - processAction $ AnswerClients [chan] ["WARNING", msg] - -processAction (ByeClient msg) = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - ri <- clientRoomA - - chan <- client's sendChan - ready <- client's isReady +processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do + infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg) + (_, _, newClients, newRooms) <- + if roomID client /= 0 then + processAction (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit" + else + return (clID, serverInfo, clients, rooms) - when (ri /= lobbyId) $ do - processAction $ MoveToLobby ("quit: " `B.append` msg) - liftIO $ modifyRoom rnc (\r -> r{ - --playersIDs = IntSet.delete ci (playersIDs r) - playersIn = (playersIn r) - 1, - readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r - }) ri - return () - - liftIO $ do - infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg)) - - --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom - - processAction $ AnswerClients [chan] ["BYE", msg] - - s <- get - put $! s{removedClients = ci `Set.insert` removedClients s} - -processAction (DeleteClient ci) = do - rnc <- gets roomsClients - liftIO $ removeClient rnc ci - - s <- get - put $! s{removedClients = ci `Set.delete` removedClients s} - -{- + mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom + writeChan (sendChan $ clients ! clID) ["BYE", msg] + return ( + 0, + serverInfo, + delete clID newClients, + adjust (\r -> r{ + playersIDs = IntSet.delete clID (playersIDs r), + playersIn = (playersIn r) - 1, + readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r + }) (roomID $ newClients ! clID) newRooms + ) where client = clients ! clID clientNick = nick client @@ -147,57 +184,46 @@ else [AnswerAll ["LOBBY:LEFT", clientNick]] else - [] --} + [] + + +processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = + return (clID, serverInfo, adjust func clID clients, rooms) + -processAction (ModifyClient f) = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - liftIO $ modifyClient rnc f ci - return () +processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) = + return (clID, serverInfo, adjust func cl2ID clients, rooms) + -processAction (ModifyClient2 ci f) = do - rnc <- gets roomsClients - liftIO $ modifyClient rnc f ci - return () +processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = + return (clID, serverInfo, clients, adjust func rID rooms) + where + rID = roomID $ clients ! clID -processAction (ModifyRoom f) = do - rnc <- gets roomsClients - ri <- clientRoomA - liftIO $ modifyRoom rnc f ri - return () +processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) = + return (clID, func serverInfo, clients, rooms) -{- - -processAction (clID, serverInfo, rnc) (ModifyServerInfo func) = - return (clID, func serverInfo, rnc) - --} -processAction (MoveToRoom ri) = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - liftIO $ do - modifyClient rnc (\cl -> cl{teamsInGame = 0}) ci - modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri - - liftIO $ moveClientToRoom rnc ri ci - - chans <- liftM (map sendChan) $ roomClientsS ri - clNick <- client's nick +processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) = + processAction ( + clID, + serverInfo, + adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients, + adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $ + adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms + ) joinMsg + where + client = clients ! clID + joinMsg = if rID == 0 then + AnswerAllOthers ["LOBBY:JOINED", nick client] + else + AnswerThisRoom ["JOINED", nick client] - processAction $ AnswerClients chans ["JOINED", clNick] -processAction (MoveToLobby msg) = do - (Just ci) <- gets clientIndex - --ri <- clientRoomA - rnc <- gets roomsClients - - liftIO $ moveClientToLobby rnc ci - -{- +processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do (_, _, newClients, newRooms) <- + if roomID client /= 0 then if isMaster client then if (gameinprogress room) && (playersIn room > 1) then (changeMaster >>= (\state -> foldM processAction state @@ -205,15 +231,16 @@ AnswerOthersInRoom ["WARNING", "Admin left the room"], RemoveClientTeams clID])) else -- not in game - processAction (clID, serverInfo, rnc) RemoveRoom + processAction (clID, serverInfo, clients, rooms) RemoveRoom else -- not master foldM processAction - (clID, serverInfo, rnc) + (clID, serverInfo, clients, rooms) [AnswerOthersInRoom ["LEFT", nick client, msg], RemoveClientTeams clID] - - + else -- in lobby + return (clID, serverInfo, clients, rooms) + return ( clID, serverInfo, @@ -232,7 +259,7 @@ } insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)} changeMaster = do - processAction (newMasterId, serverInfo, rnc) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] + processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] return ( clID, serverInfo, @@ -243,35 +270,34 @@ otherPlayersSet = IntSet.delete clID (playersIDs room) newMasterId = IntSet.findMin otherPlayersSet newMasterClient = clients ! newMasterId --} + -processAction (AddRoom roomName roomPassword) = do - Just clId <- gets clientIndex - rnc <- gets roomsClients - proto <- liftIO $ client'sM rnc clientProto clId - +processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do + let newServerInfo = serverInfo {nextRoomID = newID} let room = newRoom{ - masterID = clId, + roomUID = newID, + masterID = clID, name = roomName, password = roomPassword, - roomProto = proto + roomProto = (clientProto client) } - rId <- liftIO $ addRoom rnc room - - processAction $ MoveToRoom rId - - chans <- liftM (map sendChan) $! roomClientsS lobbyId + processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName] - mapM_ processAction [ - AnswerClients chans ["ROOM", "ADD", roomName] - , ModifyClient (\cl -> cl{isMaster = True}) - ] + processAction ( + clID, + newServerInfo, + adjust (\cl -> cl{isMaster = True}) clID clients, + insert newID room rooms + ) $ RoomAddThisClient newID + where + newID = (nextRoomID serverInfo) - 1 + client = clients ! clID -{- -processAction (clID, serverInfo, rnc) (RemoveRoom) = do - processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "DEL", name room] - processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["ROOMABANDONED", name room] + +processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do + processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room] + processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room] return (clID, serverInfo, Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients, @@ -282,163 +308,139 @@ rID = roomID client client = clients ! clID --} -processAction (UnreadyRoomClients) = do - rnc <- gets roomsClients - ri <- clientRoomA - roomPlayers <- roomClientsS ri - roomClIDs <- liftIO $ roomClientsIndicesM rnc ri - processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers) - liftIO $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs - processAction $ ModifyRoom (\r -> r{readyPlayers = 0}) + +processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do + processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers) + return (clID, + serverInfo, + Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients, + adjust (\r -> r{readyPlayers = 0}) rID rooms) + where + room = rooms ! rID + rID = roomID client + client = clients ! clID + roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs + roomPlayersIDs = IntSet.elems $ playersIDs room -processAction (RemoveTeam teamName) = do - rnc <- gets roomsClients - cl <- client's id - ri <- clientRoomA - inGame <- liftIO $ room'sM rnc gameinprogress ri - chans <- liftM (map sendChan . filter (/= cl)) $ roomClientsS ri - if inGame then - mapM_ processAction [ - AnswerClients chans ["REMOVE_TEAM", teamName], - ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) - ] +processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do + newRooms <- if not $ gameinprogress room then + do + processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName] + return $ + adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms else - mapM_ processAction [ - AnswerClients chans ["EM", rmTeamMsg], - ModifyRoom (\r -> r{ - teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, - leftTeams = teamName : leftTeams r, - roundMsgs = roundMsgs r Seq.|> rmTeamMsg - }) - ] + do + processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg] + return $ + adjust (\r -> r{ + teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, + leftTeams = teamName : leftTeams r, + roundMsgs = roundMsgs r Seq.|> rmTeamMsg + }) rID rooms + return (clID, serverInfo, clients, newRooms) where - rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName + room = rooms ! rID + rID = roomID client + client = clients ! clID + rmTeamMsg = toEngineMsg $ 'F' : teamName -processAction CheckRegistered = do - (Just ci) <- gets clientIndex - n <- client's nick - h <- client's host - db <- gets (dbQueries . serverInfo) - liftIO $ writeChan db $ CheckAccount ci n h - return () -{- -processAction (clID, serverInfo, rnc) (ClearAccountsCache) = do - writeChan (dbQueries serverInfo) ClearCache - return (clID, serverInfo, rnc) +processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do + writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client) + return (clID, serverInfo, clients, rooms) where client = clients ! clID -processAction (clID, serverInfo, rnc) (Dump) = do +processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do + writeChan (dbQueries serverInfo) ClearCache + return (clID, serverInfo, clients, rooms) + where + client = clients ! clID + + +processAction (clID, serverInfo, clients, rooms) (Dump) = do writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] - return (clID, serverInfo, rnc) --} + return (clID, serverInfo, clients, rooms) -processAction (ProcessAccountInfo info) = + +processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) = case info of HasAccount passwd isAdmin -> do - chan <- client's sendChan - processAction $ AnswerClients [chan] ["ASKPASSWORD"] + infoM "Clients" $ show clID ++ " has account" + writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"] + return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms) Guest -> do - processAction JoinLobby + infoM "Clients" $ show clID ++ " is guest" + processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby Admin -> do - mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] - chan <- client's sendChan - processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] + infoM "Clients" $ show clID ++ " is admin" + foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]] -processAction JoinLobby = do - chan <- client's sendChan - clientNick <- client's nick - (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) $! allClientsS - mapM_ processAction $ - (AnswerClients clientsChans ["LOBBY:JOINED", clientNick]) - : [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)] - ++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage] +processAction (clID, serverInfo, clients, rooms) (MoveToLobby) = + foldM processAction (clID, serverInfo, clients, rooms) $ + (RoomAddThisClient 0) + : answerLobbyNicks + ++ [SendServerMessage] -{- -processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) = - processAction ( - clID, - serverInfo, - adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients, - adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $ - adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms - ) joinMsg + -- ++ (answerServerMessage client clients) where - client = clients ! clID - joinMsg = if rID == 0 then - AnswerAllOthers ["LOBBY:JOINED", nick client] - else - AnswerThisRoom ["JOINED", nick client] - -processAction (clID, serverInfo, rnc) (KickClient kickID) = - liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked") + lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients + answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks] -processAction (clID, serverInfo, rnc) (BanClient banNick) = - return (clID, serverInfo, rnc) +processAction (clID, serverInfo, clients, rooms) (KickClient kickID) = + liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked") + + +processAction (clID, serverInfo, clients, rooms) (BanClient banNick) = + return (clID, serverInfo, clients, rooms) -processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do +processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do writeChan (sendChan $ clients ! kickID) ["KICKED"] - liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked") + liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked") -processAction (clID, serverInfo, rnc) (RemoveClientTeams teamsClID) = +processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) = liftM2 replaceID (return clID) $ - foldM processAction (teamsClID, serverInfo, rnc) removeTeamsActions + foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions where client = clients ! teamsClID room = rooms ! (roomID client) teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove --} + -processAction (AddClient client) = do - rnc <- gets roomsClients - si <- gets serverInfo - liftIO $ do - ci <- addClient rnc client - forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci - forkIO $ clientSendLoop (clientSocket client) (sendChan client) ci +processAction (clID, serverInfo, clients, rooms) (AddClient client) = do + let updatedClients = insert (clientUID client) client clients + infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client)) + writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] - infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client)) - - processAction $ AnswerClients [sendChan client] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] -{- let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo + let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo - if False && (isJust $ host client `Prelude.lookup` newLogins) then - processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast" - else - return (ci, serverInfo) --} - + if isJust $ host client `Prelude.lookup` newLogins then + processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast" + else + return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms) -processAction PingAll = do - rnc <- gets roomsClients - liftIO (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) - cis <- liftIO $ allClientsM rnc - chans <- liftIO $ mapM (client'sM rnc sendChan) cis - liftIO $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis - processAction $ AnswerClients chans ["PING"] +processAction (clID, serverInfo, clients, rooms) PingAll = do + (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients + processAction (clID, + serverInfo, + Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients, + newRooms) $ AnswerAll ["PING"] where - kickTimeouted rnc ci = do - pq <- liftIO $ client'sM rnc pingsQueue ci - when (pq > 0) $ - withStateT (\as -> as{clientIndex = Just ci}) $ - processAction (ByeClient "Ping timeout") + kickTimeouted (clID, serverInfo, clients, rooms) client = + if pingsQueue client > 0 then + processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout" + else + return (clID, serverInfo, clients, rooms) -processAction (StatsAction) = do - rnc <- gets roomsClients - si <- gets serverInfo - (roomsNum, clientsNum) <- liftIO $ withRoomsAndClients rnc stats - liftIO $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1) - where - stats irnc = (length $ allRooms irnc, length $ allClients irnc) - +processAction (clID, serverInfo, clients, rooms) (StatsAction) = do + writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1) + return (clID, serverInfo, clients, rooms)