gameServer/ServerCore.hs
author unc0rr
Mon, 23 Feb 2009 20:25:07 +0000
changeset 1833 e901ec5644b4
parent 1804 4e78ad846fb6
child 1839 5dd4cb7fd7e5
permissions -rw-r--r--
Add options for configuring database access
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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
reactCmd serverInfo clID cmd clients rooms = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
	(_ , serverInfo, clients, rooms) <-
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
		foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
	return (serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
mainLoop :: Chan CoreMessage -> ServerInfo -> Clients -> Rooms -> IO ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    25
mainLoop coreChan serverInfo clients rooms = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
	r <- readChan coreChan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
	
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
	(newServerInfo, mClients, mRooms) <-
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
		case r of
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
			Accept ci -> do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
				let updatedClients = IntMap.insert (clientUID ci) ci clients
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
				--infoM "Clients" ("New client: id " ++ (show $ clientUID ci))
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
				processAction
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
					(clientUID ci, serverInfo, updatedClients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
					(AnswerThisClient ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"])
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
				return (serverInfo, updatedClients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
			ClientMessage (clID, cmd) -> do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
				debugM "Clients" $ (show clID) ++ ": " ++ (show cmd)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
				if clID `IntMap.member` clients then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
					reactCmd serverInfo clID cmd clients rooms
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
					else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
					do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    44
					debugM "Clients" "Message from dead client"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
					return (serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
	{-			let hadRooms = (not $ null rooms) && (null mrooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
					in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
						mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    50
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
	mainLoop coreChan newServerInfo mClients mRooms
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
startServer :: ServerInfo -> Chan CoreMessage -> Socket -> IO ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
startServer serverInfo coreChan serverSocket = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
	putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
	forkIO $
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
		acceptLoop
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    59
			serverSocket
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
			coreChan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    61
			0
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    63
	return ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    64
	
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
{-	forkIO $ messagesLoop messagesChan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
	forkIO $ timerLoop messagesChan-}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    67
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    68
	startDBConnection $ serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    69
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
	mainLoop coreChan serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    72
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73