netserver/hedgewars-server.hs
author unc0rr
Tue, 04 Nov 2008 22:56:36 +0000
changeset 1476 b3b28e99570f
parent 1475 bab5650fc894
child 1477 001a52a108ed
permissions -rw-r--r--
Disconnect clients on BYE message
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)
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
     9
import Control.Monad
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    10
import Maybe (fromMaybe, isJust, fromJust)
1370
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
1397
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
    15
1398
29eedf717d0f Check for right define
unc0rr
parents: 1397
diff changeset
    16
#if !defined(mingw32_HOST_OS)
1396
abb28dcb6d0d - Send additional info on rooms
unc0rr
parents: 1394
diff changeset
    17
import System.Posix
1397
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
    18
#endif
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
    19
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    20
data Messages =
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    21
	Accept ClientInfo
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    22
	| ClientMessage ([String], ClientInfo)
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    23
	| CoreMessage [String]
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    24
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    25
messagesLoop :: TChan [String] -> IO()
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    26
messagesLoop messagesChan = forever $ do
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    27
	threadDelay (30 * 10^6) -- 30 seconds
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    28
	atomically $ writeTChan messagesChan ["PING"]
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    29
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    30
acceptLoop :: Socket -> TChan ClientInfo -> IO ()
1469
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1468
diff changeset
    31
acceptLoop servSock acceptChan = Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ do
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    32
	(cHandle, host, port) <- accept servSock
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    33
	cChan <- atomically newTChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    34
	forkIO $ clientLoop cHandle cChan
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1398
diff changeset
    35
	atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False False False)
1469
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1468
diff changeset
    36
	atomically $ writeTChan cChan ["ASKME"]
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    37
	acceptLoop servSock acceptChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    38
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    39
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    40
listenLoop :: Handle -> [String] -> TChan [String] -> IO ()
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    41
listenLoop handle buf chan = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    42
	str <- hGetLine handle
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    43
	if str == "" then do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    44
		atomically $ writeTChan chan buf
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    45
		listenLoop handle [] chan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    46
		else
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    47
		listenLoop handle (buf ++ [str]) chan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    48
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    49
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    50
clientLoop :: Handle -> TChan [String] -> IO ()
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    51
clientLoop handle chan =
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    52
	listenLoop handle [] chan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    53
		`catch` (const $ clientOff >> return ())
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    54
	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
    55
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    56
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    57
sendAnswers [] _ clients _ = return clients
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    58
sendAnswers ((handlesFunc, answer):answers) client clients rooms = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    59
	let recipients = handlesFunc client clients rooms
1476
b3b28e99570f Disconnect clients on BYE message
unc0rr
parents: 1475
diff changeset
    60
	--unless (null recipients) $ putStrLn ("< " ++ (show answer))
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    61
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    62
	clHandles' <- forM recipients $
1468
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    63
		\ch -> Control.Exception.handle
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    64
			(\e -> putStrLn ("handle exception: " ++ show e) >>
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    65
				if head answer == "BYE" then
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    66
					return [ch]
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    67
				else
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    68
					atomically $ writeTChan (chan $ fromJust $ clientByHandle ch clients) ["QUIT"] >> return []  -- cannot just remove
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    69
			) $
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    70
			do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    71
			forM_ answer (\str -> hPutStrLn ch str)
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    72
			hPutStrLn ch ""
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    73
			hFlush ch
1466
c68b0a0969d3 It seems, I finally got the solution
unc0rr
parents: 1465
diff changeset
    74
			if head answer == "BYE" then return [ch] else return []
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    75
1476
b3b28e99570f Disconnect clients on BYE message
unc0rr
parents: 1475
diff changeset
    76
	let outHandles = concat clHandles'
b3b28e99570f Disconnect clients on BYE message
unc0rr
parents: 1475
diff changeset
    77
	mapM_ (\ch -> Control.Exception.handle (const $ putStrLn "error on hClose") (hClose ch)) outHandles
b3b28e99570f Disconnect clients on BYE message
unc0rr
parents: 1475
diff changeset
    78
	let mclients = remove clients outHandles
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    79
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    80
	sendAnswers answers client mclients rooms
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    81
	where
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    82
		remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    83
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    84
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    85
reactCmd :: [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo])
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    86
reactCmd cmd client clients rooms = do
1473
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
    87
	--putStrLn ("> " ++ show cmd)
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    88
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    89
	let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    90
	let mrooms = roomsFunc rooms
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    91
	let mclients = (clientsFunc clients)
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    92
	let mclient = fromMaybe client $ find (== client) mclients
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    93
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    94
	clientsIn <- sendAnswers answers mclient mclients mrooms
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    95
	let quitClient = find forceQuit $ clientsIn
1474
8817adb86da6 Oops, fix build
unc0rr
parents: 1473
diff changeset
    96
	
1473
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
    97
	if isJust quitClient then
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
    98
		reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms
1474
8817adb86da6 Oops, fix build
unc0rr
parents: 1473
diff changeset
    99
		else
1473
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   100
		return (clientsIn, mrooms)
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   101
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   102
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   103
mainLoop :: Socket -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO ()
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   104
mainLoop servSock acceptChan messagesChan clients rooms = do
1473
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   105
	r <- atomically $
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   106
		(Accept `fmap` readTChan acceptChan) `orElse`
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   107
		(ClientMessage `fmap` tselect clients) `orElse`
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   108
		(CoreMessage `fmap` readTChan messagesChan)
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   109
	case r of
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   110
		Accept ci ->
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   111
			mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   112
		ClientMessage (cmd, client) -> do
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   113
			(clientsIn, mrooms) <- reactCmd cmd client clients rooms
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   114
			
1385
ca72264f921a Shutdown private server when room is abandoned
unc0rr
parents: 1384
diff changeset
   115
			let hadRooms = (not $ null rooms) && (null mrooms)
ca72264f921a Shutdown private server when room is abandoned
unc0rr
parents: 1384
diff changeset
   116
				in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   117
					mainLoop servSock acceptChan messagesChan clientsIn mrooms
1473
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   118
		CoreMessage msg ->
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   119
			if not $ null $ clients then
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   120
				do
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   121
				let client = head clients -- don't care
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   122
				(clientsIn, mrooms) <- reactCmd msg client clients rooms
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   123
				mainLoop servSock acceptChan messagesChan clientsIn mrooms
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   124
			else
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   125
				mainLoop servSock acceptChan messagesChan clients rooms
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   126
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   127
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   128
startServer serverSocket = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   129
	acceptChan <- atomically newTChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   130
	forkIO $ acceptLoop serverSocket acceptChan
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   131
	
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   132
	messagesChan <- atomically newTChan
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   133
	forkIO $ messagesLoop messagesChan
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   134
	
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   135
	mainLoop serverSocket acceptChan messagesChan [] []
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   136
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   137
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   138
main = withSocketsDo $ do
1398
29eedf717d0f Check for right define
unc0rr
parents: 1397
diff changeset
   139
#if !defined(mingw32_HOST_OS)
1396
abb28dcb6d0d - Send additional info on rooms
unc0rr
parents: 1394
diff changeset
   140
	installHandler sigPIPE Ignore Nothing;
1397
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
   141
#endif
1383
d20e6e8928e3 Refactor options handling and storing
unc0rr
parents: 1382
diff changeset
   142
	putStrLn $ "Listening on port " ++ show (listenPort globalOptions)
d20e6e8928e3 Refactor options handling and storing
unc0rr
parents: 1382
diff changeset
   143
	serverSocket <- listenOn $ PortNumber (listenPort globalOptions)
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   144
	startServer serverSocket `finally` sClose serverSocket