--- 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)
+
--- 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
--- 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
--- /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)
--- /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
--- 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: "
--- 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
--- 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
--- /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