diff -r 8af42b3f93d2 -r 89e24edb6020 netserver/hedgewars-server.hs --- a/netserver/hedgewars-server.hs Fri Nov 07 17:02:22 2008 +0000 +++ b/netserver/hedgewars-server.hs Fri Nov 07 22:03:43 2008 +0000 @@ -29,13 +29,18 @@ atomically $ writeTChan messagesChan ["PING"] acceptLoop :: Socket -> TChan ClientInfo -> IO () -acceptLoop servSock acceptChan = Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ do +acceptLoop servSock acceptChan = + Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ + do (cHandle, host, _) <- accept servSock + currentTime <- getCurrentTime putStrLn $ (show currentTime) ++ " new client: " ++ host + cChan <- atomically newTChan forkIO $ clientLoop cHandle cChan - atomically $ writeTChan acceptChan (ClientInfo cChan cHandle host currentTime"" 0 "" False False False) + + atomically $ writeTChan acceptChan (ClientInfo cChan cHandle host currentTime "" 0 "" False False False) atomically $ writeTChan cChan ["ASKME"] acceptLoop servSock acceptChan @@ -96,12 +101,9 @@ let mclient = fromMaybe client $ find (== client) mclients clientsIn <- sendAnswers answers mclient mclients mrooms - let quitClient = find forceQuit $ clientsIn + mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn - if isJust quitClient then - reactCmd ["QUIT", "Kicked"] (fromJust quitClient) clientsIn mrooms - else - return (clientsIn, mrooms) + return (clientsIn, mrooms) mainLoop :: TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () @@ -113,11 +115,12 @@ case r of Accept ci -> do let sameHostClients = filter (\cl -> host ci == host cl) clients - let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 5) sameHostClients + let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients when haveJustConnected $ do - atomically $ writeTChan (chan ci) ["QUIT", "Reconnected too fast"] - mainLoop acceptChan messagesChan (clients ++ [ci]) rooms + atomically $ do + --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] + writeTChan (chan ci) ["QUIT", "Reconnected too fast"] mainLoop acceptChan messagesChan (clients ++ [ci]) rooms ClientMessage (cmd, client) -> do