# HG changeset patch # User unc0rr # Date 1296670992 -10800 # Node ID 7842d085acf40a6629b3c9f997e10bd095defc3a # Parent 0eab727d47176b12cd6b25533eb99b9c45f5d381 Fix merge :D diff -r 0eab727d4717 -r 7842d085acf4 gameServer/Actions.hs --- a/gameServer/Actions.hs Wed Feb 02 11:28:38 2011 +0300 +++ b/gameServer/Actions.hs Wed Feb 02 21:23:12 2011 +0300 @@ -1,414 +1,414 @@ -{-# LANGUAGE OverloadedStrings #-} -module Actions where - -import Control.Concurrent -import Control.Concurrent.Chan -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 Data.Time -import Data.Maybe -import Control.Monad.Reader -import Control.Monad.State.Strict -import qualified Data.ByteString.Char8 as B -import Control.DeepSeq ------------------------------ -import CoreTypes -import Utils -import ClientIO -import ServerState - -data Action = - AnswerClients ![ClientChan] ![B.ByteString] - | SendServerMessage - | SendServerVars - | MoveToRoom RoomIndex - | MoveToLobby B.ByteString - | RemoveTeam B.ByteString - | RemoveRoom - | UnreadyRoomClients - | JoinLobby - | ProtocolError B.ByteString - | Warning B.ByteString - | NoticeMessage Notice - | ByeClient B.ByteString - | KickClient ClientIndex - | KickRoomClient ClientIndex - | BanClient B.ByteString - | ChangeMaster - | RemoveClientTeams ClientIndex - | ModifyClient (ClientInfo -> ClientInfo) - | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo) - | ModifyRoom (RoomInfo -> RoomInfo) - | ModifyServerInfo (ServerInfo -> ServerInfo) - | AddRoom B.ByteString B.ByteString - | CheckRegistered - | ClearAccountsCache - | ProcessAccountInfo AccountInfo - | AddClient ClientInfo - | DeleteClient ClientIndex - | PingAll - | StatsAction - -type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] - -instance NFData Action where - rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` () - rnf a = a `seq` () - -instance NFData B.ByteString -instance NFData (Chan a) - -othersChans = do - cl <- client's id - ri <- clientRoomA - liftM (map sendChan . filter (/= cl)) $ roomClientsS ri - -processAction :: Action -> StateT ServerState IO () - - -processAction (AnswerClients chans msg) = do - io $ mapM_ (flip writeChan (msg `deepseq` msg)) (chans `deepseq` chans) - - -processAction SendServerMessage = do - chan <- client's sendChan - protonum <- client's clientProto - si <- liftM serverInfo get - let message = if protonum < latestReleaseVersion si then - serverMessageForOldVersions si - else - serverMessage si - processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message] - - -processAction SendServerVars = do - chan <- client's sendChan - si <- gets serverInfo - io $ writeChan chan ("SERVER_VARS" : vars si) - where - vars si = [ - "MOTD_NEW", serverMessage si, - "MOTD_OLD", serverMessageForOldVersions si, - "LATEST_PROTO", B.pack . show $ latestReleaseVersion si - ] - - -processAction (ProtocolError msg) = do - chan <- client's sendChan - processAction $ AnswerClients [chan] ["ERROR", msg] - - -processAction (Warning msg) = do - chan <- client's sendChan - processAction $ AnswerClients [chan] ["WARNING", msg] - -processAction (NoticeMessage n) = do - chan <- client's sendChan - processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n] - -processAction (ByeClient msg) = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - ri <- clientRoomA - - chan <- client's sendChan - clNick <- client's nick - - when (ri /= lobbyId) $ do - processAction $ MoveToLobby ("quit: " `B.append` msg) - return () - - clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS - io $ do - infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg)) - - processAction $ AnswerClients [chan] ["BYE", msg] - processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg] - - s <- get - put $! s{removedClients = ci `Set.insert` removedClients s} - -processAction (DeleteClient ci) = do - rnc <- gets roomsClients - io $ removeClient rnc ci - - s <- get - put $! s{removedClients = ci `Set.delete` removedClients s} - -processAction (ModifyClient f) = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - io $ modifyClient rnc f ci - return () - -processAction (ModifyClient2 ci f) = do - rnc <- gets roomsClients - io $ modifyClient rnc f ci - return () - - -processAction (ModifyRoom f) = do - rnc <- gets roomsClients - ri <- clientRoomA - io $ modifyRoom rnc f ri - return () - - -processAction (ModifyServerInfo f) = - modify (\s -> s{serverInfo = f $ serverInfo s}) - - -processAction (MoveToRoom ri) = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - - io $ do - modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci - modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri - moveClientToRoom rnc ri ci - - chans <- liftM (map sendChan) $ roomClientsS ri - clNick <- client's nick - - processAction $ AnswerClients chans ["JOINED", clNick] - - -processAction (MoveToLobby msg) = do - (Just ci) <- gets clientIndex - ri <- clientRoomA - rnc <- gets roomsClients - (gameProgress, playersNum) <- io $ room'sM rnc (\r -> (gameinprogress r, playersIn r)) ri - ready <- client's isReady - master <- client's isMaster --- client <- client's id - clNick <- client's nick - chans <- othersChans - - if master then - if gameProgress && playersNum > 1 then - mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci] - else - processAction RemoveRoom - else - mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci] - - io $ do - modifyRoom rnc (\r -> r{ - playersIn = (playersIn r) - 1, - readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r - }) ri - moveClientToLobby rnc ci - -processAction ChangeMaster = do - ri <- clientRoomA - rnc <- gets roomsClients - newMasterId <- liftM head . io $ roomClientsIndicesM rnc ri - newMaster <- io $ client'sM rnc id newMasterId - let newRoomName = nick newMaster - mapM_ processAction [ - ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}), - ModifyClient2 newMasterId (\c -> c{isMaster = True}), - AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"] - ] - -processAction (AddRoom roomName roomPassword) = do - Just clId <- gets clientIndex - rnc <- gets roomsClients - proto <- io $ client'sM rnc clientProto clId - - let room = newRoom{ - masterID = clId, - name = roomName, - password = roomPassword, - roomProto = proto - } - - rId <- io $ addRoom rnc room - - processAction $ MoveToRoom rId - - chans <- liftM (map sendChan) $! roomClientsS lobbyId - - mapM_ processAction [ - AnswerClients chans ["ROOM", "ADD", roomName] - , ModifyClient (\cl -> cl{isMaster = True}) - ] - - -processAction RemoveRoom = do - Just clId <- gets clientIndex - rnc <- gets roomsClients - ri <- io $ clientRoomM rnc clId - roomName <- io $ room'sM rnc name ri - others <- othersChans - lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId - - mapM_ processAction [ - AnswerClients lobbyChans ["ROOM", "DEL", roomName], - AnswerClients others ["ROOMABANDONED", roomName] - ] - - io $ removeRoom rnc ri - - -processAction (UnreadyRoomClients) = do - rnc <- gets roomsClients - ri <- clientRoomA - roomPlayers <- roomClientsS ri - roomClIDs <- io $ roomClientsIndicesM rnc ri - processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers) - io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs - processAction $ ModifyRoom (\r -> r{readyPlayers = 0}) - - -processAction (RemoveTeam teamName) = do - rnc <- gets roomsClients - cl <- client's id - ri <- clientRoomA - inGame <- io $ room'sM rnc gameinprogress ri - chans <- othersChans - if inGame then - mapM_ processAction [ - AnswerClients chans ["REMOVE_TEAM", teamName], - ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) - ] - 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 - }) - ] - where - rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName - - -processAction (RemoveClientTeams clId) = do - rnc <- gets roomsClients - - removeTeamActions <- io $ do - clNick <- client'sM rnc nick clId - rId <- clientRoomM rnc clId - roomTeams <- room'sM rnc teams rId - return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams - - mapM_ processAction removeTeamActions - - - -processAction CheckRegistered = do - (Just ci) <- gets clientIndex - n <- client's nick - h <- client's host - db <- gets (dbQueries . serverInfo) - io $ writeChan db $ CheckAccount ci n h - return () - - -processAction ClearAccountsCache = do - dbq <- gets (dbQueries . serverInfo) - io $ writeChan dbq ClearCache - return () - - -processAction (ProcessAccountInfo info) = - case info of - HasAccount passwd isAdmin -> do - chan <- client's sendChan - processAction $ AnswerClients [chan] ["ASKPASSWORD"] - Guest -> do - processAction JoinLobby - Admin -> do - mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] - chan <- client's sendChan - processAction $ AnswerClients [chan] ["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, 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 - 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") - - -processAction (clID, serverInfo, rnc) (BanClient banNick) = - return (clID, serverInfo, rnc) - - -processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do - writeChan (sendChan $ clients ! kickID) ["KICKED"] - liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked") - --} - -processAction (AddClient client) = do - rnc <- gets roomsClients - si <- gets serverInfo - io $ do - ci <- addClient rnc client - t <- forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci - forkIO $ clientSendLoop (clientSocket client) t (coreChan si) (sendChan client) ci - - 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 - - if False && (isJust $ host client `Prelude.lookup` newLogins) then - processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast" - else - return (ci, serverInfo) --} - - - -processAction PingAll = do - rnc <- gets roomsClients - io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) - cis <- io $ allClientsM rnc - chans <- io $ mapM (client'sM rnc sendChan) cis - io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis - processAction $ AnswerClients chans ["PING"] - where - kickTimeouted rnc ci = do - pq <- io $ client'sM rnc pingsQueue ci - when (pq > 0) $ - withStateT (\as -> as{clientIndex = Just ci}) $ - processAction (ByeClient "Ping timeout") - - -processAction (StatsAction) = do - rnc <- gets roomsClients - si <- gets serverInfo - (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc stats - io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1) - where - stats irnc = (length $ allRooms irnc, length $ allClients irnc) - +{-# LANGUAGE OverloadedStrings #-} +module Actions where + +import Control.Concurrent +import Control.Concurrent.Chan +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 Data.Time +import Data.Maybe +import Control.Monad.Reader +import Control.Monad.State.Strict +import qualified Data.ByteString.Char8 as B +import Control.DeepSeq +----------------------------- +import CoreTypes +import Utils +import ClientIO +import ServerState + +data Action = + AnswerClients ![ClientChan] ![B.ByteString] + | SendServerMessage + | SendServerVars + | MoveToRoom RoomIndex + | MoveToLobby B.ByteString + | RemoveTeam B.ByteString + | RemoveRoom + | UnreadyRoomClients + | JoinLobby + | ProtocolError B.ByteString + | Warning B.ByteString + | NoticeMessage Notice + | ByeClient B.ByteString + | KickClient ClientIndex + | KickRoomClient ClientIndex + | BanClient B.ByteString + | ChangeMaster + | RemoveClientTeams ClientIndex + | ModifyClient (ClientInfo -> ClientInfo) + | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo) + | ModifyRoom (RoomInfo -> RoomInfo) + | ModifyServerInfo (ServerInfo -> ServerInfo) + | AddRoom B.ByteString B.ByteString + | CheckRegistered + | ClearAccountsCache + | ProcessAccountInfo AccountInfo + | AddClient ClientInfo + | DeleteClient ClientIndex + | PingAll + | StatsAction + +type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] + +instance NFData Action where + rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` () + rnf a = a `seq` () + +instance NFData B.ByteString +instance NFData (Chan a) + +othersChans = do + cl <- client's id + ri <- clientRoomA + liftM (map sendChan . filter (/= cl)) $ roomClientsS ri + +processAction :: Action -> StateT ServerState IO () + + +processAction (AnswerClients chans msg) = do + io $ mapM_ (flip writeChan (msg `deepseq` msg)) (chans `deepseq` chans) + + +processAction SendServerMessage = do + chan <- client's sendChan + protonum <- client's clientProto + si <- liftM serverInfo get + let message = if protonum < latestReleaseVersion si then + serverMessageForOldVersions si + else + serverMessage si + processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message] + + +processAction SendServerVars = do + chan <- client's sendChan + si <- gets serverInfo + io $ writeChan chan ("SERVER_VARS" : vars si) + where + vars si = [ + "MOTD_NEW", serverMessage si, + "MOTD_OLD", serverMessageForOldVersions si, + "LATEST_PROTO", B.pack . show $ latestReleaseVersion si + ] + + +processAction (ProtocolError msg) = do + chan <- client's sendChan + processAction $ AnswerClients [chan] ["ERROR", msg] + + +processAction (Warning msg) = do + chan <- client's sendChan + processAction $ AnswerClients [chan] ["WARNING", msg] + +processAction (NoticeMessage n) = do + chan <- client's sendChan + processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n] + +processAction (ByeClient msg) = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + ri <- clientRoomA + + chan <- client's sendChan + clNick <- client's nick + + when (ri /= lobbyId) $ do + processAction $ MoveToLobby ("quit: " `B.append` msg) + return () + + clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS + io $ do + infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg)) + + processAction $ AnswerClients [chan] ["BYE", msg] + processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg] + + s <- get + put $! s{removedClients = ci `Set.insert` removedClients s} + +processAction (DeleteClient ci) = do + rnc <- gets roomsClients + io $ removeClient rnc ci + + s <- get + put $! s{removedClients = ci `Set.delete` removedClients s} + +processAction (ModifyClient f) = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + io $ modifyClient rnc f ci + return () + +processAction (ModifyClient2 ci f) = do + rnc <- gets roomsClients + io $ modifyClient rnc f ci + return () + + +processAction (ModifyRoom f) = do + rnc <- gets roomsClients + ri <- clientRoomA + io $ modifyRoom rnc f ri + return () + + +processAction (ModifyServerInfo f) = + modify (\s -> s{serverInfo = f $ serverInfo s}) + + +processAction (MoveToRoom ri) = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + + io $ do + modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci + modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri + moveClientToRoom rnc ri ci + + chans <- liftM (map sendChan) $ roomClientsS ri + clNick <- client's nick + + processAction $ AnswerClients chans ["JOINED", clNick] + + +processAction (MoveToLobby msg) = do + (Just ci) <- gets clientIndex + ri <- clientRoomA + rnc <- gets roomsClients + (gameProgress, playersNum) <- io $ room'sM rnc (\r -> (gameinprogress r, playersIn r)) ri + ready <- client's isReady + master <- client's isMaster +-- client <- client's id + clNick <- client's nick + chans <- othersChans + + if master then + if gameProgress && playersNum > 1 then + mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci] + else + processAction RemoveRoom + else + mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci] + + io $ do + modifyRoom rnc (\r -> r{ + playersIn = (playersIn r) - 1, + readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r + }) ri + moveClientToLobby rnc ci + +processAction ChangeMaster = do + ri <- clientRoomA + rnc <- gets roomsClients + newMasterId <- liftM head . io $ roomClientsIndicesM rnc ri + newMaster <- io $ client'sM rnc id newMasterId + let newRoomName = nick newMaster + mapM_ processAction [ + ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}), + ModifyClient2 newMasterId (\c -> c{isMaster = True}), + AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"] + ] + +processAction (AddRoom roomName roomPassword) = do + Just clId <- gets clientIndex + rnc <- gets roomsClients + proto <- io $ client'sM rnc clientProto clId + + let room = newRoom{ + masterID = clId, + name = roomName, + password = roomPassword, + roomProto = proto + } + + rId <- io $ addRoom rnc room + + processAction $ MoveToRoom rId + + chans <- liftM (map sendChan) $! roomClientsS lobbyId + + mapM_ processAction [ + AnswerClients chans ["ROOM", "ADD", roomName] + , ModifyClient (\cl -> cl{isMaster = True}) + ] + + +processAction RemoveRoom = do + Just clId <- gets clientIndex + rnc <- gets roomsClients + ri <- io $ clientRoomM rnc clId + roomName <- io $ room'sM rnc name ri + others <- othersChans + lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId + + mapM_ processAction [ + AnswerClients lobbyChans ["ROOM", "DEL", roomName], + AnswerClients others ["ROOMABANDONED", roomName] + ] + + io $ removeRoom rnc ri + + +processAction (UnreadyRoomClients) = do + rnc <- gets roomsClients + ri <- clientRoomA + roomPlayers <- roomClientsS ri + roomClIDs <- io $ roomClientsIndicesM rnc ri + processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers) + io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs + processAction $ ModifyRoom (\r -> r{readyPlayers = 0}) + + +processAction (RemoveTeam teamName) = do + rnc <- gets roomsClients + cl <- client's id + ri <- clientRoomA + inGame <- io $ room'sM rnc gameinprogress ri + chans <- othersChans + if inGame then + mapM_ processAction [ + AnswerClients chans ["REMOVE_TEAM", teamName], + ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) + ] + 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 + }) + ] + where + rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName + + +processAction (RemoveClientTeams clId) = do + rnc <- gets roomsClients + + removeTeamActions <- io $ do + clNick <- client'sM rnc nick clId + rId <- clientRoomM rnc clId + roomTeams <- room'sM rnc teams rId + return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams + + mapM_ processAction removeTeamActions + + + +processAction CheckRegistered = do + (Just ci) <- gets clientIndex + n <- client's nick + h <- client's host + db <- gets (dbQueries . serverInfo) + io $ writeChan db $ CheckAccount ci n h + return () + + +processAction ClearAccountsCache = do + dbq <- gets (dbQueries . serverInfo) + io $ writeChan dbq ClearCache + return () + + +processAction (ProcessAccountInfo info) = + case info of + HasAccount passwd isAdmin -> do + chan <- client's sendChan + processAction $ AnswerClients [chan] ["ASKPASSWORD"] + Guest -> do + processAction JoinLobby + Admin -> do + mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] + chan <- client's sendChan + processAction $ AnswerClients [chan] ["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, 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 + 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") + + +processAction (clID, serverInfo, rnc) (BanClient banNick) = + return (clID, serverInfo, rnc) + + +processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do + writeChan (sendChan $ clients ! kickID) ["KICKED"] + liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked") + +-} + +processAction (AddClient client) = do + rnc <- gets roomsClients + si <- gets serverInfo + io $ do + ci <- addClient rnc client + t <- forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci + forkIO $ clientSendLoop (clientSocket client) t (coreChan si) (sendChan client) ci + + 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 + + if False && (isJust $ host client `Prelude.lookup` newLogins) then + processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast" + else + return (ci, serverInfo) +-} + + + +processAction PingAll = do + rnc <- gets roomsClients + io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) + cis <- io $ allClientsM rnc + chans <- io $ mapM (client'sM rnc sendChan) cis + io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis + processAction $ AnswerClients chans ["PING"] + where + kickTimeouted rnc ci = do + pq <- io $ client'sM rnc pingsQueue ci + when (pq > 0) $ + withStateT (\as -> as{clientIndex = Just ci}) $ + processAction (ByeClient "Ping timeout") + + +processAction (StatsAction) = do + rnc <- gets roomsClients + si <- gets serverInfo + (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc stats + io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1) + where + stats irnc = (length $ allRooms irnc, length $ allClients irnc) + diff -r 0eab727d4717 -r 7842d085acf4 gameServer/NetRoutines.hs --- a/gameServer/NetRoutines.hs Wed Feb 02 11:28:38 2011 +0300 +++ b/gameServer/NetRoutines.hs Wed Feb 02 21:23:12 2011 +0300 @@ -1,46 +1,41 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} module NetRoutines where -import Network import Network.Socket import System.IO -import Control.Concurrent import Control.Concurrent.Chan -import Control.Concurrent.STM import qualified Control.Exception as Exception import Data.Time +import Control.Monad ----------------------------- import CoreTypes -import ClientIO import Utils +import RoomsAndClients -acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO () -acceptLoop servSock coreChan clientCounter = do +acceptLoop :: Socket -> Chan CoreMessage -> IO () +acceptLoop servSock chan = forever $ do Exception.handle (\(_ :: Exception.IOException) -> putStrLn "exception on connect") $ do - (socket, sockAddr) <- Network.Socket.accept servSock + (sock, sockAddr) <- Network.Socket.accept servSock - cHandle <- socketToHandle socket ReadWriteMode - hSetBuffering cHandle LineBuffering clientHost <- sockAddr2String sockAddr currentTime <- getCurrentTime - - sendChan <- newChan + + sendChan' <- newChan let newClient = (ClientInfo - nextID - sendChan - cHandle + sendChan' + sock clientHost currentTime "" "" False 0 - 0 + lobbyId 0 False False @@ -49,12 +44,5 @@ undefined ) - writeChan coreChan $ Accept newClient - - forkIO $ clientRecvLoop cHandle coreChan nextID - forkIO $ clientSendLoop cHandle coreChan sendChan nextID + writeChan chan $ Accept newClient return () - - acceptLoop servSock coreChan nextID - where - nextID = clientCounter + 1 diff -r 0eab727d4717 -r 7842d085acf4 gameServer/Opts.hs --- a/gameServer/Opts.hs Wed Feb 02 11:28:38 2011 +0300 +++ b/gameServer/Opts.hs Wed Feb 02 21:23:12 2011 +0300 @@ -3,10 +3,12 @@ getOpts, ) where -import System.Environment ( getArgs ) +import System.Environment import System.Console.GetOpt import Network import Data.Maybe ( fromMaybe ) +import qualified Data.ByteString.Char8 as B + import CoreTypes import Utils @@ -30,9 +32,9 @@ where readDedicated = fromMaybe True (maybeRead str :: Maybe Bool) -readDbLogin str opts = opts{dbLogin = str} -readDbPassword str opts = opts{dbPassword = str} -readDbHost str opts = opts{dbHost = str} +readDbLogin str opts = opts{dbLogin = B.pack str} +readDbPassword str opts = opts{dbPassword = B.pack str} +readDbHost str opts = opts{dbHost = B.pack str} getOpts :: ServerInfo -> IO ServerInfo getOpts opts = do diff -r 0eab727d4717 -r 7842d085acf4 gameServer/RoomsAndClients.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/RoomsAndClients.hs Wed Feb 02 21:23:12 2011 +0300 @@ -0,0 +1,196 @@ +module RoomsAndClients( + RoomIndex(), + ClientIndex(), + MRoomsAndClients(), + IRoomsAndClients(), + newRoomsAndClients, + addRoom, + addClient, + removeRoom, + removeClient, + modifyRoom, + modifyClient, + lobbyId, + moveClientToLobby, + moveClientToRoom, + clientRoomM, + clientExists, + client, + room, + client'sM, + room'sM, + allClientsM, + clientsM, + roomClientsM, + roomClientsIndicesM, + withRoomsAndClients, + allRooms, + allClients, + clientRoom, + showRooms, + roomClients + ) 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, Show, Read, Ord) + +instance Show RoomIndex where + show (RoomIndex i) = 'r' : 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 = let cls = cl : roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr + +roomRemoveClient :: ClientIndex -> Room r -> Room r +roomRemoveClient cl room = let cls = filter (/= cl) $ roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr + + +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)) (unRoomIndex lobbyId) + return $ ClientIndex i + +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 + + +modifyRoom :: MRoomsAndClients r c -> (r -> r) -> RoomIndex -> IO () +modifyRoom (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = modifyElem rooms (\r -> r{room' = f $ room' r}) ri + +modifyClient :: MRoomsAndClients r c -> (c -> c) -> ClientIndex -> IO () +modifyClient (MRoomsAndClients (_, clients)) f (ClientIndex ci) = modifyElem clients (\c -> c{client' = f $ client' c}) 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 + + +clientExists :: MRoomsAndClients r c -> ClientIndex -> IO Bool +clientExists (MRoomsAndClients (_, clients)) (ClientIndex ci) = elemExists clients ci + +clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex +clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci) + +client'sM :: MRoomsAndClients r c -> (c -> a) -> ClientIndex -> IO a +client'sM (MRoomsAndClients (_, clients)) f (ClientIndex ci) = liftM (f . client') (clients `readElem` ci) + +room'sM :: MRoomsAndClients r c -> (r -> a) -> RoomIndex -> IO a +room'sM (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = liftM (f . room') (rooms `readElem` ri) + +allClientsM :: MRoomsAndClients r c -> IO [ClientIndex] +allClientsM (MRoomsAndClients (_, clients)) = liftM (map ClientIndex) $ indicesM clients + +clientsM :: MRoomsAndClients r c -> IO [c] +clientsM (MRoomsAndClients (_, clients)) = indicesM clients >>= mapM (\ci -> liftM client' $ readElem clients ci) + +roomClientsIndicesM :: MRoomsAndClients r c -> RoomIndex -> IO [ClientIndex] +roomClientsIndicesM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) + +roomClientsM :: MRoomsAndClients r c -> RoomIndex -> IO [c] +roomClientsM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) >>= mapM (\(ClientIndex ci) -> liftM client' $ readElem clients 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 :: IRoomsAndClients r c -> ClientIndex -> RoomIndex +clientRoom (IRoomsAndClients (_, clients)) (ClientIndex ci) = clientRoom' (clients ! ci) + +client :: IRoomsAndClients r c -> ClientIndex -> c +client (IRoomsAndClients (_, clients)) (ClientIndex ci) = client' (clients ! ci) + +room :: IRoomsAndClients r c -> RoomIndex -> r +room (IRoomsAndClients (rooms, _)) (RoomIndex ri) = room' (rooms ! ri) + +roomClients :: IRoomsAndClients r c -> RoomIndex -> [ClientIndex] +roomClients (IRoomsAndClients (rooms, _)) (RoomIndex ri) = roomClients' $ (rooms ! ri) diff -r 0eab727d4717 -r 7842d085acf4 gameServer/Store.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/Store.hs Wed Feb 02 21:23:12 2011 +0300 @@ -0,0 +1,145 @@ +module Store( + ElemIndex(), + MStore(), + IStore(), + newStore, + addElem, + removeElem, + readElem, + writeElem, + modifyElem, + elemExists, + firstIndex, + indicesM, + 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, Show, Read, Ord) +newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e)) +newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e) + + +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 (error $ "Store: no element " ++ show n) + 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 + +elemExists :: MStore e -> ElemIndex -> IO Bool +elemExists (MStore ref) (ElemIndex n) = do + (_, free, _) <- readIORef ref + return $ n `IntSet.notMember` free + +indicesM :: MStore e -> IO [ElemIndex] +indicesM (MStore ref) = do + (busy, _, _) <- readIORef ref + return $ map ElemIndex $ IntSet.toList busy + + +-- A way to 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) + +i2m :: (MStore e) -> IStore e -> IO () +i2m (MStore ref) (IStore (_, arr)) = do + (b, e, _) <- readIORef ref + a <- IOA.unsafeThaw arr + writeIORef ref (b, e, a) + +withIStore :: MStore e -> (IStore e -> a) -> IO a +withIStore m f = do + i <- m2i m + let res = f i + res `seq` i2m m i + return res + + +withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a +withIStore2 m1 m2 f = do + i1 <- m2i m1 + i2 <- m2i m2 + let res = f i1 i2 + res `seq` i2m m1 i1 + i2m m2 i2 + return res + + +-- 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 0eab727d4717 -r 7842d085acf4 gameServer/hedgewars-server.hs --- a/gameServer/hedgewars-server.hs Wed Feb 02 11:28:38 2011 +0300 +++ b/gameServer/hedgewars-server.hs Wed Feb 02 21:23:12 2011 +0300 @@ -3,22 +3,15 @@ module Main where import Network.Socket -import qualified Network import Network.BSD import Control.Concurrent.STM import Control.Concurrent.Chan -#if defined(NEW_EXCEPTIONS) -import qualified Control.OldException as Exception -#else import qualified Control.Exception as Exception -#endif import System.Log.Logger ----------------------------------- import Opts import CoreTypes -import OfficialServer.DBInteraction import ServerCore -import Utils #if !defined(mingw32_HOST_OS) @@ -26,10 +19,12 @@ #endif +setupLoggers :: IO () setupLoggers = updateGlobalLogger "Clients" (setLevel INFO) +main :: IO () main = withSocketsDo $ do #if !defined(mingw32_HOST_OS) installHandler sigPIPE Ignore Nothing; @@ -38,11 +33,11 @@ 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: " dbLogin' <- askFromConsole "login: " diff -r 0eab727d4717 -r 7842d085acf4 gameServer/stresstest.hs --- a/gameServer/stresstest.hs Wed Feb 02 11:28:38 2011 +0300 +++ b/gameServer/stresstest.hs Wed Feb 02 21:23:12 2011 +0300 @@ -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 (30000::Int, 59000) >>= 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 (30000::Int, 59000) threadDelay delay forkIO testing diff -r 0eab727d4717 -r 7842d085acf4 gameServer/stresstest2.hs --- a/gameServer/stresstest2.hs Wed Feb 02 11:28:38 2011 +0300 +++ b/gameServer/stresstest2.hs Wed Feb 02 21:23:12 2011 +0300 @@ -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,22 +14,28 @@ import System.Posix #endif -testing = Control.Exception.handle print $ do - delay <- randomRIO (100::Int, 300) - threadDelay delay +session1 nick room = ["NICK", nick, "", "PROTO", "32", ""] + + + +testing = Control.OldException.handle print $ do + putStrLn "Start" sock <- connectTo "127.0.0.1" (PortNumber 46631) - hClose sock -forks i = do - delay <- randomRIO (50::Int, 190) - if i `mod` 10 == 0 then putStr (show i) else putStr "." - hFlush stdout - threadDelay delay - forkIO testing - forks (i + 1) + num1 <- randomRIO (70000::Int, 70100) + num2 <- randomRIO (0::Int, 2) + num3 <- randomRIO (0::Int, 5) + let nick1 = 'n' : show num1 + let room1 = 'r' : show num2 + mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (300::Int, 590) >>= threadDelay) $ session1 nick1 room1 + mapM_ (\x -> hPutStrLn sock x >> hFlush sock) $ concatMap (\x -> ["CHAT_MSG", show x, ""]) [1..] + hClose sock + putStrLn "Finish" + +forks = testing main = withSocketsDo $ do #if !defined(mingw32_HOST_OS) installHandler sigPIPE Ignore Nothing; #endif - forks 1 + forks diff -r 0eab727d4717 -r 7842d085acf4 gameServer/stresstest3.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/stresstest3.hs Wed Feb 02 21:23:12 2011 +0300 @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import IO +import System.IO +import Control.Concurrent +import Network +import Control.OldException +import Control.Monad +import System.Random +import Control.Monad.State +import Data.List + +#if !defined(mingw32_HOST_OS) +import System.Posix +#endif + +type SState = Handle +io = liftIO + +readPacket :: StateT SState IO [String] +readPacket = do + h <- get + p <- io $ hGetPacket h [] + return p + where + hGetPacket h buf = do + l <- hGetLine h + if (not $ null l) then hGetPacket h (buf ++ [l]) else return buf + +waitPacket :: String -> StateT SState IO Bool +waitPacket s = do + p <- readPacket + return $ head p == s + +sendPacket :: [String] -> StateT SState IO () +sendPacket s = do + h <- get + io $ do + mapM_ (hPutStrLn h) s + hPutStrLn h "" + hFlush h + +emulateSession :: StateT SState IO () +emulateSession = do + n <- io $ randomRIO (100000::Int, 100100) + waitPacket "CONNECTED" + sendPacket ["NICK", "test" ++ (show n)] + waitPacket "NICK" + sendPacket ["PROTO", "31"] + waitPacket "PROTO" + b <- waitPacket "LOBBY:JOINED" + --io $ print b + sendPacket ["QUIT", "BYE"] + return () + +testing = Control.OldException.handle print $ do + putStr "+" + sock <- connectTo "127.0.0.1" (PortNumber 46631) + evalStateT emulateSession sock + --hClose sock + putStr "-" + hFlush stdout + +forks = forM_ [1..100] $ const $ do + delay <- randomRIO (10000::Int, 30000) + threadDelay delay + forkIO testing + +main = withSocketsDo $ do +#if !defined(mingw32_HOST_OS) + installHandler sigPIPE Ignore Nothing; +#endif + forks