Some screwing around in try to fix space leak. No luck yet.
--- a/gameServer/Actions.hs Sun Oct 10 12:53:16 2010 -0400
+++ b/gameServer/Actions.hs Sun Oct 10 21:32:18 2010 +0400
@@ -98,30 +98,35 @@
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
ri <- clientRoomA
- when (ri /= lobbyId) $ do
- processAction $ MoveToLobby ("quit: " `B.append` msg)
- return ()
chan <- client's sendChan
ready <- client's isReady
+ when (ri /= lobbyId) $ do
+ processAction $ MoveToLobby ("quit: " `B.append` msg)
+ liftIO $ modifyRoom rnc (\r -> r{
+ --playersIDs = IntSet.delete ci (playersIDs r)
+ playersIn = (playersIn r) - 1,
+ readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
+ }) ri
+ return ()
+
liftIO $ do
infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg))
--mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
- modifyRoom rnc (\r -> r{
- --playersIDs = IntSet.delete ci (playersIDs r)
- playersIn = (playersIn r) - 1,
- readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
- }) ri
processAction $ AnswerClients [chan] ["BYE", msg]
- modify (\s -> s{removedClients = ci `Set.insert` removedClients s})
+
+ s <- get
+ put $! s{removedClients = ci `Set.insert` removedClients s}
processAction (DeleteClient ci) = do
rnc <- gets roomsClients
liftIO $ removeClient rnc ci
- modify (\s -> s{removedClients = ci `Set.delete` removedClients s})
+
+ s <- get
+ put $! s{removedClients = ci `Set.delete` removedClients s}
{-
where
@@ -256,7 +261,7 @@
processAction $ MoveToRoom rId
- chans <- liftM (map sendChan) $ roomClientsS lobbyId
+ chans <- liftM (map sendChan) $! roomClientsS lobbyId
mapM_ processAction [
AnswerClients chans ["ROOM", "ADD", roomName]
@@ -399,7 +404,7 @@
liftIO $ do
ci <- addClient rnc client
forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci
- forkIO $ clientSendLoop (clientSocket client) (coreChan si) (sendChan client) ci
+ forkIO $ clientSendLoop (clientSocket client) (sendChan client) ci
infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client))
--- a/gameServer/ClientIO.hs Sun Oct 10 12:53:16 2010 -0400
+++ b/gameServer/ClientIO.hs Sun Oct 10 21:32:18 2010 +0400
@@ -57,8 +57,8 @@
-clientSendLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO()
-clientSendLoop s coreChan chan ci = do
+clientSendLoop :: Socket -> Chan [B.ByteString] -> ClientIndex -> IO ()
+clientSendLoop s chan ci = do
answer <- readChan chan
Exception.handle
(\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do
@@ -67,7 +67,7 @@
if (isQuit answer) then
Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s
else
- clientSendLoop s coreChan chan ci
+ clientSendLoop s chan ci
where
--sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e])
--- a/gameServer/CoreTypes.hs Sun Oct 10 12:53:16 2010 -0400
+++ b/gameServer/CoreTypes.hs Sun Oct 10 21:32:18 2010 +0400
@@ -78,7 +78,6 @@
gameinprogress :: Bool,
playersIn :: !Int,
readyPlayers :: !Int,
- playersIDs :: IntSet.IntSet,
isRestrictedJoins :: Bool,
isRestrictedTeams :: Bool,
roundMsgs :: Seq B.ByteString,
@@ -88,8 +87,7 @@
}
instance Show RoomInfo where
- show ri = ", players ids: " ++ show (IntSet.size $ playersIDs ri)
- ++ ", players: " ++ show (playersIn ri)
+ show ri = ", players: " ++ show (playersIn ri)
++ ", ready: " ++ show (readyPlayers ri)
++ ", teams: " ++ show (teams ri)
@@ -104,7 +102,6 @@
False
0
0
- IntSet.empty
False
False
Data.Sequence.empty
--- a/gameServer/RoomsAndClients.hs Sun Oct 10 12:53:16 2010 -0400
+++ b/gameServer/RoomsAndClients.hs Sun Oct 10 21:32:18 2010 +0400
@@ -82,10 +82,10 @@
roomAddClient :: ClientIndex -> Room r -> Room r
-roomAddClient cl room = room{roomClients' = cl : roomClients' room}
+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 = room{roomClients' = filter (/= cl) $ roomClients' room}
+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
--- a/gameServer/ServerCore.hs Sun Oct 10 12:53:16 2010 -0400
+++ b/gameServer/ServerCore.hs Sun Oct 10 21:32:18 2010 +0400
@@ -32,10 +32,11 @@
mainLoop :: StateT ServerState IO ()
mainLoop = forever $ do
+ get >>= \s -> put $! s
+
si <- gets serverInfo
r <- liftIO $ readChan $ coreChan si
- liftIO $ putStrLn $ "Core msg: " ++ show r
case r of
Accept ci -> processAction (AddClient ci)
@@ -44,7 +45,8 @@
removed <- gets removedClients
when (not $ ci `Set.member` removed) $ do
- modify (\as -> as{clientIndex = Just ci})
+ as <- get
+ put $! as{clientIndex = Just ci}
reactCmd cmd
Remove ci -> do
@@ -60,7 +62,8 @@
rnc <- gets roomsClients
exists <- liftIO $ clientExists rnc ci
when (exists) $ do
- modify (\as -> as{clientIndex = Just ci})
+ as <- get
+ put $! as{clientIndex = Just ci}
processAction (ProcessAccountInfo info)
return ()
--- a/gameServer/hedgewars-server.hs Sun Oct 10 12:53:16 2010 -0400
+++ b/gameServer/hedgewars-server.hs Sun Oct 10 21:32:18 2010 +0400
@@ -21,7 +21,7 @@
setupLoggers :: IO ()
setupLoggers =
updateGlobalLogger "Clients"
- (setLevel DEBUG)
+ (setLevel INFO)
main :: IO ()
main = withSocketsDo $ do
--- a/gameServer/stresstest.hs Sun Oct 10 12:53:16 2010 -0400
+++ b/gameServer/stresstest.hs Sun Oct 10 21:32:18 2010 +0400
@@ -19,7 +19,7 @@
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 (300000::Int, 590000) >>= threadDelay) s
+ mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (30000::Int, 59000) >>= threadDelay) s
hFlush sock
threadDelay 225000
@@ -40,7 +40,7 @@
putStrLn "Finish"
forks = forever $ do
- delay <- randomRIO (300000::Int, 590000)
+ delay <- randomRIO (30000::Int, 59000)
threadDelay delay
forkIO testing
--- a/gameServer/stresstest2.hs Sun Oct 10 12:53:16 2010 -0400
+++ b/gameServer/stresstest2.hs Sun Oct 10 21:32:18 2010 +0400
@@ -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
--- a/gameServer/stresstest3.hs Sun Oct 10 12:53:16 2010 -0400
+++ b/gameServer/stresstest3.hs Sun Oct 10 21:32:18 2010 +0400
@@ -52,6 +52,7 @@
waitPacket "PROTO"
b <- waitPacket "LOBBY:JOINED"
--io $ print b
+ sendPacket ["QUIT", "BYE"]
return ()
testing = Control.OldException.handle print $ do
@@ -62,7 +63,7 @@
putStr "-"
hFlush stdout
-forks = forever $ do
+forks = forM_ [1..100] $ const $ do
delay <- randomRIO (10000::Int, 30000)
threadDelay delay
forkIO testing