netserver/hedgewars-server.hs
author unc0rr
Mon, 17 Nov 2008 18:24:34 +0000
changeset 1499 870305c40b81
parent 1497 b4586b0f4426
child 1500 5721af6d73f0
permissions -rw-r--r--
Don't close socket handles, just leave that job for garbage collector, as doing it manually seems to be the cause of server hangs
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1497
b4586b0f4426 Include CPP option into source file for easy use
unc0rr
parents: 1494
diff changeset
     1
{-# LANGUAGE CPP #-}
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     2
module Main where
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     3
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     4
import Network
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     5
import IO
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     6
import System.IO
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     7
import Control.Concurrent
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     8
import Control.Concurrent.STM
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     9
import Control.Exception (setUncaughtExceptionHandler, handle, finally)
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    10
import Control.Monad
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    11
import Maybe (fromMaybe, isJust, fromJust)
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    12
import Data.List
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    13
import Miscutils
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    14
import HWProto
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    15
import Opts
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    16
import Data.Time
1397
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
    17
1398
29eedf717d0f Check for right define
unc0rr
parents: 1397
diff changeset
    18
#if !defined(mingw32_HOST_OS)
1396
abb28dcb6d0d - Send additional info on rooms
unc0rr
parents: 1394
diff changeset
    19
import System.Posix
1397
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
    20
#endif
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
    21
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    22
data Messages =
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    23
	Accept ClientInfo
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    24
	| ClientMessage ([String], ClientInfo)
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    25
	| CoreMessage [String]
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    26
	| TimerTick
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    27
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    28
messagesLoop :: TChan [String] -> IO()
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    29
messagesLoop messagesChan = forever $ do
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    30
	threadDelay (25 * 10^6) -- 25 seconds
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    31
	atomically $ writeTChan messagesChan ["PING"]
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    32
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    33
timerLoop :: TChan [String] -> IO()
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    34
timerLoop messagesChan = forever $ do
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    35
	threadDelay (60 * 10^6) -- 60 seconds
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    36
	atomically $ writeTChan messagesChan ["MINUTELY"]
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    37
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    38
acceptLoop :: Socket -> TChan ClientInfo -> IO ()
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    39
acceptLoop servSock acceptChan =
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    40
	Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    41
	do
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    42
	(cHandle, host, _) <- accept servSock
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    43
	
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    44
	currentTime <- getCurrentTime
1481
f741afa7dbf3 Show time of connection start
unc0rr
parents: 1480
diff changeset
    45
	putStrLn $ (show currentTime) ++ " new client: " ++ host
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    46
	
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    47
	cChan <- atomically newTChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    48
	forkIO $ clientLoop cHandle cChan
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    49
	
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    50
	atomically $ writeTChan acceptChan (ClientInfo cChan cHandle host currentTime "" 0 "" False False False)
1469
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1468
diff changeset
    51
	atomically $ writeTChan cChan ["ASKME"]
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    52
	acceptLoop servSock acceptChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    53
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    54
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    55
listenLoop :: Handle -> [String] -> TChan [String] -> IO ()
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    56
listenLoop handle buf chan = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    57
	str <- hGetLine handle
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    58
	if str == "" then do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    59
		atomically $ writeTChan chan buf
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    60
		listenLoop handle [] chan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    61
		else
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    62
		listenLoop handle (buf ++ [str]) chan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    63
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    64
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    65
clientLoop :: Handle -> TChan [String] -> IO ()
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    66
clientLoop handle chan =
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    67
	listenLoop handle [] chan
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    68
		`catch` (\e -> (clientOff $ show e) >> return ())
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    69
	where clientOff msg = atomically $ writeTChan chan ["QUIT", msg] -- if the client disconnects, we perform as if it sent QUIT message
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    70
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    71
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    72
sendAnswers [] _ clients _ = return clients
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    73
sendAnswers ((handlesFunc, answer):answers) client clients rooms = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    74
	let recipients = handlesFunc client clients rooms
1476
b3b28e99570f Disconnect clients on BYE message
unc0rr
parents: 1475
diff changeset
    75
	--unless (null recipients) $ putStrLn ("< " ++ (show answer))
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    76
	when (head answer == "NICK") $ putStrLn (show answer)
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    77
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    78
	clHandles' <- forM recipients $
1468
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    79
		\ch -> Control.Exception.handle
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    80
			(\e -> if head answer == "BYE" then
1468
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    81
					return [ch]
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    82
				else
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    83
					atomically $ writeTChan (chan $ fromJust $ clientByHandle ch clients) ["QUIT", show e] >> return []  -- cannot just remove
1468
6e6a75de2fc9 Reformat code a bit
unc0rr
parents: 1466
diff changeset
    84
			) $
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    85
			do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    86
			forM_ answer (\str -> hPutStrLn ch str)
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    87
			hPutStrLn ch ""
1499
870305c40b81 Don't close socket handles, just leave that job for garbage collector, as doing it manually seems to be the cause of server hangs
unc0rr
parents: 1497
diff changeset
    88
			--hFlush ch
1466
c68b0a0969d3 It seems, I finally got the solution
unc0rr
parents: 1465
diff changeset
    89
			if head answer == "BYE" then return [ch] else return []
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    90
1476
b3b28e99570f Disconnect clients on BYE message
unc0rr
parents: 1475
diff changeset
    91
	let outHandles = concat clHandles'
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    92
	unless (null outHandles) $ putStrLn ((show $ length outHandles) ++ " / " ++ (show $ length clients) ++ " : " ++ (show answer))
1499
870305c40b81 Don't close socket handles, just leave that job for garbage collector, as doing it manually seems to be the cause of server hangs
unc0rr
parents: 1497
diff changeset
    93
870305c40b81 Don't close socket handles, just leave that job for garbage collector, as doing it manually seems to be the cause of server hangs
unc0rr
parents: 1497
diff changeset
    94
	-- strange, but this seems to be a bad idea to manually close these handles as it causes hangs
870305c40b81 Don't close socket handles, just leave that job for garbage collector, as doing it manually seems to be the cause of server hangs
unc0rr
parents: 1497
diff changeset
    95
	--mapM_ (\ch -> Control.Exception.handle (const $ putStrLn "error on hClose") (hClose ch)) outHandles
1476
b3b28e99570f Disconnect clients on BYE message
unc0rr
parents: 1475
diff changeset
    96
	let mclients = remove clients outHandles
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    97
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    98
	sendAnswers answers client mclients rooms
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    99
	where
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   100
		remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   101
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   102
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   103
reactCmd :: ServerInfo -> [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo])
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   104
reactCmd serverInfo cmd client clients rooms = do
1473
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   105
	--putStrLn ("> " ++ show cmd)
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   106
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   107
	let (clientsFunc, roomsFunc, answerFuncs) = handleCmd client clients rooms $ cmd
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   108
	let mrooms = roomsFunc rooms
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   109
	let mclients = (clientsFunc clients)
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   110
	let mclient = fromMaybe client $ find (== client) mclients
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   111
	let answers = map (\x -> x serverInfo) answerFuncs
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   112
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   113
	clientsIn <- sendAnswers answers mclient mclients mrooms
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
   114
	mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn
