# HG changeset patch
# User unc0rr
# Date 1226346294 0
# Node ID 1e422bc5d863e6431fbdc5e7bf4a65151dc5362e
# Parent  2da1fe033f2300e4bea761c8afb13c00033f8bb0
Show last hour logins number

diff -r 2da1fe033f23 -r 1e422bc5d863 netserver/HWProto.hs
--- a/netserver/HWProto.hs	Mon Nov 10 15:57:59 2008 +0000
+++ b/netserver/HWProto.hs	Mon Nov 10 19:44:54 2008 +0000
@@ -72,7 +72,8 @@
 			(answerClientOnly ["TEAM_COLOR", teamname team, teamcolor team]) ++
 			(answerClientOnly ["HH_NUM", teamname team, show $ hhnum team])
 
-answerServerMessage clients = [\serverInfo -> (clientOnly, "SERVER_MESSAGE" : [(mainbody serverInfo) ++ clientsIn])]
+answerServerMessage clients = [\serverInfo -> (clientOnly, "SERVER_MESSAGE" :
+		[(mainbody serverInfo) ++ clientsIn ++ (lastHour serverInfo)])]
 	where
 		mainbody serverInfo = serverMessage serverInfo ++
 			if isDedicated serverInfo then
@@ -82,6 +83,11 @@
 		
 		clientsIn = "<p align=left>" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "</p>"
 		clientslist = if not $ null nicks then foldr1 (\a b -> a  ++ ", " ++ b) nicks else ""
+		lastHour serverInfo =
+			if isDedicated serverInfo then
+				"<p align=left>" ++ (show $ length $ lastHourUsers serverInfo) ++ " user logins in last hour</p>"
+				else
+				""
 		nicks = filter (not . null) $ map nick clients
 
 answerPing = makeAnswer allClients ["PING"]
diff -r 2da1fe033f23 -r 1e422bc5d863 netserver/Miscutils.hs
--- a/netserver/Miscutils.hs	Mon Nov 10 15:57:59 2008 +0000
+++ b/netserver/Miscutils.hs	Mon Nov 10 19:44:54 2008 +0000
@@ -79,13 +79,17 @@
 	{
 		isDedicated :: Bool,
 		serverMessage :: String,
-		listenPort :: PortNumber
+		listenPort :: PortNumber,
+		loginsNumber :: Int,
+		lastHourUsers :: [UTCTime]
 	}
 newServerInfo = (
 	ServerInfo
 		True
 		"<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>"
 		46631
+		0
+		[]
 	)
 
 type ClientsTransform = [ClientInfo] -> [ClientInfo]
diff -r 2da1fe033f23 -r 1e422bc5d863 netserver/hedgewars-server.hs
--- a/netserver/hedgewars-server.hs	Mon Nov 10 15:57:59 2008 +0000
+++ b/netserver/hedgewars-server.hs	Mon Nov 10 19:44:54 2008 +0000
@@ -22,12 +22,18 @@
 	Accept ClientInfo
 	| ClientMessage ([String], ClientInfo)
 	| CoreMessage [String]
+	| TimerTick
 
 messagesLoop :: TChan [String] -> IO()
 messagesLoop messagesChan = forever $ do
-	threadDelay (30 * 10^6) -- 30 seconds
+	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"]
+
 acceptLoop :: Socket -> TChan ClientInfo -> IO ()
 acceptLoop servSock acceptChan =
 	Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $
@@ -123,8 +129,13 @@
 				atomically $ do
 					--writeTChan (chan ci) ["ERROR", "Reconnected too fast"]
 					writeTChan (chan ci) ["QUIT", "Reconnected too fast"]
-				
-			mainLoop serverInfo acceptChan messagesChan (clients ++ [ci]) rooms
+
+			currentTime <- getCurrentTime
+			let newServerInfo = serverInfo{
+					loginsNumber = loginsNumber serverInfo + 1,
+					lastHourUsers = currentTime : lastHourUsers serverInfo
+					}
+			mainLoop newServerInfo acceptChan messagesChan (clients ++ [ci]) rooms
 			
 		ClientMessage (cmd, client) -> do
 			(clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms
@@ -133,14 +144,21 @@
 				in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
 					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
 		
-		CoreMessage msg ->
-			if not $ null $ clients then
-				do
-				let client = head clients -- don't care
-				(clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms
-				mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
-			else
-				mainLoop serverInfo acceptChan messagesChan clients rooms
+		CoreMessage msg -> case msg of
+			["PING"] ->
+				if not $ null $ clients then
+					do
+					let client = head clients -- don't care
+					(clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms
+					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
+				else
+					mainLoop serverInfo acceptChan messagesChan clients rooms
+			["MINUTELY"] -> do
+				currentTime <- getCurrentTime
+				let newServerInfo = serverInfo{
+						lastHourUsers = filter (\t -> currentTime `diffUTCTime` t > 3600) $ lastHourUsers serverInfo
+						}
+				mainLoop newServerInfo acceptChan messagesChan clients rooms
 
 startServer :: ServerInfo -> Socket -> IO()
 startServer serverInfo serverSocket = do
@@ -149,6 +167,7 @@
 	
 	messagesChan <- atomically newTChan
 	forkIO $ messagesLoop messagesChan
+	forkIO $ timerLoop messagesChan
 
 	mainLoop serverInfo acceptChan messagesChan [] []
 
@@ -157,9 +176,9 @@
 #if !defined(mingw32_HOST_OS)
 	installHandler sigPIPE Ignore Nothing;
 #endif
-	serverInfo <- getOpts newServerInfo
+	serverInfo <- getOpts $ newServerInfo
 	
 	putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
+	serverSocket <- listenOn $ PortNumber (listenPort serverInfo)
 	
-	serverSocket <- listenOn $ PortNumber (listenPort serverInfo)
 	startServer serverInfo serverSocket `finally` sClose serverSocket