diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/ServerCore.hs --- /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) + + +