--- a/gameServer/Actions.hs Sat May 08 21:50:26 2010 +0000
+++ b/gameServer/Actions.hs Sun May 09 17:53:08 2010 +0000
@@ -9,6 +9,7 @@
import Data.Time
import Maybe
import Control.Monad.Reader
+import Control.Monad.State
-----------------------------
import CoreTypes
@@ -48,14 +49,25 @@
type CmdHandler = [String] -> Reader (ClientIndex, IRnC) [Action]
+data ActionsState = ActionsState {
+ clientIndex :: Maybe ClientIndex,
+ serverInfo :: ServerInfo,
+ roomsClients :: MRnC
+ }
+
+clientRoomA :: StateT ActionsState IO RoomIndex
+clientRoomA = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ liftIO $ clientRoomM rnc ci
+
replaceID a (b, c, d, e) = (a, c, d, e)
-processAction :: (ClientIndex, ServerInfo, MRnC) -> Action -> IO (ClientIndex, ServerInfo)
+processAction :: Action -> StateT ActionsState IO ()
-processAction (ci, serverInfo, rnc) (AnswerClients chans msg) = do
- mapM_ (flip writeChan msg) chans
- return (ci, serverInfo)
+processAction (AnswerClients chans msg) =
+ liftIO $ mapM_ (flip writeChan msg) chans
{-
@@ -91,24 +103,28 @@
return (clID, serverInfo, rnc)
-}
-processAction (ci, serverInfo, rnc) (ByeClient msg) = do
- infoM "Clients" (show ci ++ " quits: " ++ msg)
-
- ri <- clientRoomM rnc ci
+processAction (ByeClient msg) = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ ri <- clientRoomA
when (ri /= lobbyId) $ do
- processAction (ci, serverInfo, rnc) $ RoomRemoveThisClient ("quit: " ++ msg)
+ processAction $ RoomRemoveThisClient ("quit: " ++ msg)
return ()
- --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
- --writeChan (sendChan $ clients ! clID) ["BYE", msg]
- modifyRoom rnc (\r -> r{
- --playersIDs = IntSet.delete ci (playersIDs r)
- playersIn = (playersIn r) - 1
- --readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r
- }) ri
- removeClient rnc ci
-
- return (ci, serverInfo)
+ liftIO $ do
+ infoM "Clients" (show ci ++ " quits: " ++ msg)
+
+ ri <- clientRoomM rnc ci
+
+ --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
+ --writeChan (sendChan $ clients ! clID) ["BYE", msg]
+ modifyRoom rnc (\r -> r{
+ --playersIDs = IntSet.delete ci (playersIDs r)
+ playersIn = (playersIn r) - 1
+ --readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r
+ }) ri
+ removeClient rnc ci
+
{-
where
@@ -360,20 +376,27 @@
removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove
-}
-processAction (_, serverInfo, rnc) (AddClient client) = do
- ci <- addClient rnc client
- forkIO $ clientRecvLoop (clientHandle client) (coreChan serverInfo) ci
- forkIO $ clientSendLoop (clientHandle client) (coreChan serverInfo) (sendChan client) ci
+processAction (AddClient client) = do
+ rnc <- gets roomsClients
+ si <- gets serverInfo
+ liftIO $ do
+ ci <- addClient rnc client
+ forkIO $ clientRecvLoop (clientHandle client) (coreChan si) ci
+ forkIO $ clientSendLoop (clientHandle client) (coreChan si) (sendChan client) ci
+
+ infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client))
+ writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
- infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client))
- writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
-
- let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo
+{- let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo
- if False && (isJust $ host client `Prelude.lookup` newLogins) then
- processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast"
- else
- return (ci, serverInfo)
+ if False && (isJust $ host client `Prelude.lookup` newLogins) then
+ processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast"
+ else
+ return (ci, serverInfo)
+-}
+
+
+
{-
processAction (clID, serverInfo, rnc) PingAll = do
--- a/gameServer/ServerCore.hs Sat May 08 21:50:26 2010 +0000
+++ b/gameServer/ServerCore.hs Sun May 09 17:53:08 2010 +0000
@@ -7,6 +7,7 @@
import qualified Data.IntMap as IntMap
import System.Log.Logger
import Control.Monad.Reader
+import Control.Monad.State
--------------------------------------
import CoreTypes
import NetRoutines
@@ -20,25 +21,28 @@
timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
-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))
+reactCmd :: [String] -> StateT ActionsState IO ()
+reactCmd cmd = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
+ forM_ actions processAction
-mainLoop :: ServerInfo -> MRnC -> IO ()
-mainLoop serverInfo rnc = forever $ do
- r <- readChan $ coreChan serverInfo
+mainLoop :: StateT ActionsState IO ()
+mainLoop = forever $ do
+ si <- gets serverInfo
+ r <- liftIO $ readChan $ coreChan si
case r of
Accept ci -> do
- processAction
- (undefined, serverInfo, rnc) (AddClient ci)
+ processAction (AddClient ci)
return ()
- ClientMessage (clID, cmd) -> do
- debugM "Clients" $ (show clID) ++ ": " ++ (show cmd)
+ ClientMessage (ci, cmd) -> do
+ liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd)
+ modify (\as -> as{clientIndex = Just ci})
--if clID `IntMap.member` clients then
- reactCmd serverInfo clID cmd rnc
+ reactCmd cmd
return ()
--else
--do
@@ -47,9 +51,7 @@
ClientAccountInfo (clID, info) -> do
--if clID `IntMap.member` clients then
- processAction
- (clID, serverInfo, rnc)
- (ProcessAccountInfo info)
+ processAction (ProcessAccountInfo info)
return ()
--else
--do
@@ -79,6 +81,6 @@
rnc <- newRoomsAndClients newRoom
- forkIO $ mainLoop serverInfo rnc
+ forkIO $ evalStateT mainLoop (ActionsState Nothing serverInfo rnc)
forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"