1474
8817adb86da6 Oops, fix build
unc0rr
parents: 1473
diff changeset
   115
	
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
   116
	return (clientsIn, mrooms)
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   117
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   118
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   119
mainLoop :: ServerInfo -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO ()
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   120
mainLoop serverInfo acceptChan messagesChan clients rooms = do
1473
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   121
	r <- atomically $
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   122
		(Accept `fmap` readTChan acceptChan) `orElse`
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   123
		(ClientMessage `fmap` tselect clients) `orElse`
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   124
		(CoreMessage `fmap` readTChan messagesChan)
1484
c01512115c12 - Add es and sv translations to hedgewars.pro
unc0rr
parents: 1483
diff changeset
   125
	
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   126
	case r of
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
   127
		Accept ci -> do
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
   128
			let sameHostClients = filter (\cl -> host ci == host cl) clients
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
   129
			let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
   130
			
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
   131
			when haveJustConnected $ do
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
   132
				atomically $ do
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
   133
					--writeTChan (chan ci) ["ERROR", "Reconnected too fast"]
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
   134
					writeTChan (chan ci) ["QUIT", "Reconnected too fast"]
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   135
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   136
			currentTime <- getCurrentTime
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   137
			let newServerInfo = serverInfo{
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   138
					loginsNumber = loginsNumber serverInfo + 1,
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   139
					lastHourUsers = currentTime : lastHourUsers serverInfo
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   140
					}
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   141
			mainLoop newServerInfo acceptChan messagesChan (clients ++ [ci]) rooms
1484
c01512115c12 - Add es and sv translations to hedgewars.pro
unc0rr
parents: 1483
diff changeset
   142
			
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   143
		ClientMessage (cmd, client) -> do
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   144
			(clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   145
			
1385
ca72264f921a Shutdown private server when room is abandoned
unc0rr
parents: 1384
diff changeset
   146
			let hadRooms = (not $ null rooms) && (null mrooms)
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   147
				in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   148
					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
1484
c01512115c12 - Add es and sv translations to hedgewars.pro
unc0rr
parents: 1483
diff changeset
   149
		
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   150
		CoreMessage msg -> case msg of
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   151
			["PING"] ->
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   152
				if not $ null $ clients then
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   153
					do
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   154
					let client = head clients -- don't care
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   155
					(clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   156
					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   157
				else
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   158
					mainLoop serverInfo acceptChan messagesChan clients rooms
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   159
			["MINUTELY"] -> do
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   160
				currentTime <- getCurrentTime
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   161
				let newServerInfo = serverInfo{
1494
6e6baf165e0c Fix wrong filter
unc0rr
parents: 1493
diff changeset
   162
						lastHourUsers = filter (\t -> currentTime `diffUTCTime` t < 3600) $ lastHourUsers serverInfo
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   163
						}
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   164
				mainLoop newServerInfo acceptChan messagesChan clients rooms
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   165
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   166
startServer :: ServerInfo -> Socket -> IO()
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   167
startServer serverInfo serverSocket = do
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   168
	acceptChan <- atomically newTChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   169
	forkIO $ acceptLoop serverSocket acceptChan
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   170
	
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   171
	messagesChan <- atomically newTChan
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   172
	forkIO $ messagesLoop messagesChan
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   173
	forkIO $ timerLoop messagesChan
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   174
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   175
	mainLoop serverInfo acceptChan messagesChan [] []
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   176
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   177
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   178
main = withSocketsDo $ do
1398
29eedf717d0f Check for right define
unc0rr
parents: 1397
diff changeset
   179
#if !defined(mingw32_HOST_OS)
1396
abb28dcb6d0d - Send additional info on rooms
unc0rr
parents: 1394
diff changeset
   180
	installHandler sigPIPE Ignore Nothing;
1397
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
   181
#endif
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   182
	serverInfo <- getOpts $ newServerInfo
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   183
	
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   184
	putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   185
	serverSocket <- listenOn $ PortNumber (listenPort serverInfo)
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   186
	
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   187
	startServer serverInfo serverSocket `finally` sClose serverSocket