# HG changeset patch
# User unc0rr
# Date 1286731938 -14400
# Node ID 709fdb89f76c23836a019863b2dc4e2ee4821d9b
# Parent  41e06b74c991b2f9a71bd365c92bd332138f2c67
Some screwing around in try to fix space leak. No luck yet.

diff -r 41e06b74c991 -r 709fdb89f76c gameServer/Actions.hs
--- 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))
 
diff -r 41e06b74c991 -r 709fdb89f76c gameServer/ClientIO.hs
--- 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])
diff -r 41e06b74c991 -r 709fdb89f76c gameServer/CoreTypes.hs
--- 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
diff -r 41e06b74c991 -r 709fdb89f76c gameServer/RoomsAndClients.hs
--- 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
diff -r 41e06b74c991 -r 709fdb89f76c gameServer/ServerCore.hs
--- 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 ()
 
diff -r 41e06b74c991 -r 709fdb89f76c gameServer/hedgewars-server.hs
--- 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
diff -r 41e06b74c991 -r 709fdb89f76c gameServer/stresstest.hs
--- 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
 
diff -r 41e06b74c991 -r 709fdb89f76c gameServer/stresstest2.hs
--- 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
diff -r 41e06b74c991 -r 709fdb89f76c gameServer/stresstest3.hs
--- 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