io = liftIO server_refactor
authorunc0rr
Thu, 27 Jan 2011 22:14:14 +0300
branchserver_refactor
changeset 4601 08ae94dd4c0d
parent 4599 a9e4093a7e78
child 4604 831a4b91e9bc
io = liftIO
gameServer/Actions.hs
gameServer/ServerState.hs
gameServer/Utils.hs
--- 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