--- a/gameServer/Actions.hs Sun Jul 25 18:55:54 2010 +0400
+++ b/gameServer/Actions.hs Sun Jul 25 22:39:59 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 18:55:54 2010 +0400
+++ b/gameServer/ClientIO.hs Sun Jul 25 22:39:59 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 18:55:54 2010 +0400
+++ b/gameServer/CoreTypes.hs Sun Jul 25 22:39:59 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 18:55:54 2010 +0400
+++ b/gameServer/ServerCore.hs Sun Jul 25 22:39:59 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 18:55:54 2010 +0400
+++ b/gameServer/Store.hs Sun Jul 25 22:39:59 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 18:55:54 2010 +0400
+++ b/gameServer/stresstest3.hs Sun Jul 25 22:39:59 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