gameServer/ServerCore.hs
author unc0rr
Fri, 27 Mar 2009 20:29:38 +0000
changeset 1927 e2031906a347
parent 1926 cb46fbdcaa41
child 2116 dec7ead2d178
permissions -rw-r--r--
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
module ServerCore where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
import Network
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import Control.Concurrent
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Control.Concurrent.STM
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Control.Concurrent.Chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Control.Monad
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import qualified Data.IntMap as IntMap
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import System.Log.Logger
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import NetRoutines
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import Utils
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import HWProtoCore
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
import Actions
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    16
import OfficialServer.DBInteraction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    18
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    19
timerLoop :: Chan CoreMessage -> IO()
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    20
timerLoop messagesChan = forever $ do
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    21
	threadDelay (30 * 10^6) -- 30 seconds
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    22
	writeChan messagesChan TimerAction
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    23
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    24
firstAway (_, a, b, c) = (a, b, c)
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    25
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms)
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    27
reactCmd serverInfo clID cmd clients rooms =
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    28
	liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    30
mainLoop :: ServerInfo -> Clients -> Rooms -> IO ()
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    31
mainLoop serverInfo clients rooms = do
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    32
	r <- readChan $ coreChan serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
	
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
	(newServerInfo, mClients, mRooms) <-
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
		case r of
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
			Accept ci -> do
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    37
				liftM firstAway $ processAction
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1841
diff changeset
    38
					(clientUID ci, serverInfo, clients, rooms) (AddClient ci)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
			ClientMessage (clID, cmd) -> do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
				debugM "Clients" $ (show clID) ++ ": " ++ (show cmd)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
				if clID `IntMap.member` clients then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
					reactCmd serverInfo clID cmd clients rooms
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    44
					else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
					do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
					debugM "Clients" "Message from dead client"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
					return (serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    49
			ClientAccountInfo clID info ->
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    50
				if clID `IntMap.member` clients then
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    51
					liftM firstAway $ processAction
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    52
						(clID, serverInfo, clients, rooms)
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    53
						(ProcessAccountInfo info)
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    54
					else
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    55
					do
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    56
					debugM "Clients" "Got info for dead client"
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    57
					return (serverInfo, clients, rooms)
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    58
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    59
			TimerAction ->
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    60
				liftM firstAway $ processAction
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    61
						(0, serverInfo, clients, rooms)
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    62
						PingAll
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    63
			
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    64
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
	{-			let hadRooms = (not $ null rooms) && (null mrooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
					in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    67
						mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    68
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    69
	mainLoop newServerInfo mClients mRooms
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    71
startServer :: ServerInfo -> Socket -> IO ()
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    72
startServer serverInfo serverSocket = do
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
	putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    74
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    75
	forkIO $
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    76
		acceptLoop
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    77
			serverSocket
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    78
			(coreChan serverInfo)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    79
			0
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    80
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    81
	return ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
	
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    83
	forkIO $ timerLoop $ coreChan serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    84
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    85
	startDBConnection $ serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    86
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    87
	mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom)