netserver/hedgewars-server.hs
changeset 1370 ff8863ebde17
child 1381 e9754d1d61a9
equal deleted inserted replaced
1369:f5b1b3fd70cc 1370:ff8863ebde17
       
     1 module Main where
       
     2 
       
     3 import Network
       
     4 import IO
       
     5 import System.IO
       
     6 import Control.Concurrent
       
     7 import Control.Concurrent.STM
       
     8 import Control.Exception (setUncaughtExceptionHandler, handle, finally)
       
     9 import Control.Monad (forM, forM_, filterM, liftM)
       
    10 import Maybe (fromMaybe)
       
    11 import Data.List
       
    12 import Miscutils
       
    13 import HWProto
       
    14 import Opts
       
    15 
       
    16 acceptLoop :: Socket -> TChan ClientInfo -> IO ()
       
    17 acceptLoop servSock acceptChan = do
       
    18 	(cHandle, host, port) <- accept servSock
       
    19 	cChan <- atomically newTChan
       
    20 	forkIO $ clientLoop cHandle cChan
       
    21 	atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False)
       
    22 	hPutStrLn cHandle "CONNECTED\n"
       
    23 	hFlush cHandle
       
    24 	acceptLoop servSock acceptChan
       
    25 
       
    26 
       
    27 listenLoop :: Handle -> [String] -> TChan [String] -> IO ()
       
    28 listenLoop handle buf chan = do
       
    29 	str <- hGetLine handle
       
    30 	if str == "" then do
       
    31 		atomically $ writeTChan chan buf
       
    32 		listenLoop handle [] chan
       
    33 		else
       
    34 		listenLoop handle (buf ++ [str]) chan
       
    35 
       
    36 
       
    37 clientLoop :: Handle -> TChan [String] -> IO ()
       
    38 clientLoop handle chan =
       
    39 	listenLoop handle [] chan
       
    40 		`catch` (const $ clientOff >> return ())
       
    41 	where clientOff = atomically $ writeTChan chan ["QUIT"] -- if the client disconnects, we perform as if it sent QUIT message
       
    42 
       
    43 
       
    44 sendAnswers [] _ clients _ = return clients
       
    45 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do
       
    46 	let recipients = handlesFunc client clients rooms
       
    47 	putStrLn ("< " ++ (show answer))
       
    48 
       
    49 	clHandles' <- forM recipients $
       
    50 		\ch -> Control.Exception.handle (\e -> putStrLn (show e) >> hClose ch >> return [ch]) $
       
    51 			if (not $ null answer) && (head answer == "off") then hClose ch >> return [ch] else -- probably client with exception, don't send him anything
       
    52 			do
       
    53 			forM_ answer (\str -> hPutStrLn ch str)
       
    54 			hPutStrLn ch ""
       
    55 			hFlush ch
       
    56 			if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return []
       
    57 
       
    58 	let mclients = remove clients $ concat clHandles'
       
    59 
       
    60 	sendAnswers answers client mclients rooms
       
    61 	where
       
    62 		remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles
       
    63 
       
    64 
       
    65 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ()
       
    66 mainLoop servSock acceptChan clients rooms = do
       
    67 	r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
       
    68 	case r of
       
    69 		Left ci -> do
       
    70 			mainLoop servSock acceptChan (clients ++ [ci]) rooms
       
    71 		Right (cmd, client) -> do
       
    72 			putStrLn ("> " ++ show cmd)
       
    73 
       
    74 			let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd
       
    75 			let mrooms = roomsFunc rooms
       
    76 			let mclients = (clientsFunc clients)
       
    77 			let mclient = fromMaybe client $ find (== client) mclients
       
    78 
       
    79 			clientsIn <- sendAnswers answers mclient mclients mrooms
       
    80 			
       
    81 			mainLoop servSock acceptChan clientsIn mrooms
       
    82 
       
    83 
       
    84 startServer serverSocket = do
       
    85 	acceptChan <- atomically newTChan
       
    86 	forkIO $ acceptLoop serverSocket acceptChan
       
    87 	mainLoop serverSocket acceptChan [] []
       
    88 
       
    89 
       
    90 main = withSocketsDo $ do
       
    91 	flags <- opts
       
    92 	putStrLn $ "Listening on port " ++ show (getPort flags)
       
    93 	serverSocket <- listenOn $ PortNumber (getPort flags)
       
    94 	startServer serverSocket `finally` sClose serverSocket