--- 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)
--- 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 =
--- 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]
--- 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