gameServer/ServerCore.hs
changeset 1804 4e78ad846fb6
child 1833 e901ec5644b4
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/ServerCore.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,72 @@
+module ServerCore where
+
+import Network
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Concurrent.Chan
+import Control.Monad
+import qualified Data.IntMap as IntMap
+import System.Log.Logger
+--------------------------------------
+import CoreTypes
+import NetRoutines
+import Utils
+import HWProtoCore
+import Actions
+
+reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms)
+reactCmd serverInfo clID cmd clients rooms = do
+	(_ , serverInfo, clients, rooms) <-
+		foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd
+	return (serverInfo, clients, rooms)
+
+mainLoop :: Chan CoreMessage -> ServerInfo -> Clients -> Rooms -> IO ()
+mainLoop coreChan serverInfo clients rooms = do
+	r <- readChan coreChan
+	
+	(newServerInfo, mClients, mRooms) <-
+		case r of
+			Accept ci -> do
+				let updatedClients = IntMap.insert (clientUID ci) ci clients
+				--infoM "Clients" ("New client: id " ++ (show $ clientUID ci))
+				processAction
+					(clientUID ci, serverInfo, updatedClients, rooms)
+					(AnswerThisClient ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"])
+				return (serverInfo, updatedClients, rooms)
+
+			ClientMessage (clID, cmd) -> do
+				debugM "Clients" $ (show clID) ++ ": " ++ (show cmd)
+				if clID `IntMap.member` clients then
+					reactCmd serverInfo clID cmd clients rooms
+					else
+					do
+					debugM "Clients" "Message from dead client"
+					return (serverInfo, clients, rooms)
+
+	{-			let hadRooms = (not $ null rooms) && (null mrooms)
+					in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
+						mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -}
+
+	mainLoop coreChan newServerInfo mClients mRooms
+
+startServer :: ServerInfo -> Chan CoreMessage -> Socket -> IO ()
+startServer serverInfo coreChan serverSocket = do
+	putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
+
+	forkIO $
+		acceptLoop
+			serverSocket
+			coreChan
+			0
+
+	return ()
+	
+{-	forkIO $ messagesLoop messagesChan
+	forkIO $ timerLoop messagesChan-}
+
+--	startDBConnection $ dbQueries serverInfo
+
+	mainLoop coreChan serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
+
+
+