# HG changeset patch # User unc0rr # Date 1280083231 -14400 # Node ID 857c9546a822815a7a7538d4d8b463b442c0a529 # Parent 45778b16b22454ad0302e002cd53b2b749c1d178# Parent 10f3099b497cb6ccb44812d2c9f4df6553973a82 merge diff -r 10f3099b497c -r 857c9546a822 gameServer/Actions.hs --- 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 diff -r 10f3099b497c -r 857c9546a822 gameServer/ClientIO.hs --- 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 diff -r 10f3099b497c -r 857c9546a822 gameServer/CoreTypes.hs --- 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 diff -r 10f3099b497c -r 857c9546a822 gameServer/ServerCore.hs --- 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] diff -r 10f3099b497c -r 857c9546a822 gameServer/Store.hs --- 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) diff -r 10f3099b497c -r 857c9546a822 gameServer/stresstest3.hs --- 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