netserver/hedgewars-server.hs
author unc0rr
Fri, 16 Jan 2009 18:40:52 +0000
changeset 1686 f42dbc52225c
parent 1598 c853e02ed663
child 1755 cfb442f6a149
permissions -rw-r--r--
Use more convenient syntax
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1558
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1514
diff changeset
     1
{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}
1510
98c5799c851b Add some type info
unc0rr
parents: 1508
diff changeset
     2
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     3
module Main where
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     4
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     5
import Network
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     6
import IO
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     7
import System.IO
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     8
import Control.Concurrent
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
     9
import Control.Concurrent.STM
1510
98c5799c851b Add some type info
unc0rr
parents: 1508
diff changeset
    10
import Control.Exception (handle, finally, Exception, IOException)
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    11
import Control.Monad
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
    12
import Maybe (fromMaybe, isJust, fromJust)
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    13
import Data.List
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    14
import Miscutils
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    15
import HWProto
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    16
import Opts
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    17
import Data.Time
1397
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
    18
1398
29eedf717d0f Check for right define
unc0rr
parents: 1397
diff changeset
    19
#if !defined(mingw32_HOST_OS)
1396
abb28dcb6d0d - Send additional info on rooms
unc0rr
parents: 1394
diff changeset
    20
import System.Posix
1397
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
    21
