# HG changeset patch
# User unc0rr
# Date 1225658462 0
# Node ID 87e5a6c3882cd637005722646d0b68ecde7dd04b
# Parent  54e4b03e6ba699408bf9165e3d3306af617ba8be
Ping clients every 30 seconds, should help with ghosts on server

diff -r 54e4b03e6ba6 -r 87e5a6c3882c CMakeLists.txt
--- a/CMakeLists.txt	Sun Nov 02 11:46:58 2008 +0000
+++ b/CMakeLists.txt	Sun Nov 02 20:41:02 2008 +0000
@@ -1,6 +1,6 @@
 project(hedgewars)
 
-cmake_minimum_required(VERSION 2.4.4 FATAL_ERROR)
+cmake_minimum_required(VERSION 2.6.0 FATAL_ERROR)
 
 if(COMMAND cmake_policy)
 	cmake_policy(SET CMP0003 NEW)
diff -r 54e4b03e6ba6 -r 87e5a6c3882c netserver/HWProto.hs
--- a/netserver/HWProto.hs	Sun Nov 02 11:46:58 2008 +0000
+++ b/netserver/HWProto.hs	Sun Nov 02 20:41:02 2008 +0000
@@ -62,6 +62,7 @@
 answerNotReady nick = [(sameRoom, ["NOT_READY", nick])]
 answerTooFewClans = [(clientOnly, ["ERROR", "Too few clans in game"])]
 answerRestricted = [(clientOnly, ["WARNING", "Room joining restricted"])]
+answerPing = [(allClients, ["PING"])]
 
 -- Main state-independent cmd handler
 handleCmd :: CmdHandler
@@ -78,6 +79,8 @@
 		(clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom
 		newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom
 
+handleCmd _ _ _ ["PING"] = -- core requsted
+	(noChangeClients, noChangeRooms, answerPing)
 
 -- check state and call state-dependent commmand handlers
 handleCmd client clients rooms cmd =
diff -r 54e4b03e6ba6 -r 87e5a6c3882c netserver/Miscutils.hs
--- a/netserver/Miscutils.hs	Sun Nov 02 11:46:58 2008 +0000
+++ b/netserver/Miscutils.hs	Sun Nov 02 20:41:02 2008 +0000
@@ -90,6 +90,9 @@
 fromRoom :: String -> HandlesSelector
 fromRoom roomName _ clients _ = map handle $ filter (\ci -> room ci == roomName) clients
 
+allClients :: HandlesSelector
+allClients _ clients _ = map handle $ clients
+
 clientOnly :: HandlesSelector
 clientOnly client _ _ = [handle client]
 
diff -r 54e4b03e6ba6 -r 87e5a6c3882c netserver/hedgewars-server.hs
--- a/netserver/hedgewars-server.hs	Sun Nov 02 11:46:58 2008 +0000
+++ b/netserver/hedgewars-server.hs	Sun Nov 02 20:41:02 2008 +0000
@@ -6,7 +6,7 @@
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception (setUncaughtExceptionHandler, handle, finally)
-import Control.Monad (forM, forM_, filterM, liftM, when, unless)
+import Control.Monad
 import Maybe (fromMaybe, isJust, fromJust)
 import Data.List
 import Miscutils
@@ -17,6 +17,15 @@
 import System.Posix
 #endif
 
+data Messages =
+	Accept ClientInfo
+	| ClientMessage ([String], ClientInfo)
+	| CoreMessage [String]
+
+messagesLoop :: TChan [String] -> IO()
+messagesLoop messagesChan = forever $ do
+	threadDelay (30 * 10^6) -- 30 seconds
+	atomically $ writeTChan messagesChan ["PING"]
 
 acceptLoop :: Socket -> TChan ClientInfo -> IO ()
 acceptLoop servSock acceptChan = do
@@ -80,24 +89,35 @@
 	if isJust quitClient then reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms)
 
 
-mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ()
-mainLoop servSock acceptChan clients rooms = do
-	r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
+mainLoop :: Socket -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO ()
+mainLoop servSock acceptChan messagesChan clients rooms = do
+	r <- atomically $ (Accept `fmap` readTChan acceptChan) `orElse` (ClientMessage `fmap` tselect clients) `orElse` (CoreMessage `fmap` readTChan messagesChan)
 	case r of
-		Left ci -> do
-			mainLoop servSock acceptChan (clients ++ [ci]) rooms
-		Right (cmd, client) -> do
+		Accept ci ->
+			mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms
+		ClientMessage (cmd, client) -> do
 			(clientsIn, mrooms) <- reactCmd cmd client clients rooms
 			
 			let hadRooms = (not $ null rooms) && (null mrooms)
 				in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $
-					mainLoop servSock acceptChan clientsIn mrooms
+					mainLoop servSock acceptChan messagesChan clientsIn mrooms
+		CoreMessage msg -> if not $ null $ clients then
+			do
+				let client = head clients -- don't care
+				(clientsIn, mrooms) <- reactCmd msg client clients rooms
+				mainLoop servSock acceptChan messagesChan clientsIn mrooms
+			else
+				mainLoop servSock acceptChan messagesChan clients rooms
 
 
 startServer serverSocket = do
 	acceptChan <- atomically newTChan
 	forkIO $ acceptLoop serverSocket acceptChan
-	mainLoop serverSocket acceptChan [] []
+	
+	messagesChan <- atomically newTChan
+	forkIO $ messagesLoop messagesChan
+	
+	mainLoop serverSocket acceptChan messagesChan [] []
 
 
 main = withSocketsDo $ do