merge
authorunc0rr
Sun, 25 Jul 2010 22:40:31 +0400
changeset 3675 857c9546a822
parent 3673 45778b16b224 (diff)
parent 3674 10f3099b497c (current diff)
child 3677 7d917b587547
merge
project_files/HedgewarsMobile/Resources/Icons/LI-iphone-Landscape.png
--- a/gameServer/Actions.hs	Sun Jul 25 17:32:07 2010 +0200
+++ b/gameServer/Actions.hs	Sun Jul 25 22:40:31 2010 +0400
@@ -56,8 +56,10 @@
 processAction :: Action -> StateT ServerState IO ()
 
 
-processAction (AnswerClients chans msg) = 
-    liftIO $ mapM_ (flip writeChan msg) chans
+processAction (AnswerClients chans msg) = do
+    liftIO (putStr $ "AnswerClients... " ++ (show $ length chans) ++ " (" ++ (show msg) ++")")
+    liftIO $ map (flip seq ()) chans `seq` mapM_ (flip writeChan msg) chans
+    liftIO (putStrLn "done")
 
 
 processAction SendServerMessage = do
@@ -68,7 +70,7 @@
             serverMessageForOldVersions si
             else
             serverMessage si
-    liftIO $ writeChan chan ["SERVER_MESSAGE", message]
+    processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
 {-
 
 processAction (clID, serverInfo, rnc) SendServerVars = do
@@ -87,12 +89,12 @@
 
 processAction (ProtocolError msg) = do
     chan <- client's sendChan
-    liftIO $ writeChan chan ["ERROR", msg]
+    processAction $ AnswerClients [chan] ["ERROR", msg]
 
 
 processAction (Warning msg) = do
     chan <- client's sendChan
-    liftIO $ writeChan chan ["WARNING", msg]
+    processAction $ AnswerClients [chan] ["WARNING", msg]
 
 processAction (ByeClient msg) = do
     (Just ci) <- gets clientIndex
@@ -109,13 +111,13 @@
         infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg))
 
         --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
-        writeChan chan ["BYE", msg]
         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})
 
 processAction (DeleteClient ci) = do
@@ -336,13 +338,13 @@
     case info of
         HasAccount passwd isAdmin -> do
             chan <- client's sendChan
-            liftIO $ writeChan chan ["ASKPASSWORD"]
+            processAction $ AnswerClients [chan] ["ASKPASSWORD"]
         Guest -> do
             processAction JoinLobby
         Admin -> do
             mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
             chan <- client's sendChan
-            liftIO $ writeChan chan ["ADMIN_ACCESS"]
+            processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
 
 
 processAction JoinLobby = do
@@ -402,8 +404,8 @@
         forkIO $ clientSendLoop (clientSocket client) (coreChan si) (sendChan client) ci
 
         infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client))
-        writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
 
+    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
--- a/gameServer/ClientIO.hs	Sun Jul 25 17:32:07 2010 +0200
+++ b/gameServer/ClientIO.hs	Sun Jul 25 22:40:31 2010 +0400
@@ -60,17 +60,17 @@
 clientSendLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO()
 clientSendLoop s coreChan chan ci = do
     answer <- readChan chan
-    doClose <- Exception.handle
-        (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return True) $ do
+    Exception.handle
+        (\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do
             sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n')
-            return $ isQuit answer
 
-    if doClose then
+    if (isQuit answer) then
         Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s
         else
         clientSendLoop s coreChan chan ci
 
     where
-        sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e])
+        --sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e])
+        sendQuit e = putStrLn $ show e
         isQuit ("BYE":xs) = True
         isQuit _ = False
--- a/gameServer/CoreTypes.hs	Sun Jul 25 17:32:07 2010 +0200
+++ b/gameServer/CoreTypes.hs	Sun Jul 25 22:40:31 2010 +0400
@@ -175,6 +175,13 @@
     | TimerAction Int
     | Remove ClientIndex
 
+instance Show CoreMessage where
+    show (Accept _) = "Accept"
+    show (ClientMessage _) = "ClientMessage"
+    show (ClientAccountInfo _) = "ClientAccountInfo"
+    show (TimerAction _) = "TimerAction"
+    show (Remove _) = "Remove"
+    
 type MRnC = MRoomsAndClients RoomInfo ClientInfo
 type IRnC = IRoomsAndClients RoomInfo ClientInfo
 
--- a/gameServer/ServerCore.hs	Sun Jul 25 17:32:07 2010 +0200
+++ b/gameServer/ServerCore.hs	Sun Jul 25 22:40:31 2010 +0400
@@ -35,6 +35,7 @@
     si <- gets serverInfo
     r <- liftIO $ readChan $ coreChan si
 
+    liftIO $ putStrLn $ "Core msg: " ++ show r
     case r of
         Accept ci -> processAction (AddClient ci)
 
@@ -46,7 +47,9 @@
                 modify (\as -> as{clientIndex = Just ci})
                 reactCmd cmd
 
-        Remove ci -> processAction (DeleteClient ci)
+        Remove ci -> do
+            liftIO $ debugM "Clients"  $ "DeleteClient: " ++ show ci
+            processAction (DeleteClient ci)
 
                 --else
                 --do
@@ -54,10 +57,13 @@
                 --return (serverInfo, rnc)
 
         ClientAccountInfo (ci, info) -> do
-            removed <- gets removedClients
-            when (not $ ci `Set.member` removed) $
-                processAction (ProcessAccountInfo info)
-
+            --should instead check ci exists and has same nick/hostname
+            --removed <- gets removedClients
+            --when (not $ ci `Set.member` removed) $ do
+            --    modify (\as -> as{clientIndex = Just ci})
+            --    processAction (ProcessAccountInfo info)
+            return ()
+            
         TimerAction tick ->
                 mapM_ processAction $
                     PingAll : [StatsAction | even tick]
--- a/gameServer/Store.hs	Sun Jul 25 17:32:07 2010 +0200
+++ b/gameServer/Store.hs	Sun Jul 25 22:40:31 2010 +0400
@@ -77,7 +77,7 @@
 removeElem :: MStore e -> ElemIndex -> IO ()
 removeElem (MStore ref) (ElemIndex n) = do
     (busyElems, freeElems, arr) <- readIORef ref
-    IOA.writeArray arr n (error "Store: no element")
+    IOA.writeArray arr n (error $ "Store: no element " ++ show n)
     writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr)
 
 
--- a/gameServer/stresstest3.hs	Sun Jul 25 17:32:07 2010 +0200
+++ b/gameServer/stresstest3.hs	Sun Jul 25 22:40:31 2010 +0400
@@ -63,7 +63,7 @@
     hFlush stdout
 
 forks = forever $ do
-    delay <- randomRIO (20000::Int, 40000)
+    delay <- randomRIO (10000::Int, 30000)
     threadDelay delay
     forkIO testing