#endif
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
    22
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    23
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    24
data Messages =
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    25
	Accept ClientInfo
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    26
	| ClientMessage ([String], ClientInfo)
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    27
	| CoreMessage [String]
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    28
	| TimerTick
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    29
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    30
messagesLoop :: TChan [String] -> IO()
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    31
messagesLoop messagesChan = forever $ do
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    32
	threadDelay (25 * 10^6) -- 25 seconds
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
    33
	atomically $ writeTChan messagesChan ["PING"]
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    34
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    35
timerLoop :: TChan [String] -> IO()
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    36
timerLoop messagesChan = forever $ do
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    37
	threadDelay (60 * 10^6) -- 60 seconds
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    38
	atomically $ writeTChan messagesChan ["MINUTELY"]
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
    39
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    40
acceptLoop :: Socket -> TChan ClientInfo -> IO ()
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    41
acceptLoop servSock acceptChan =
1558
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1514
diff changeset
    42
	Control.Exception.handle (\(_ :: Exception) -> putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    43
	do
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    44
	(cHandle, host, _) <- accept servSock
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    45
	
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    46
	currentTime <- getCurrentTime
1481
f741afa7dbf3 Show time of connection start
unc0rr
parents: 1480
diff changeset
    47
	putStrLn $ (show currentTime) ++ " new client: " ++ host
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    48
	
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    49
	cChan <- atomically newTChan
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    50
	sendChan <- atomically newTChan
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    51
	forkIO $ clientRecvLoop cHandle cChan
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    52
	forkIO $ clientSendLoop cHandle cChan sendChan
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
    53
	
1598
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    54
	atomically $ writeTChan acceptChan
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    55
			(ClientInfo
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    56
				cChan
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    57
				sendChan
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    58
				cHandle
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    59
				host
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    60
				currentTime
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    61
				""
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    62
				0
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    63
				""
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    64
				False
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    65
				False
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    66
				False
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    67
				False)
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
    68
1469
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1468
diff changeset
    69
	atomically $ writeTChan cChan ["ASKME"]
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    70
	acceptLoop servSock acceptChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    71
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    72
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    73
listenLoop :: Handle -> [String] -> TChan [String] -> IO ()
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    74
listenLoop handle buf chan = do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    75
	str <- hGetLine handle
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    76
	if str == "" then do
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    77
		atomically $ writeTChan chan buf
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    78
		listenLoop handle [] chan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    79
		else
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    80
		listenLoop handle (buf ++ [str]) chan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    81
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    82
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    83
clientRecvLoop :: Handle -> TChan [String] -> IO ()
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    84
clientRecvLoop handle chan =
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    85
	listenLoop handle [] chan
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    86
		`catch` (\e -> (clientOff $ show e) >> return ())
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
    87
	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
    88
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    89
clientSendLoop :: Handle -> TChan[String] -> TChan[String] -> IO()
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    90
clientSendLoop handle clChan chan = do
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    91
	answer <- atomically $ readTChan chan
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    92
	doClose <- Control.Exception.handle
1558
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1514
diff changeset
    93
		(\(e :: Exception) -> if isQuit answer then return True else sendQuit e >> return False) $ do
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    94
		forM_ answer (\str -> hPutStrLn handle str)
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    95
		hPutStrLn handle ""
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    96
		hFlush handle
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    97
		return $ isQuit answer
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
    98
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
    99
	if doClose then
1558
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1514
diff changeset
   100
		Control.Exception.handle (\(_ :: Exception) -> putStrLn "error on hClose") $ hClose handle
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   101
		else
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   102
		clientSendLoop handle clChan chan
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   103
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   104
	where
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   105
		sendQuit e = atomically $ writeTChan clChan ["QUIT", show e]
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   106
		isQuit answer = head answer == "BYE"
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   107
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   108
sendAnswers  [] _ clients _ = return clients
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   109
sendAnswers ((handlesFunc, answer):answers) client clients rooms = do
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   110
	let recipients = handlesFunc client clients rooms
1476
b3b28e99570f Disconnect clients on BYE message
unc0rr
parents: 1475
diff changeset
   111
	--unless (null recipients) $ putStrLn ("< " ++ (show answer))
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
   112
	when (head answer == "NICK") $ putStrLn (show answer)
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   113
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   114
	clHandles' <- forM recipients $
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   115
		\ch ->
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   116
			do
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   117
			atomically $ writeTChan (sendChan ch) answer
1466
c68b0a0969d3 It seems, I finally got the solution
unc0rr
parents: 1465
diff changeset
   118
			if head answer == "BYE" then return [ch] else return []
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   119
1476
b3b28e99570f Disconnect clients on BYE message
unc0rr
parents: 1475
diff changeset
   120
	let outHandles = concat clHandles'
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
   121
	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
   122
1686
f42dbc52225c Use more convenient syntax
unc0rr
parents: 1598
diff changeset
   123
	let mclients = clients \\ outHandles
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   124
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   125
	sendAnswers answers client mclients 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
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   128
reactCmd :: ServerInfo -> [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo])
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   129
reactCmd serverInfo cmd client clients rooms = do
1473
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   130
	--putStrLn ("> " ++ show cmd)
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   131
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   132
	let (clientsFunc, roomsFunc, answerFuncs) = handleCmd client clients rooms $ cmd
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   133
	let mrooms = roomsFunc rooms
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   134
	let mclients = (clientsFunc clients)
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   135
	let mclient = fromMaybe client $ find (== client) mclients
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   136
	let answers = map (\x -> x serverInfo) answerFuncs
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   137
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   138
	clientsIn <- sendAnswers answers mclient mclients mrooms
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
   139
	mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn
1598
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
   140
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
   141
	let clientsFinal = map (\cl -> if partRoom cl then cl{room = [], partRoom = False} else cl) clientsIn
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1558
diff changeset
   142
	return (clientsFinal, mrooms)
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   143
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   144
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   145
mainLoop :: ServerInfo -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO ()
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   146
mainLoop serverInfo acceptChan messagesChan clients rooms = do
1473
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   147
	r <- atomically $
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   148
		(Accept `fmap` readTChan acceptChan) `orElse`
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   149
		(ClientMessage `fmap` tselect clients) `orElse`
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1469
diff changeset
   150
		(CoreMessage `fmap` readTChan messagesChan)
