Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
--- a/gameServer/Actions.hs Fri Mar 27 18:50:18 2009 +0000
+++ b/gameServer/Actions.hs Fri Mar 27 20:29:38 2009 +0000
@@ -42,6 +42,7 @@
| ProcessAccountInfo AccountInfo
| Dump
| AddClient ClientInfo
+ | PingAll
type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action]
@@ -56,7 +57,7 @@
processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do
- mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) (keys clients)
+ mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients)
return (clID, serverInfo, clients, rooms)
@@ -330,7 +331,7 @@
processAction (clID, serverInfo, clients, rooms) (AddClient client) = do
let updatedClients = insert (clientUID client) client clients
- infoM "Clients" ((show $ clientUID client) ++ ": new client. Time: " ++ (show $ connectTime client))
+ infoM "Clients" ((show $ clientUID client) ++ ": New client. Time: " ++ (show $ connectTime client))
writeChan (sendChan $ client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 20) $ lastLogins serverInfo
@@ -339,3 +340,11 @@
processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast"
else
return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) PingAll = do
+ processAction (clID,
+ serverInfo,
+ map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) clients,
+ rooms) $ AnswerAll ["PING"]
+
--- a/gameServer/CoreTypes.hs Fri Mar 27 18:50:18 2009 +0000
+++ b/gameServer/CoreTypes.hs Fri Mar 27 20:29:38 2009 +0000
@@ -25,6 +25,7 @@
logonPassed :: Bool,
clientProto :: Word16,
roomID :: Int,
+ pingsQueue :: Word,
isMaster :: Bool,
isReady :: Bool,
isAdministrator :: Bool,
@@ -152,8 +153,7 @@
Accept ClientInfo
| ClientMessage (Int, [String])
| ClientAccountInfo Int AccountInfo
- -- | CoreMessage String
- -- | TimerTick
+ | TimerAction
data DBQuery =
CheckAccount ClientInfo
--- a/gameServer/NetRoutines.hs Fri Mar 27 18:50:18 2009 +0000
+++ b/gameServer/NetRoutines.hs Fri Mar 27 20:29:38 2009 +0000
@@ -41,6 +41,7 @@
False
0
0
+ 0
False
False
False
--- a/gameServer/ServerCore.hs Fri Mar 27 18:50:18 2009 +0000
+++ b/gameServer/ServerCore.hs Fri Mar 27 20:29:38 2009 +0000
@@ -16,6 +16,11 @@
import OfficialServer.DBInteraction
+timerLoop :: Chan CoreMessage -> IO()
+timerLoop messagesChan = forever $ do
+ threadDelay (30 * 10^6) -- 30 seconds
+ writeChan messagesChan TimerAction
+
firstAway (_, a, b, c) = (a, b, c)
reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms)
@@ -50,6 +55,11 @@
do
debugM "Clients" "Got info for dead client"
return (serverInfo, clients, rooms)
+
+ TimerAction ->
+ liftM firstAway $ processAction
+ (0, serverInfo, clients, rooms)
+ PingAll
{- let hadRooms = (not $ null rooms) && (null mrooms)
@@ -58,20 +68,19 @@
mainLoop newServerInfo mClients mRooms
-startServer :: ServerInfo -> Chan CoreMessage -> Socket -> IO ()
-startServer serverInfo coreChan serverSocket = do
+startServer :: ServerInfo -> Socket -> IO ()
+startServer serverInfo serverSocket = do
putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
forkIO $
acceptLoop
serverSocket
- coreChan
+ (coreChan serverInfo)
0
return ()
-{- forkIO $ messagesLoop messagesChan
- forkIO $ timerLoop messagesChan-}
+ forkIO $ timerLoop $ coreChan serverInfo
startDBConnection $ serverInfo
--- a/gameServer/hedgewars-server.hs Fri Mar 27 18:50:18 2009 +0000
+++ b/gameServer/hedgewars-server.hs Fri Mar 27 20:29:38 2009 +0000
@@ -20,22 +20,6 @@
#endif
-{-data Messages =
- Accept ClientInfo
- | ClientMessage ([String], ClientInfo)
- | CoreMessage [String]
- | TimerTick
-
-messagesLoop :: TChan String -> IO()
-messagesLoop messagesChan = forever $ do
- threadDelay (25 * 10^6) -- 25 seconds
- atomically $ writeTChan messagesChan "PING"
-
-timerLoop :: TChan String -> IO()
-timerLoop messagesChan = forever $ do
- threadDelay (60 * 10^6) -- 60 seconds
- atomically $ writeTChan messagesChan "MINUTELY"-}
-
setupLoggers =
updateGlobalLogger "Clients"
(setLevel DEBUG)
@@ -55,4 +39,4 @@
bracket
(Network.listenOn $ Network.PortNumber $ listenPort serverInfo)
(sClose)
- (startServer serverInfo coreChan)
+ (startServer serverInfo)