--- a/gameServer/Actions.hs Thu Jan 27 22:10:24 2011 +0300
+++ b/gameServer/Actions.hs Thu Jan 27 22:14:14 2011 +0300
@@ -68,7 +68,7 @@
processAction (AnswerClients chans msg) = do
- liftIO $ mapM_ (flip writeChan msg) chans
+ io $ mapM_ (flip writeChan msg) chans
processAction SendServerMessage = do
@@ -116,7 +116,7 @@
processAction $ MoveToLobby ("quit: " `B.append` msg)
return ()
- liftIO $ do
+ io $ do
infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg))
--mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
@@ -128,7 +128,7 @@
processAction (DeleteClient ci) = do
rnc <- gets roomsClients
- liftIO $ removeClient rnc ci
+ io $ removeClient rnc ci
s <- get
put $! s{removedClients = ci `Set.delete` removedClients s}
@@ -158,19 +158,19 @@
processAction (ModifyClient f) = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
- liftIO $ modifyClient rnc f ci
+ io $ modifyClient rnc f ci
return ()
processAction (ModifyClient2 ci f) = do
rnc <- gets roomsClients
- liftIO $ modifyClient rnc f ci
+ io $ modifyClient rnc f ci
return ()
processAction (ModifyRoom f) = do
rnc <- gets roomsClients
ri <- clientRoomA
- liftIO $ modifyRoom rnc f ri
+ io $ modifyRoom rnc f ri
return ()
{-
@@ -184,7 +184,7 @@
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
- liftIO $ do
+ io $ do
modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci
modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri
moveClientToRoom rnc ri ci
@@ -213,7 +213,7 @@
chans <- othersChans
mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
- liftIO $ do
+ io $ do
modifyRoom rnc (\r -> r{
playersIn = (playersIn r) - 1,
readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
@@ -272,7 +272,7 @@
processAction (AddRoom roomName roomPassword) = do
Just clId <- gets clientIndex
rnc <- gets roomsClients
- proto <- liftIO $ client'sM rnc clientProto clId
+ proto <- io $ client'sM rnc clientProto clId
let room = newRoom{
masterID = clId,
@@ -281,7 +281,7 @@
roomProto = proto
}
- rId <- liftIO $ addRoom rnc room
+ rId <- io $ addRoom rnc room
processAction $ MoveToRoom rId
@@ -296,8 +296,8 @@
processAction RemoveRoom = do
Just clId <- gets clientIndex
rnc <- gets roomsClients
- ri <- liftIO $ clientRoomM rnc clId
- roomName <- liftIO $ room'sM rnc name ri
+ ri <- io $ clientRoomM rnc clId
+ roomName <- io $ room'sM rnc name ri
others <- othersChans
lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId
@@ -306,16 +306,16 @@
AnswerClients others ["ROOMABANDONED", roomName]
]
- liftIO $ removeRoom rnc ri
+ io $ removeRoom rnc ri
processAction (UnreadyRoomClients) = do
rnc <- gets roomsClients
ri <- clientRoomA
roomPlayers <- roomClientsS ri
- roomClIDs <- liftIO $ roomClientsIndicesM rnc ri
+ roomClIDs <- io $ roomClientsIndicesM rnc ri
processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers)
- liftIO $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
+ io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
@@ -323,7 +323,7 @@
rnc <- gets roomsClients
cl <- client's id
ri <- clientRoomA
- inGame <- liftIO $ room'sM rnc gameinprogress ri
+ inGame <- io $ room'sM rnc gameinprogress ri
chans <- othersChans
if inGame then
mapM_ processAction [
@@ -346,7 +346,7 @@
processAction (RemoveClientTeams clId) = do
rnc <- gets roomsClients
- removeTeamActions <- liftIO $ do
+ removeTeamActions <- io $ do
clNick <- client'sM rnc nick clId
rId <- clientRoomM rnc clId
roomTeams <- room'sM rnc teams rId
@@ -361,13 +361,13 @@
n <- client's nick
h <- client's host
db <- gets (dbQueries . serverInfo)
- liftIO $ writeChan db $ CheckAccount ci n h
+ io $ writeChan db $ CheckAccount ci n h
return ()
processAction ClearAccountsCache = do
dbq <- gets (dbQueries . serverInfo)
- liftIO $ writeChan dbq ClearCache
+ io $ writeChan dbq ClearCache
return ()
@@ -426,7 +426,7 @@
processAction (AddClient client) = do
rnc <- gets roomsClients
si <- gets serverInfo
- liftIO $ do
+ io $ do
ci <- addClient rnc client
t <- forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci
forkIO $ clientSendLoop (clientSocket client) t (coreChan si) (sendChan client) ci
@@ -446,14 +446,14 @@
processAction PingAll = do
rnc <- gets roomsClients
- liftIO (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
- cis <- liftIO $ allClientsM rnc
- chans <- liftIO $ mapM (client'sM rnc sendChan) cis
- liftIO $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
+ io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
+ cis <- io $ allClientsM rnc
+ chans <- io $ mapM (client'sM rnc sendChan) cis
+ io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
processAction $ AnswerClients chans ["PING"]
where
kickTimeouted rnc ci = do
- pq <- liftIO $ client'sM rnc pingsQueue ci
+ pq <- io $ client'sM rnc pingsQueue ci
when (pq > 0) $
withStateT (\as -> as{clientIndex = Just ci}) $
processAction (ByeClient "Ping timeout")
@@ -462,8 +462,8 @@
processAction (StatsAction) = do
rnc <- gets roomsClients
si <- gets serverInfo
- (roomsNum, clientsNum) <- liftIO $ withRoomsAndClients rnc stats
- liftIO $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
+ (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc stats
+ io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
where
stats irnc = (length $ allRooms irnc, length $ allClients irnc)
--- a/gameServer/ServerState.hs Thu Jan 27 22:10:24 2011 +0300
+++ b/gameServer/ServerState.hs Thu Jan 27 22:14:14 2011 +0300
@@ -5,7 +5,8 @@
ServerState(..),
client's,
allClientsS,
- roomClientsS
+ roomClientsS,
+ io
) where
import Control.Monad.State.Strict
@@ -41,3 +42,6 @@
roomClientsS ri = do
rnc <- gets roomsClients
liftIO $ roomClientsM rnc ri
+
+io :: IO a -> StateT ServerState IO a
+io = liftIO
--- a/gameServer/Utils.hs Thu Jan 27 22:10:24 2011 +0300
+++ b/gameServer/Utils.hs Thu Jan 27 22:14:14 2011 +0300
@@ -14,6 +14,7 @@
import System.IO
import qualified Data.List as List
import Control.Monad
+import Control.Monad.Trans
import Data.Maybe
-------------------------------------------------
import qualified Codec.Binary.Base64 as Base64
@@ -121,5 +122,3 @@
showB :: Show a => a -> B.ByteString
showB = B.pack .show
-
-io = liftIO