# HG changeset patch # User unc0rr # Date 1273046497 0 # Node ID ead2ed20dfd4c5d70cb1d71fde6935b479d5ccd6 # Parent 5543340db66354423dcb305c35ce16c2880a8484 Start the server refactoring diff -r 5543340db663 -r ead2ed20dfd4 gameServer/Actions.hs --- a/gameServer/Actions.hs Tue May 04 21:30:25 2010 +0000 +++ b/gameServer/Actions.hs Wed May 05 08:01:37 2010 +0000 @@ -1,26 +1,23 @@ 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.Sequence as Seq import System.Log.Logger import Monad import Data.Time import Maybe + ----------------------------- import CoreTypes import Utils +import ClientIO +import RoomsAndClients data Action = - AnswerThisClient [String] - | AnswerAll [String] - | AnswerAllOthers [String] - | AnswerThisRoom [String] - | AnswerOthersInRoom [String] - | AnswerSameClan [String] - | AnswerLobby [String] + AnswerClients [Chan [String]] [String] | SendServerMessage | SendServerVars | RoomAddThisClient Int -- roomID @@ -49,74 +46,22 @@ | PingAll | StatsAction -type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action] +type CmdHandler = Int -> MRnC -> [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 (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 :: (ClientIndex, ServerInfo, MRnC) -> Action -> IO (ClientIndex, ServerInfo) -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 (ci, serverInfo, rnc) (AnswerClients chans msg) = do + mapM_ (flip writeChan msg) chans + return (ci, serverInfo) -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 +{- +processAction (clID, serverInfo, rnc) SendServerMessage = do writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo] - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) where client = clients ! clID message si = if clientProto client < latestReleaseVersion si then @@ -124,35 +69,35 @@ else serverMessage si -processAction (clID, serverInfo, clients, rooms) SendServerVars = do +processAction (clID, serverInfo, rnc) SendServerVars = do writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars) - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) 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 +processAction (clID, serverInfo, rnc) (ProtocolError msg) = do writeChan (sendChan $ clients ! clID) ["ERROR", msg] - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) -processAction (clID, serverInfo, clients, rooms) (Warning msg) = do +processAction (clID, serverInfo, rnc) (Warning msg) = do writeChan (sendChan $ clients ! clID) ["WARNING", msg] - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) -processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do +processAction (clID, serverInfo, rnc) (ByeClient msg) = do infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg) (_, _, newClients, newRooms) <- if roomID client /= 0 then - processAction (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit" + processAction (clID, serverInfo, rnc) $ RoomRemoveThisClient "quit" else - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom writeChan (sendChan $ clients ! clID) ["BYE", msg] @@ -187,25 +132,25 @@ [] -processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = - return (clID, serverInfo, adjust func clID clients, rooms) +processAction (clID, serverInfo, rnc) (ModifyClient func) = + return (clID, serverInfo, adjust func clID rnc) -processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) = - return (clID, serverInfo, adjust func cl2ID clients, rooms) +processAction (clID, serverInfo, rnc) (ModifyClient2 cl2ID func) = + return (clID, serverInfo, adjust func cl2ID rnc) -processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = +processAction (clID, serverInfo, rnc) (ModifyRoom func) = return (clID, serverInfo, clients, adjust func rID rooms) where rID = roomID $ clients ! clID -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 (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) = +processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) = processAction ( clID, serverInfo, @@ -221,7 +166,7 @@ AnswerThisRoom ["JOINED", nick client] -processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do +processAction (clID, serverInfo, rnc) (RoomRemoveThisClient msg) = do (_, _, newClients, newRooms) <- if roomID client /= 0 then if isMaster client then @@ -231,16 +176,16 @@ AnswerOthersInRoom ["WARNING", "Admin left the room"], RemoveClientTeams clID])) else -- not in game - processAction (clID, serverInfo, clients, rooms) RemoveRoom + processAction (clID, serverInfo, rnc) RemoveRoom else -- not master foldM processAction - (clID, serverInfo, clients, rooms) + (clID, serverInfo, rnc) [AnswerOthersInRoom ["LEFT", nick client, msg], RemoveClientTeams clID] else -- in lobby - return (clID, serverInfo, clients, rooms) - + return (clID, serverInfo, rnc) + return ( clID, serverInfo, @@ -259,7 +204,7 @@ } insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)} changeMaster = do - processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] + processAction (newMasterId, serverInfo, rnc) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] return ( clID, serverInfo, @@ -272,7 +217,7 @@ newMasterClient = clients ! newMasterId -processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do +processAction (clID, serverInfo, rnc) (AddRoom roomName roomPassword) = do let newServerInfo = serverInfo {nextRoomID = newID} let room = newRoom{ roomUID = newID, @@ -282,7 +227,7 @@ roomProto = (clientProto client) } - processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName] + processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "ADD", roomName] processAction ( clID, @@ -295,9 +240,9 @@ client = clients ! clID -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] +processAction (clID, serverInfo, rnc) (RemoveRoom) = do + processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "DEL", name room] + processAction (clID, serverInfo, rnc) $ 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, @@ -309,8 +254,8 @@ client = clients ! clID -processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do - processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers) +processAction (clID, serverInfo, rnc) (UnreadyRoomClients) = do + processAction (clID, serverInfo, rnc) $ AnswerThisRoom ("NOT_READY" : roomPlayers) return (clID, serverInfo, Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients, @@ -323,15 +268,15 @@ roomPlayersIDs = IntSet.elems $ playersIDs room -processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do +processAction (clID, serverInfo, rnc) (RemoveTeam teamName) = do newRooms <- if not $ gameinprogress room then do - processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName] + processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName] return $ adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms else do - processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg] + processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["EM", rmTeamMsg] return $ adjust (\r -> r{ teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, @@ -346,41 +291,41 @@ rmTeamMsg = toEngineMsg $ 'F' : teamName -processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do +processAction (clID, serverInfo, rnc) (CheckRegistered) = do writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client) - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) where client = clients ! clID -processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do +processAction (clID, serverInfo, rnc) (ClearAccountsCache) = do writeChan (dbQueries serverInfo) ClearCache - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) where client = clients ! clID -processAction (clID, serverInfo, clients, rooms) (Dump) = do +processAction (clID, serverInfo, rnc) (Dump) = do writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) -processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) = +processAction (clID, serverInfo, rnc) (ProcessAccountInfo info) = case info of HasAccount passwd isAdmin -> do infoM "Clients" $ show clID ++ " has account" writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"] - return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms) + return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID rnc) Guest -> do infoM "Clients" $ show clID ++ " is guest" - processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby + processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID rnc) MoveToLobby Admin -> do infoM "Clients" $ show clID ++ " is admin" - foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]] + foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID rnc) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]] -processAction (clID, serverInfo, clients, rooms) (MoveToLobby) = - foldM processAction (clID, serverInfo, clients, rooms) $ +processAction (clID, serverInfo, rnc) (MoveToLobby) = + foldM processAction (clID, serverInfo, rnc) $ (RoomAddThisClient 0) : answerLobbyNicks ++ [SendServerMessage] @@ -391,22 +336,22 @@ answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks] -processAction (clID, serverInfo, clients, rooms) (KickClient kickID) = - liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked") +processAction (clID, serverInfo, rnc) (KickClient kickID) = + liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked") -processAction (clID, serverInfo, clients, rooms) (BanClient banNick) = - return (clID, serverInfo, clients, rooms) +processAction (clID, serverInfo, rnc) (BanClient banNick) = + return (clID, serverInfo, rnc) -processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do +processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do writeChan (sendChan $ clients ! kickID) ["KICKED"] - liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked") + liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked") -processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) = +processAction (clID, serverInfo, rnc) (RemoveClientTeams teamsClID) = liftM2 replaceID (return clID) $ - foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions + foldM processAction (teamsClID, serverInfo, rnc) removeTeamsActions where client = clients ! teamsClID room = rooms ! (roomID client) @@ -414,33 +359,38 @@ removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove -processAction (clID, serverInfo, clients, rooms) (AddClient client) = do +processAction (clID, serverInfo, rnc) (AddClient client) = do + forkIO $ clientRecvLoop (clientHandle client) (coreChan serverInfo) (clientUID client) + forkIO $ clientSendLoop (clientHandle client) (coreChan serverInfo) (sendChan client) (clientUID client) + 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/"] let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo - if isJust $ host client `Prelude.lookup` newLogins then + if False && (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 (clID, serverInfo, clients, rooms) PingAll = do - (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients +processAction (clID, serverInfo, rnc) PingAll = do + (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, rnc) $ elems clients processAction (clID, serverInfo, Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients, newRooms) $ AnswerAll ["PING"] where - kickTimeouted (clID, serverInfo, clients, rooms) client = + kickTimeouted (clID, serverInfo, rnc) client = if pingsQueue client > 0 then - processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout" + processAction (clientUID client, serverInfo, rnc) $ ByeClient "Ping timeout" else - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) -processAction (clID, serverInfo, clients, rooms) (StatsAction) = do +processAction (clID, serverInfo, rnc) (StatsAction) = do writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1) - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) + +-} \ No newline at end of file diff -r 5543340db663 -r ead2ed20dfd4 gameServer/CoreTypes.hs --- a/gameServer/CoreTypes.hs Tue May 04 21:30:25 2010 +0000 +++ b/gameServer/CoreTypes.hs Wed May 05 08:01:37 2010 +0000 @@ -12,6 +12,7 @@ import Network import Data.Function +import RoomsAndClients data ClientInfo = ClientInfo @@ -177,12 +178,12 @@ | ClientAccountInfo (Int, AccountInfo) | TimerAction Int -type Clients = IntMap.IntMap ClientInfo -type Rooms = IntMap.IntMap RoomInfo +type MRnC = MRoomsAndClients RoomInfo ClientInfo +type IRnC = IRoomsAndClients RoomInfo ClientInfo --type ClientsTransform = [ClientInfo] -> [ClientInfo] --type RoomsTransform = [RoomInfo] -> [RoomInfo] --type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo] --type Answer = ServerInfo -> (HandlesSelector, [String]) -type ClientsSelector = Clients -> Rooms -> [Int] +--type ClientsSelector = Clients -> Rooms -> [Int] diff -r 5543340db663 -r ead2ed20dfd4 gameServer/HWProtoLobbyState.hs --- a/gameServer/HWProtoLobbyState.hs Tue May 04 21:30:25 2010 +0000 +++ b/gameServer/HWProtoLobbyState.hs Wed May 05 08:01:37 2010 +0000 @@ -100,7 +100,7 @@ roomClientsIDs toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs - + answerFullConfig = map toAnswer (leftConfigPart ++ rightConfigPart) (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p /= "MAP") (Map.toList $ params jRoom) @@ -118,7 +118,7 @@ handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName] = handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, ""] - + handleCmd_lobby clID clients rooms ["FOLLOW", asknick] = if noSuchClient || roomID followClient == 0 then diff -r 5543340db663 -r ead2ed20dfd4 gameServer/NetRoutines.hs --- a/gameServer/NetRoutines.hs Tue May 04 21:30:25 2010 +0000 +++ b/gameServer/NetRoutines.hs Wed May 05 08:01:37 2010 +0000 @@ -26,7 +26,7 @@ clientHost <- sockAddr2String sockAddr currentTime <- getCurrentTime - + sendChan <- newChan let newClient = @@ -50,9 +50,6 @@ ) writeChan coreChan $ Accept newClient - - forkIO $ clientRecvLoop cHandle coreChan nextID - forkIO $ clientSendLoop cHandle coreChan sendChan nextID return () acceptLoop servSock coreChan nextID diff -r 5543340db663 -r ead2ed20dfd4 gameServer/OfficialServer/DBInteraction.hs --- a/gameServer/OfficialServer/DBInteraction.hs Tue May 04 21:30:25 2010 +0000 +++ b/gameServer/OfficialServer/DBInteraction.hs Wed May 05 08:01:37 2010 +0000 @@ -21,7 +21,7 @@ localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"] -fakeDbConnection serverInfo = do +fakeDbConnection serverInfo = forever $ do q <- readChan $ dbQueries serverInfo case q of CheckAccount clUid _ clHost -> do @@ -30,8 +30,6 @@ ClearCache -> return () SendStats {} -> return () - fakeDbConnection serverInfo - #if defined(OFFICIAL_SERVER) pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = diff -r 5543340db663 -r ead2ed20dfd4 gameServer/RoomsAndClients.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/RoomsAndClients.hs Wed May 05 08:01:37 2010 +0000 @@ -0,0 +1,156 @@ +module RoomsAndClients( + RoomIndex(), + ClientIndex(), + MRoomsAndClients(), + IRoomsAndClients(), + newRoomsAndClients, + addRoom, + addClient, + removeRoom, + removeClient, + lobbyId, + moveClientToLobby, + moveClientToRoom, + clientRoom, + client, + allClients, + withRoomsAndClients, + showRooms + ) where + + +import Store +import Control.Monad + + +data Room r = Room { + roomClients' :: [ClientIndex], + room' :: r + } + + +data Client c = Client { + clientRoom' :: RoomIndex, + client' :: c + } + + +newtype RoomIndex = RoomIndex ElemIndex + deriving (Eq) +newtype ClientIndex = ClientIndex ElemIndex + deriving (Eq) + +instance Show RoomIndex where + show (RoomIndex i) = 'r' : show i +instance Show ClientIndex where + show (ClientIndex i) = 'c' : show i + +unRoomIndex :: RoomIndex -> ElemIndex +unRoomIndex (RoomIndex r) = r + +unClientIndex :: ClientIndex -> ElemIndex +unClientIndex (ClientIndex c) = c + + +newtype MRoomsAndClients r c = MRoomsAndClients (MStore (Room r), MStore (Client c)) +newtype IRoomsAndClients r c = IRoomsAndClients (IStore (Room r), IStore (Client c)) + + +lobbyId :: RoomIndex +lobbyId = RoomIndex firstIndex + + +newRoomsAndClients :: r -> IO (MRoomsAndClients r c) +newRoomsAndClients r = do + rooms <- newStore + clients <- newStore + let rnc = MRoomsAndClients (rooms, clients) + ri <- addRoom rnc r + when (ri /= lobbyId) $ error "Empty struct inserts not at firstIndex index" + return rnc + + +roomAddClient :: ClientIndex -> Room r -> Room r +roomAddClient cl room = room{roomClients' = cl : roomClients' room} + +roomRemoveClient :: ClientIndex -> Room r -> Room r +roomRemoveClient cl room = room{roomClients' = filter (/= cl) $ roomClients' room} + + +addRoom :: MRoomsAndClients r c -> r -> IO RoomIndex +addRoom (MRoomsAndClients (rooms, _)) room = do + i <- addElem rooms (Room [] room) + return $ RoomIndex i + + +addClient :: MRoomsAndClients r c -> c -> IO ClientIndex +addClient (MRoomsAndClients (rooms, clients)) client = do + i <- addElem clients (Client lobbyId client) + modifyElem rooms (roomAddClient (ClientIndex i)) rid + return $ ClientIndex i + where + rid = (\(RoomIndex i) -> i) lobbyId + +removeRoom :: MRoomsAndClients r c -> RoomIndex -> IO () +removeRoom rnc@(MRoomsAndClients (rooms, _)) room@(RoomIndex ri) + | room == lobbyId = error "Cannot delete lobby" + | otherwise = do + clIds <- liftM roomClients' $ readElem rooms ri + forM_ clIds (moveClientToLobby rnc) + removeElem rooms ri + + +removeClient :: MRoomsAndClients r c -> ClientIndex -> IO () +removeClient (MRoomsAndClients (rooms, clients)) cl@(ClientIndex ci) = do + RoomIndex ri <- liftM clientRoom' $ readElem clients ci + modifyElem rooms (roomRemoveClient cl) ri + removeElem clients ci + + +moveClientInRooms :: MRoomsAndClients r c -> RoomIndex -> RoomIndex -> ClientIndex -> IO () +moveClientInRooms (MRoomsAndClients (rooms, clients)) (RoomIndex riFrom) rt@(RoomIndex riTo) cl@(ClientIndex ci) = do + modifyElem rooms (roomRemoveClient cl) riFrom + modifyElem rooms (roomAddClient cl) riTo + modifyElem clients (\c -> c{clientRoom' = rt}) ci + + +moveClientToLobby :: MRoomsAndClients r c -> ClientIndex -> IO () +moveClientToLobby rnc ci = do + room <- clientRoomM rnc ci + moveClientInRooms rnc room lobbyId ci + + +moveClientToRoom :: MRoomsAndClients r c -> RoomIndex -> ClientIndex -> IO () +moveClientToRoom rnc ri ci = moveClientInRooms rnc lobbyId ri ci + + +clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex +clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci) + + +withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a +withRoomsAndClients (MRoomsAndClients (rooms, clients)) f = + withIStore2 rooms clients (\r c -> f $ IRoomsAndClients (r, c)) + +---------------------------------------- +----------- IRoomsAndClients ----------- + +showRooms :: (Show r, Show c) => IRoomsAndClients r c -> String +showRooms rnc@(IRoomsAndClients (rooms, clients)) = concatMap showRoom (allRooms rnc) + where + showRoom r = unlines $ ((show r) ++ ": " ++ (show $ room' $ rooms ! (unRoomIndex r))) : (map showClient (roomClients' $ rooms ! (unRoomIndex r))) + showClient c = " " ++ (show c) ++ ": " ++ (show $ client' $ clients ! (unClientIndex c)) + + +allRooms :: IRoomsAndClients r c -> [RoomIndex] +allRooms (IRoomsAndClients (rooms, _)) = map RoomIndex $ indices rooms + +allClients :: IRoomsAndClients r c -> [ClientIndex] +allClients (IRoomsAndClients (_, clients)) = map ClientIndex $ indices clients + + +clientRoom :: ClientIndex -> IRoomsAndClients r c -> RoomIndex +clientRoom (ClientIndex ci) (IRoomsAndClients (_, clients)) = clientRoom' (clients ! ci) + +client :: IRoomsAndClients r c -> ClientIndex -> c +client (IRoomsAndClients (_, clients)) (ClientIndex ci) = client' (clients ! ci) diff -r 5543340db663 -r ead2ed20dfd4 gameServer/ServerCore.hs --- a/gameServer/ServerCore.hs Tue May 04 21:30:25 2010 +0000 +++ b/gameServer/ServerCore.hs Wed May 05 08:01:37 2010 +0000 @@ -2,7 +2,6 @@ import Network import Control.Concurrent -import Control.Concurrent.STM import Control.Concurrent.Chan import Control.Monad import qualified Data.IntMap as IntMap @@ -10,7 +9,6 @@ -------------------------------------- import CoreTypes import NetRoutines -import Utils import HWProtoCore import Actions import OfficialServer.DBInteraction @@ -28,7 +26,7 @@ mainLoop :: ServerInfo -> Clients -> Rooms -> IO () mainLoop serverInfo clients rooms = do r <- readChan $ coreChan serverInfo - + (newServerInfo, mClients, mRooms) <- case r of Accept ci -> @@ -59,11 +57,6 @@ foldM processAction (0, serverInfo, clients, rooms) $ PingAll : [StatsAction | even tick] - - {- let hadRooms = (not $ null rooms) && (null mrooms) - in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ - mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} - mainLoop newServerInfo mClients mRooms startServer :: ServerInfo -> Socket -> IO () @@ -84,4 +77,4 @@ forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom) - forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" \ No newline at end of file + forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" diff -r 5543340db663 -r ead2ed20dfd4 gameServer/Store.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/Store.hs Wed May 05 08:01:37 2010 +0000 @@ -0,0 +1,122 @@ +module Store( + ElemIndex(), + MStore(), + IStore(), + newStore, + addElem, + removeElem, + readElem, + writeElem, + modifyElem, + firstIndex, + withIStore, + withIStore2, + (!), + indices + ) where + +import qualified Data.Array.IArray as IA +import qualified Data.Array.IO as IOA +import qualified Data.IntSet as IntSet +import Data.IORef +import Control.Monad + + +newtype ElemIndex = ElemIndex Int + deriving (Eq) +newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e)) +newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e) + +instance Show ElemIndex where + show (ElemIndex i) = 'i' : show i + +firstIndex :: ElemIndex +firstIndex = ElemIndex 0 + +-- MStore code +initialSize :: Int +initialSize = 10 + + +growFunc :: Int -> Int +growFunc a = a * 3 `div` 2 + + +newStore :: IO (MStore e) +newStore = do + newar <- IOA.newArray_ (0, initialSize - 1) + new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar) + return (MStore new) + + +growStore :: MStore e -> IO () +growStore (MStore ref) = do + (busyElems, freeElems, arr) <- readIORef ref + (_, m') <- IOA.getBounds arr + let newM' = growFunc (m' + 1) - 1 + newArr <- IOA.newArray_ (0, newM') + sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']] + writeIORef ref (busyElems, freeElems `IntSet.union` (IntSet.fromAscList [m'+1..newM']), newArr) + + +growIfNeeded :: MStore e -> IO () +growIfNeeded m@(MStore ref) = do + (_, freeElems, _) <- readIORef ref + when (IntSet.null freeElems) $ growStore m + + +addElem :: MStore e -> e -> IO ElemIndex +addElem m@(MStore ref) element = do + growIfNeeded m + (busyElems, freeElems, arr) <- readIORef ref + let (n, freeElems') = IntSet.deleteFindMin freeElems + IOA.writeArray arr n element + writeIORef ref (IntSet.insert n busyElems, freeElems', arr) + return $ ElemIndex n + + +removeElem :: MStore e -> ElemIndex -> IO () +removeElem (MStore ref) (ElemIndex n) = do + (busyElems, freeElems, arr) <- readIORef ref + IOA.writeArray arr n undefined + writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr) + + +readElem :: MStore e -> ElemIndex -> IO e +readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n + + +writeElem :: MStore e -> ElemIndex -> e -> IO () +writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el + + +modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO () +modifyElem (MStore ref) f (ElemIndex n) = do + (_, _, arr) <- readIORef ref + IOA.readArray arr n >>= (IOA.writeArray arr n) . f + + +-- A way to use see MStore elements in pure code via IStore +m2i :: MStore e -> IO (IStore e) +m2i (MStore ref) = do + (a, _, c') <- readIORef ref + c <- IOA.unsafeFreeze c' + return $ IStore (a, c) + +withIStore :: MStore e -> (IStore e -> a) -> IO a +withIStore m f = liftM f (m2i m) + + +withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a +withIStore2 m1 m2 f = do + i1 <- m2i m1 + i2 <- m2i m2 + return $ f i1 i2 + + +-- IStore code +(!) :: IStore e -> ElemIndex -> e +(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i + +indices :: IStore e -> [ElemIndex] +indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy diff -r 5543340db663 -r ead2ed20dfd4 gameServer/hedgewars-server.hs --- a/gameServer/hedgewars-server.hs Tue May 04 21:30:25 2010 +0000 +++ b/gameServer/hedgewars-server.hs Wed May 05 08:01:37 2010 +0000 @@ -2,8 +2,7 @@ module Main where -import Network.Socket -import qualified Network +import Network import Control.Concurrent.STM import Control.Concurrent.Chan #if defined(NEW_EXCEPTIONS) @@ -15,9 +14,7 @@ ----------------------------------- import Opts import CoreTypes -import OfficialServer.DBInteraction import ServerCore -import Utils #if !defined(mingw32_HOST_OS) @@ -27,7 +24,7 @@ setupLoggers = updateGlobalLogger "Clients" - (setLevel INFO) + (setLevel DEBUG) main = withSocketsDo $ do #if !defined(mingw32_HOST_OS) @@ -37,10 +34,10 @@ setupLoggers - stats <- atomically $ newTMVar (StatisticsInfo 0 0) + stats' <- atomically $ newTMVar (StatisticsInfo 0 0) dbQueriesChan <- newChan - coreChan <- newChan - serverInfo' <- getOpts $ newServerInfo stats coreChan dbQueriesChan + coreChan' <- newChan + serverInfo' <- getOpts $ newServerInfo stats' coreChan' dbQueriesChan #if defined(OFFICIAL_SERVER) dbHost' <- askFromConsole "DB host: " diff -r 5543340db663 -r ead2ed20dfd4 gameServer/stresstest.hs --- a/gameServer/stresstest.hs Tue May 04 21:30:25 2010 +0000 +++ b/gameServer/stresstest.hs Wed May 05 08:01:37 2010 +0000 @@ -6,7 +6,7 @@ import System.IO import Control.Concurrent import Network -import Control.Exception +import Control.OldException import Control.Monad import System.Random @@ -14,24 +14,24 @@ import System.Posix #endif -session1 nick room = ["NICK", nick, "", "PROTO", "24", "", "CHAT", "lobby 1", "", "CREATE", room, "", "CHAT", "room 1", "", "QUIT", "bye-bye", ""] -session2 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "bye-bye", ""] -session3 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT", "room 2", "", "QUIT", "bye-bye", ""] +session1 nick room = ["NICK", nick, "", "PROTO", "32", "", "PING", "", "CHAT", "lobby 1", "", "CREATE_ROOM", room, "", "CHAT", "room 1", "", "QUIT", "creator", ""] +session2 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROOM", room, "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "part-quit", ""] +session3 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROON", room, "", "CHAT", "room 2", "", "QUIT", "quit", ""] emulateSession sock s = do - mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (50000::Int, 90000) >>= threadDelay) s + mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (300000::Int, 590000) >>= threadDelay) s hFlush sock threadDelay 225000 -testing = Control.Exception.handle print $ do +testing = Control.OldException.handle print $ do putStrLn "Start" sock <- connectTo "127.0.0.1" (PortNumber 46631) num1 <- randomRIO (70000::Int, 70100) num2 <- randomRIO (0::Int, 2) num3 <- randomRIO (0::Int, 5) - let nick1 = show num1 - let room1 = show num2 + let nick1 = 'n' : show num1 + let room1 = 'r' : show num2 case num2 of 0 -> emulateSession sock $ session1 nick1 room1 1 -> emulateSession sock $ session2 nick1 room1 @@ -40,7 +40,7 @@ putStrLn "Finish" forks = forever $ do - delay <- randomRIO (10000::Int, 19000) + delay <- randomRIO (300000::Int, 590000) threadDelay delay forkIO testing