--- a/netserver/HWProto.hs Fri Nov 07 17:02:22 2008 +0000
+++ b/netserver/HWProto.hs Fri Nov 07 22:03:43 2008 +0000
@@ -25,6 +25,7 @@
answerBadCmd = [(clientOnly, ["ERROR", "Bad command, state or incorrect parameter"])]
answerNotMaster = [(clientOnly, ["ERROR", "You cannot configure room parameters"])]
answerBadParam = [(clientOnly, ["ERROR", "Bad parameter"])]
+answerErrorMsg msg = [(clientOnly, ["ERROR", msg])]
answerQuit msg = [(clientOnly, ["BYE", msg])]
answerAbandoned = [(othersInRoom, ["BYE", "Room abandoned"])]
answerQuitInform nick = [(othersInRoom, ["LEFT", nick])]
@@ -93,6 +94,9 @@
handleCmd _ _ _ ["PONG"] =
(noChangeClients, noChangeRooms, [])
+handleCmd _ _ _ ["ERROR", msg] =
+ (noChangeClients, noChangeRooms, answerErrorMsg msg)
+
-- check state and call state-dependent commmand handlers
handleCmd client clients rooms cmd =
if null (nick client) || protocol client == 0 then
--- 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