netserver/hedgewars-server.hs
changeset 1461 87e5a6c3882c
parent 1403 b8c921ed0f13
child 1463 659157f76171
equal deleted inserted replaced
1460:54e4b03e6ba6 1461:87e5a6c3882c
     4 import IO
     4 import IO
     5 import System.IO
     5 import System.IO
     6 import Control.Concurrent
     6 import Control.Concurrent
     7 import Control.Concurrent.STM
     7 import Control.Concurrent.STM
     8 import Control.Exception (setUncaughtExceptionHandler, handle, finally)
     8 import Control.Exception (setUncaughtExceptionHandler, handle, finally)
     9 import Control.Monad (forM, forM_, filterM, liftM, when, unless)
     9 import Control.Monad
    10 import Maybe (fromMaybe, isJust, fromJust)
    10 import Maybe (fromMaybe, isJust, fromJust)
    11 import Data.List
    11 import Data.List
    12 import Miscutils
    12 import Miscutils
    13 import HWProto
    13 import HWProto
    14 import Opts
    14 import Opts
    15 
    15 
    16 #if !defined(mingw32_HOST_OS)
    16 #if !defined(mingw32_HOST_OS)
    17 import System.Posix
    17 import System.Posix
    18 #endif
    18 #endif
    19 
    19 
       
    20 data Messages =
       
    21 	Accept ClientInfo
       
    22 	| ClientMessage ([String], ClientInfo)
       
    23 	| CoreMessage [String]
       
    24 
       
    25 messagesLoop :: TChan [String] -> IO()
       
    26 messagesLoop messagesChan = forever $ do
       
    27 	threadDelay (30 * 10^6) -- 30 seconds
       
    28 	atomically $ writeTChan messagesChan ["PING"]
    20 
    29 
    21 acceptLoop :: Socket -> TChan ClientInfo -> IO ()
    30 acceptLoop :: Socket -> TChan ClientInfo -> IO ()
    22 acceptLoop servSock acceptChan = do
    31 acceptLoop servSock acceptChan = do
    23 	(cHandle, host, port) <- accept servSock
    32 	(cHandle, host, port) <- accept servSock
    24 	hPutStrLn cHandle "CONNECTED\n"
    33 	hPutStrLn cHandle "CONNECTED\n"
    78 	clientsIn <- sendAnswers answers mclient mclients mrooms
    87 	clientsIn <- sendAnswers answers mclient mclients mrooms
    79 	let quitClient = find forceQuit $ clientsIn
    88 	let quitClient = find forceQuit $ clientsIn
    80 	if isJust quitClient then reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms)
    89 	if isJust quitClient then reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms)
    81 
    90 
    82 
    91 
    83 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ()
    92 mainLoop :: Socket -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO ()
    84 mainLoop servSock acceptChan clients rooms = do
    93 mainLoop servSock acceptChan messagesChan clients rooms = do
    85 	r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
    94 	r <- atomically $ (Accept `fmap` readTChan acceptChan) `orElse` (ClientMessage `fmap` tselect clients) `orElse` (CoreMessage `fmap` readTChan messagesChan)
    86 	case r of
    95 	case r of
    87 		Left ci -> do
    96 		Accept ci ->
    88 			mainLoop servSock acceptChan (clients ++ [ci]) rooms
    97 			mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms
    89 		Right (cmd, client) -> do
    98 		ClientMessage (cmd, client) -> do
    90 			(clientsIn, mrooms) <- reactCmd cmd client clients rooms
    99 			(clientsIn, mrooms) <- reactCmd cmd client clients rooms
    91 			
   100 			
    92 			let hadRooms = (not $ null rooms) && (null mrooms)
   101 			let hadRooms = (not $ null rooms) && (null mrooms)
    93 				in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $
   102 				in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $
    94 					mainLoop servSock acceptChan clientsIn mrooms
   103 					mainLoop servSock acceptChan messagesChan clientsIn mrooms
       
   104 		CoreMessage msg -> if not $ null $ clients then
       
   105 			do
       
   106 				let client = head clients -- don't care
       
   107 				(clientsIn, mrooms) <- reactCmd msg client clients rooms
       
   108 				mainLoop servSock acceptChan messagesChan clientsIn mrooms
       
   109 			else
       
   110 				mainLoop servSock acceptChan messagesChan clients rooms
    95 
   111 
    96 
   112 
    97 startServer serverSocket = do
   113 startServer serverSocket = do
    98 	acceptChan <- atomically newTChan
   114 	acceptChan <- atomically newTChan
    99 	forkIO $ acceptLoop serverSocket acceptChan
   115 	forkIO $ acceptLoop serverSocket acceptChan
   100 	mainLoop serverSocket acceptChan [] []
   116 	
       
   117 	messagesChan <- atomically newTChan
       
   118 	forkIO $ messagesLoop messagesChan
       
   119 	
       
   120 	mainLoop serverSocket acceptChan messagesChan [] []
   101 
   121 
   102 
   122 
   103 main = withSocketsDo $ do
   123 main = withSocketsDo $ do
   104 #if !defined(mingw32_HOST_OS)
   124 #if !defined(mingw32_HOST_OS)
   105 	installHandler sigPIPE Ignore Nothing;
   125 	installHandler sigPIPE Ignore Nothing;