--- /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)
+
+
+