--- a/netserver/HWProto.hs Wed Nov 05 08:02:12 2008 +0000
+++ b/netserver/HWProto.hs Fri Nov 07 15:58:36 2008 +0000
@@ -25,8 +25,8 @@
answerBadCmd = [(clientOnly, ["ERROR", "Bad command, state or incorrect parameter"])]
answerNotMaster = [(clientOnly, ["ERROR", "You cannot configure room parameters"])]
answerBadParam = [(clientOnly, ["ERROR", "Bad parameter"])]
-answerQuit = [(clientOnly, ["BYE"])]
-answerAbandoned = [(othersInRoom, ["BYE"])]
+answerQuit msg = [(clientOnly, ["BYE", msg])]
+answerAbandoned = [(othersInRoom, ["BYE", "Room abandoned"])]
answerQuitInform nick = [(othersInRoom, ["LEFT", nick])]
answerNickChosen = [(clientOnly, ["ERROR", "The nick already chosen"])]
answerNickChooseAnother = [(clientOnly, ["WARNING", "Choose another nick"])]
@@ -70,18 +70,19 @@
-- Main state-independent cmd handler
handleCmd :: CmdHandler
-handleCmd client _ rooms ("QUIT":xs) =
+handleCmd client _ rooms ("QUIT" : xs) =
if null (room client) then
- (noChangeClients, noChangeRooms, answerQuit)
+ (noChangeClients, noChangeRooms, answerQuit msg)
else if isMaster client then
- (noChangeClients, removeRoom (room client), answerQuit ++ answerAbandoned) -- core disconnects clients on ROOMABANDONED answer
+ (noChangeClients, removeRoom (room client), (answerQuit msg) ++ answerAbandoned) -- core disconnects clients on ROOMABANDONED answer
else
- (noChangeClients, modifyRoom clRoom{teams = othersTeams, playersIn = (playersIn clRoom) - 1, readyPlayers = newReadyPlayers}, answerQuit ++ (answerQuitInform $ nick client) ++ answerRemoveClientTeams)
+ (noChangeClients, modifyRoom clRoom{teams = othersTeams, playersIn = (playersIn clRoom) - 1, readyPlayers = newReadyPlayers}, (answerQuit msg) ++ (answerQuitInform $ nick client) ++ answerRemoveClientTeams)
where
clRoom = roomByName (room client) rooms
answerRemoveClientTeams = map (\tn -> (othersInRoom, ["REMOVE_TEAM", teamname tn])) clientTeams
(clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom
newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom
+ msg = if not $ null xs then head xs else ""
handleCmd _ _ _ ["PING"] = -- core requsted
(noChangeClients, noChangeRooms, answerPing)
--- a/netserver/Miscutils.hs Wed Nov 05 08:02:12 2008 +0000
+++ b/netserver/Miscutils.hs Fri Nov 07 15:58:36 2008 +0000
@@ -7,12 +7,15 @@
import Data.List
import Maybe (fromJust)
import qualified Data.Map as Map
+import Data.Time
data ClientInfo =
ClientInfo
{
chan :: TChan [String],
handle :: Handle,
+ host :: String,
+ connectTime :: UTCTime,
nick :: String,
protocol :: Word16,
room :: String,
--- 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