diff -r 6af73e7f2438 -r 4e4f88a7bdf2 gameServer/ServerCore.hs --- a/gameServer/ServerCore.hs Thu May 06 15:26:14 2010 +0000 +++ b/gameServer/ServerCore.hs Thu May 06 17:39:08 2010 +0000 @@ -6,58 +6,61 @@ import Control.Monad import qualified Data.IntMap as IntMap import System.Log.Logger +import Control.Monad.Reader -------------------------------------- import CoreTypes import NetRoutines import HWProtoCore import Actions import OfficialServer.DBInteraction +import RoomsAndClients timerLoop :: Int -> Chan CoreMessage -> IO() timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan -firstAway (_, a, b, c) = (a, b, c) -reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) -reactCmd serverInfo clID cmd clients rooms = - liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd +reactCmd :: ServerInfo -> ClientIndex -> [String] -> MRnC -> IO () +reactCmd sInfo ci cmd rnc = do + actions <- withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) + forM_ actions (processAction (ci, sInfo, rnc)) -mainLoop :: ServerInfo -> Clients -> Rooms -> IO () -mainLoop serverInfo clients rooms = do +mainLoop :: ServerInfo -> MRnC -> IO () +mainLoop serverInfo rnc = forever $ do r <- readChan $ coreChan serverInfo - (newServerInfo, mClients, mRooms) <- - case r of - Accept ci -> - liftM firstAway $ processAction - (clientUID ci, serverInfo, clients, rooms) (AddClient ci) + case r of + Accept ci -> do + processAction + (undefined, serverInfo, rnc) (AddClient ci) + return () - 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) + ClientMessage (clID, cmd) -> do + debugM "Clients" $ (show clID) ++ ": " ++ (show cmd) + --if clID `IntMap.member` clients then + reactCmd serverInfo clID cmd rnc + return () + --else + --do + --debugM "Clients" "Message from dead client" + --return (serverInfo, rnc) - ClientAccountInfo (clID, info) -> - if clID `IntMap.member` clients then - liftM firstAway $ processAction - (clID, serverInfo, clients, rooms) - (ProcessAccountInfo info) - else - do - debugM "Clients" "Got info for dead client" - return (serverInfo, clients, rooms) + ClientAccountInfo (clID, info) -> do + --if clID `IntMap.member` clients then + processAction + (clID, serverInfo, rnc) + (ProcessAccountInfo info) + return () + --else + --do + --debugM "Clients" "Got info for dead client" + --return (serverInfo, rnc) - TimerAction tick -> - liftM firstAway $ - foldM processAction (0, serverInfo, clients, rooms) $ - PingAll : [StatsAction | even tick] - - mainLoop newServerInfo mClients mRooms + TimerAction tick -> + return () + --liftM snd $ + -- foldM processAction (0, serverInfo, rnc) $ + -- PingAll : [StatsAction | even tick] startServer :: ServerInfo -> Socket -> IO () startServer serverInfo serverSocket = do @@ -67,14 +70,15 @@ acceptLoop serverSocket (coreChan serverInfo) - 0 return () - + forkIO $ timerLoop 0 $ coreChan serverInfo startDBConnection serverInfo - forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom) + rnc <- newRoomsAndClients newRoom + + forkIO $ mainLoop serverInfo rnc forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"