netserver/hedgewars-server.hs
author unc0rr
Mon, 20 Oct 2008 18:35:36 +0000
changeset 1384 329d3308e2e3
parent 1383 d20e6e8928e3
child 1385 ca72264f921a
permissions -rw-r--r--
Support for private servers in frontend
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     1
module Main where
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     2
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     3
import Network
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     4
import IO
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     5
import System.IO
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     6
import Control.Concurrent
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     7
import Control.Concurrent.STM
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     8
import Control.Exception (setUncaughtExceptionHandler, handle, finally)
1384
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
     9
import Control.Monad (forM, forM_, filterM, liftM, when, unless)
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    10
import Maybe (fromMaybe)
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    11
import Data.List
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    12
import Miscutils
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    13
import HWProto
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    14
import Opts
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    15
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    16
acceptLoop :: Socket -> TChan ClientInfo -> IO ()
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    17
acceptLoop servSock acceptChan = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    18
	(cHandle, host, port) <- accept servSock
1384
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
    19
	hPutStrLn cHandle "CONNECTED\n"
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
    20
	hFlush cHandle
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    21
	cChan <- atomically newTChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    22
	forkIO $ clientLoop cHandle cChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    23
	atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False)
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    24
	acceptLoop servSock acceptChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    25
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    26
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    27
listenLoop :: Handle -> [String] -> TChan [String] -> IO ()
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    28
listenLoop handle buf chan = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    29
	str <- hGetLine handle
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    30
	if str == "" then do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    31
		atomically $ writeTChan chan buf
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    32
		listenLoop handle [] chan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    33
		else
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    34
		listenLoop handle (buf ++ [str]) chan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    35
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    36
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    37
clientLoop :: Handle -> TChan [String] -> IO ()
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    38
clientLoop handle chan =
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    39
	listenLoop handle [] chan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    40
		`catch` (const $ clientOff >> return ())
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    41
	where clientOff = atomically $ writeTChan chan ["QUIT"] -- if the client disconnects, we perform as if it sent QUIT message
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    42
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    43
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    44
sendAnswers [] _ clients _ = return clients
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    45
sendAnswers ((handlesFunc, answer):answers) client clients rooms = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    46
	let recipients = handlesFunc client clients rooms
1381
e9754d1d61a9 Log reply only when send it
unc0rr
parents: 1370
diff changeset
    47
	unless (null recipients) $ putStrLn ("< " ++ (show answer))
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    48
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    49
	clHandles' <- forM recipients $
1382
b6ab9fea22fe - Small but very important fix
unc0rr
parents: 1381
diff changeset
    50
		\ch -> Control.Exception.handle (\e -> putStrLn (show e) >> hClose ch >> return []) $ -- cannot just remove
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    51
			do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    52
			forM_ answer (\str -> hPutStrLn ch str)
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    53
			hPutStrLn ch ""
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    54
			hFlush ch
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    55
			if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return []
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    56
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    57
	let mclients = remove clients $ concat clHandles'
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    58
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    59
	sendAnswers answers client mclients rooms
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    60
	where
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    61
		remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    62
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    63
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    64
mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ()
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    65
mainLoop servSock acceptChan clients rooms = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    66
	r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    67
	case r of
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    68
		Left ci -> do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    69
			mainLoop servSock acceptChan (clients ++ [ci]) rooms
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    70
		Right (cmd, client) -> do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    71
			putStrLn ("> " ++ show cmd)
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    72
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    73
			let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    74
			let mrooms = roomsFunc rooms
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    75
			let mclients = (clientsFunc clients)
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    76
			let mclient = fromMaybe client $ find (== client) mclients
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    77
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    78
			clientsIn <- sendAnswers answers mclient mclients mrooms
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    79
			
1384
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
    80
			when ((isDedicated globalOptions) || (not $ null clientsIn)) $ mainLoop servSock acceptChan clientsIn mrooms
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    81
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    82
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    83
startServer serverSocket = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    84
	acceptChan <- atomically newTChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    85
	forkIO $ acceptLoop serverSocket acceptChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    86
	mainLoop serverSocket acceptChan [] []
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    87
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    88
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    89
main = withSocketsDo $ do
1383
d20e6e8928e3 Refactor options handling and storing
unc0rr
parents: 1382
diff changeset
    90
	putStrLn $ "Listening on port " ++ show (listenPort globalOptions)
d20e6e8928e3 Refactor options handling and storing
unc0rr
parents: 1382
diff changeset
    91
	serverSocket <- listenOn $ PortNumber (listenPort globalOptions)
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    92
	startServer serverSocket `finally` sClose serverSocket