1484
c01512115c12 - Add es and sv translations to hedgewars.pro
unc0rr
parents: 1483
diff changeset
   151
	
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   152
	case r of
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
   153
		Accept ci -> do
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
   154
			let sameHostClients = filter (\cl -> host ci == host cl) clients
1514
c4170faf7b0a oops, remove leftovers
unc0rr
parents: 1513
diff changeset
   155
			let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
   156
			
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1477
diff changeset
   157
			when haveJustConnected $ do
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
   158
				atomically $ do
89e24edb6020 Make code flow more clear
unc0rr
parents: 1482
diff changeset
   159
					writeTChan (chan ci) ["QUIT", "Reconnected too fast"]
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   160
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   161
			currentTime <- getCurrentTime
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   162
			let newServerInfo = serverInfo{
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   163
					loginsNumber = loginsNumber serverInfo + 1,
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   164
					lastHourUsers = currentTime : lastHourUsers serverInfo
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   165
					}
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   166
			mainLoop newServerInfo acceptChan messagesChan (clients ++ [ci]) rooms
1484
c01512115c12 - Add es and sv translations to hedgewars.pro
unc0rr
parents: 1483
diff changeset
   167
			
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   168
		ClientMessage (cmd, client) -> do
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   169
			(clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   170
			
1385
ca72264f921a Shutdown private server when room is abandoned
unc0rr
parents: 1384
diff changeset
   171
			let hadRooms = (not $ null rooms) && (null mrooms)
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   172
				in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   173
					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
1484
c01512115c12 - Add es and sv translations to hedgewars.pro
unc0rr
parents: 1483
diff changeset
   174
		
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   175
		CoreMessage msg -> case msg of
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   176
			["PING"] ->
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   177
				if not $ null $ clients then
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   178
					do
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   179
					let client = head clients -- don't care
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   180
					(clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   181
					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   182
				else
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   183
					mainLoop serverInfo acceptChan messagesChan clients rooms
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   184
			["MINUTELY"] -> do
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   185
				currentTime <- getCurrentTime
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   186
				let newServerInfo = serverInfo{
1494
6e6baf165e0c Fix wrong filter
unc0rr
parents: 1493
diff changeset
   187
						lastHourUsers = filter (\t -> currentTime `diffUTCTime` t < 3600) $ lastHourUsers serverInfo
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   188
						}
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   189
				mainLoop newServerInfo acceptChan messagesChan clients rooms
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   190
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   191
startServer :: ServerInfo -> Socket -> IO()
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   192
startServer serverInfo serverSocket = do
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   193
	acceptChan <- atomically newTChan
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   194
	forkIO $ acceptLoop serverSocket acceptChan
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   195
	
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   196
	messagesChan <- atomically newTChan
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1403
diff changeset
   197
	forkIO $ messagesLoop messagesChan
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   198
	forkIO $ timerLoop messagesChan
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   199
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1511
diff changeset
   200
	mainLoop serverInfo acceptChan messagesChan [] []
1370
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   201
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   202
ff8863ebde17 Add hedgewars server to build process
unc0rr
parents:
diff changeset
   203
main = withSocketsDo $ do
1398
29eedf717d0f Check for right define
unc0rr
parents: 1397
diff changeset
   204
#if !defined(mingw32_HOST_OS)
1396
abb28dcb6d0d - Send additional info on rooms
unc0rr
parents: 1394
diff changeset
   205
	installHandler sigPIPE Ignore Nothing;
1397
471c42a1c358 Use C preprocessor to allow compilation in windows
unc0rr
parents: 1396
diff changeset
   206
#endif
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   207
	serverInfo <- getOpts $ newServerInfo
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   208
	
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   209
	putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   210
	serverSocket <- listenOn $ PortNumber (listenPort serverInfo)
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   211
	
2da1fe033f23 Finish refactoring
unc0rr
parents: 1484
diff changeset
   212
	startServer serverInfo serverSocket `finally` sClose serverSocket