diff -r 001a52a108ed -r 8bfb417d165e netserver/hedgewars-server.hs --- a/netserver/hedgewars-server.hs Wed Nov 05 08:02:12 2008 +0000 +++ b/netserver/hedgewars-server.hs Fri Nov 07 15:58:36 2008 +0000 @@ -12,6 +12,7 @@ import Miscutils import HWProto import Opts +import Data.Time #if !defined(mingw32_HOST_OS) import System.Posix @@ -29,11 +30,12 @@ acceptLoop :: Socket -> TChan ClientInfo -> IO () acceptLoop servSock acceptChan = Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ do - (cHandle, host, port) <- accept servSock - putStrLn "new client" + (cHandle, host, _) <- accept servSock + putStrLn $ "new client: " ++ host + currentTime <- getCurrentTime cChan <- atomically newTChan forkIO $ clientLoop cHandle cChan - atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False False False) + atomically $ writeTChan acceptChan (ClientInfo cChan cHandle host currentTime"" 0 "" False False False) atomically $ writeTChan cChan ["ASKME"] acceptLoop servSock acceptChan @@ -51,22 +53,22 @@ clientLoop :: Handle -> TChan [String] -> IO () clientLoop handle chan = listenLoop handle [] chan - `catch` (const $ clientOff >> return ()) - where clientOff = atomically $ writeTChan chan ["QUIT"] -- if the client disconnects, we perform as if it sent QUIT message + `catch` (\e -> (clientOff $ show e) >> return ()) + where clientOff msg = atomically $ writeTChan chan ["QUIT", msg] -- if the client disconnects, we perform as if it sent QUIT message sendAnswers [] _ clients _ = return clients sendAnswers ((handlesFunc, answer):answers) client clients rooms = do let recipients = handlesFunc client clients rooms --unless (null recipients) $ putStrLn ("< " ++ (show answer)) + when (head answer == "NICK") $ putStrLn (show answer) clHandles' <- forM recipients $ \ch -> Control.Exception.handle - (\e -> putStrLn ("handle exception: " ++ show e) >> - if head answer == "BYE" then + (\e -> if head answer == "BYE" then return [ch] else - atomically $ writeTChan (chan $ fromJust $ clientByHandle ch clients) ["QUIT"] >> return [] -- cannot just remove + atomically $ writeTChan (chan $ fromJust $ clientByHandle ch clients) ["QUIT", show e] >> return [] -- cannot just remove ) $ do forM_ answer (\str -> hPutStrLn ch str) @@ -75,7 +77,7 @@ if head answer == "BYE" then return [ch] else return [] let outHandles = concat clHandles' - unless (null outHandles) $ putStrLn ("bye: " ++ (show $ length outHandles) ++ "/" ++ (show $ length clients) ++ " clients") + unless (null outHandles) $ putStrLn ((show $ length outHandles) ++ " / " ++ (show $ length clients) ++ " : " ++ (show answer)) mapM_ (\ch -> Control.Exception.handle (const $ putStrLn "error on hClose") (hClose ch)) outHandles let mclients = remove clients outHandles @@ -97,7 +99,7 @@ let quitClient = find forceQuit $ clientsIn if isJust quitClient then - reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms + reactCmd ["QUIT", "Kicked"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms) @@ -109,7 +111,14 @@ (ClientMessage `fmap` tselect clients) `orElse` (CoreMessage `fmap` readTChan messagesChan) case r of - Accept ci -> + Accept ci -> do + let sameHostClients = filter (\cl -> host ci == host cl) clients + let haveJustConnected = not $ null $ filter (\cl -> diffUTCTime (connectTime ci) (connectTime cl) <= 5) sameHostClients + + when haveJustConnected $ do + atomically $ writeTChan (chan ci) ["QUIT", "Reconnected too fast"] + mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms + mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms ClientMessage (cmd, client) -> do (clientsIn, mrooms) <- reactCmd cmd client clients rooms