Some more progress
authorunc0rr
Tue, 08 Jun 2010 18:20:49 +0000
changeset 3502 ad38c653b7d9
parent 3501 a3159a410e5c
child 3503 fc0aec1c1b8b
Some more progress
gameServer/Actions.hs
gameServer/CoreTypes.hs
gameServer/HWProtoLobbyState.hs
gameServer/NetRoutines.hs
gameServer/RoomsAndClients.hs
gameServer/ServerState.hs
--- a/gameServer/Actions.hs	Sun Jun 06 19:03:06 2010 +0000
+++ b/gameServer/Actions.hs	Tue Jun 08 18:20:49 2010 +0000
@@ -11,7 +11,7 @@
 import Maybe
 import Control.Monad.Reader
 import Control.Monad.State
-import Data.ByteString.Char8 as B
+import qualified Data.ByteString.Char8 as B
 -----------------------------
 import CoreTypes
 import Utils
@@ -19,27 +19,27 @@
 import ServerState
 
 data Action =
-    AnswerClients [ClientChan] [ByteString]
+    AnswerClients [ClientChan] [B.ByteString]
     | SendServerMessage
     | SendServerVars
-    | RoomAddThisClient RoomIndex -- roomID
-    | RoomRemoveThisClient ByteString
-    | RemoveTeam ByteString
+    | MoveToRoom RoomIndex
+    | RoomRemoveThisClient B.ByteString
+    | RemoveTeam B.ByteString
     | RemoveRoom
     | UnreadyRoomClients
-    | MoveToLobby
-    | ProtocolError ByteString
-    | Warning ByteString
-    | ByeClient ByteString
-    | KickClient ClientIndex -- clID
-    | KickRoomClient ClientIndex -- clID
-    | BanClient ByteString -- nick
-    | RemoveClientTeams ClientIndex -- clID
+    | JoinLobby
+    | ProtocolError B.ByteString
+    | Warning B.ByteString
+    | ByeClient B.ByteString
+    | KickClient ClientIndex
+    | KickRoomClient ClientIndex
+    | BanClient B.ByteString -- nick
+    | RemoveClientTeams ClientIndex
     | ModifyClient (ClientInfo -> ClientInfo)
     | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
     | ModifyRoom (RoomInfo -> RoomInfo)
     | ModifyServerInfo (ServerInfo -> ServerInfo)
-    | AddRoom ByteString ByteString
+    | AddRoom B.ByteString B.ByteString
     | CheckRegistered
     | ClearAccountsCache
     | ProcessAccountInfo AccountInfo
@@ -48,7 +48,7 @@
     | PingAll
     | StatsAction
 
-type CmdHandler = [ByteString] -> Reader (ClientIndex, IRnC) [Action]
+type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
 
 
 processAction :: Action -> StateT ServerState IO ()
@@ -154,23 +154,22 @@
 processAction (clID, serverInfo, rnc) (ModifyServerInfo func) =
     return (clID, func serverInfo, rnc)
 
+-}
 
-processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) =
-    processAction (
-        clID,
-        serverInfo,
-        adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
-        adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
-            adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
-        ) joinMsg
-    where
-        client = clients ! clID
-        joinMsg = if rID == 0 then
-                AnswerAllOthers ["LOBBY:JOINED", nick client]
-            else
-                AnswerThisRoom ["JOINED", nick client]
+processAction (MoveToRoom rId) = do
+    (Just ci) <- gets clientIndex
+    rnc <- gets roomsClients
+    liftIO $ do
+        modifyClient rnc (\cl -> cl{teamsInGame = 0}) ci
+        modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) rId
+        
+    chans <- liftM (map sendChan) $ roomClientsS rId
+     liftio movetoroom
+    clNick <- client's nick
+    
+    processAction $ AnswerClients chans ["JOINED", clNick]
 
-
+{-
 processAction (clID, serverInfo, rnc) (RoomRemoveThisClient msg) = do
     (_, _, newClients, newRooms) <-
         if roomID client /= 0 then
@@ -220,31 +219,29 @@
         otherPlayersSet = IntSet.delete clID (playersIDs room)
         newMasterId = IntSet.findMin otherPlayersSet
         newMasterClient = clients ! newMasterId
-
+-}
 
-processAction (clID, serverInfo, rnc) (AddRoom roomName roomPassword) = do
-    let newServerInfo = serverInfo {nextRoomID = newID}
+processAction (AddRoom roomName roomPassword) = do
+    (ServerState (Just clId) _ rnc) <- get
+    proto <- liftIO $ client'sM rnc clientProto clId
+    
     let room = newRoom{
-            roomUID = newID,
-            masterID = clID,
+            masterID = clId,
             name = roomName,
             password = roomPassword,
-            roomProto = (clientProto client)
+            roomProto = proto
             }
-
-    processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "ADD", roomName]
+            
+    rId <- liftIO $ addRoom rnc room      
+    
+    chans <- liftM (map sendChan) $ roomClientsS lobbyId
 
-    processAction (
-        clID,
-        newServerInfo,
-        adjust (\cl -> cl{isMaster = True}) clID clients,
-        insert newID room rooms
-        ) $ RoomAddThisClient newID
-    where
-        newID = (nextRoomID serverInfo) - 1
-        client = clients ! clID
+    mapM_ processAction [
+        AnswerClients chans ["ROOM", "ADD", roomName]
+        , ModifyClient (\cl -> cl{isMaster = True})
+        , MoveToRoom rId]
 
-
+{-
 processAction (clID, serverInfo, rnc) (RemoveRoom) = do
     processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "DEL", name room]
     processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["ROOMABANDONED", name room]
@@ -323,21 +320,37 @@
             chan <- client's sendChan
             liftIO $ writeChan chan ["ASKPASSWORD"]
         Guest -> do
-            mapM_ processAction [ModifyClient (\cl -> cl{logonPassed = True}), MoveToLobby]
+            processAction JoinLobby
         Admin -> do
-            mapM processAction [ModifyClient (\cl -> cl{logonPassed = True, isAdministrator = True}), MoveToLobby]
+            mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
             chan <- client's sendChan
             liftIO $ writeChan chan ["ADMIN_ACCESS"]
 
-processAction MoveToLobby = do
+
+processAction JoinLobby = do
     chan <- client's sendChan
-    lobbyNicks <- liftM (Prelude.map nick . Prelude.filter logonPassed) allClientsS
+    clientNick <- client's nick
+    (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) allClientsS
     mapM_ processAction $
---        (RoomAddThisClient 0)
-        [AnswerClients [chan] ("LOBBY:JOINED" : lobbyNicks) | not $ Prelude.null lobbyNicks]
-        ++ [SendServerMessage]
+        (AnswerClients clientsChans ["LOBBY:JOINED", clientNick])
+        : [AnswerClients [chan] ("LOBBY:JOINED" : lobbyNicks) | not $ Prelude.null lobbyNicks]
+        ++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
 
 {-
+processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) =
+    processAction (
+        clID,
+        serverInfo,
+        adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
+        adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
+            adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
+        ) joinMsg
+    where
+        client = clients ! clID
+        joinMsg = if rID == 0 then
+                AnswerAllOthers ["LOBBY:JOINED", nick client]
+            else
+                AnswerThisRoom ["JOINED", nick client]
 
 processAction (clID, serverInfo, rnc) (KickClient kickID) =
     liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked")
--- a/gameServer/CoreTypes.hs	Sun Jun 06 19:03:06 2010 +0000
+++ b/gameServer/CoreTypes.hs	Tue Jun 08 18:20:49 2010 +0000
@@ -28,7 +28,7 @@
         webPassword :: B.ByteString,
         logonPassed :: Bool,
         clientProto :: !Word16,
-        roomID :: !Int,
+        roomID :: RoomIndex,
         pingsQueue :: !Word,
         isMaster :: Bool,
         isReady :: Bool,
--- a/gameServer/HWProtoLobbyState.hs	Sun Jun 06 19:03:06 2010 +0000
+++ b/gameServer/HWProtoLobbyState.hs	Tue Jun 08 18:20:49 2010 +0000
@@ -56,23 +56,25 @@
     s <- roomOthersChans
     return [AnswerClients s ["CHAT", n, msg]]
 
-{-
-handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, roomPassword]
-    | haveSameRoom = [Warning "Room exists"]
-    | illegalName newRoom = [Warning "Illegal room name"]
-    | otherwise =
-        [RoomRemoveThisClient "", -- leave lobby
-        AddRoom newRoom roomPassword,
-        AnswerThisClient ["NOT_READY", clientNick]
-        ]
-    where
-        clientNick = nick $ clients IntMap.! clID
-        haveSameRoom = isJust $ find (\room -> newRoom == name room) $ IntMap.elems rooms
+handleCmd_lobby ["CREATE_ROOM", newRoom, roomPassword]
+    | illegalName newRoom = return [Warning "Illegal room name"]
+    | otherwise = do
+        rs <- allRoomInfos
+        (ci, irnc) <- ask
+        let cl =  irnc `client` ci
+        return $ if isJust $ find (\room -> newRoom == name room) rs then 
+            [Warning "Room exists"]
+            else
+            [
+                AddRoom newRoom roomPassword,
+                AnswerClients [sendChan cl] ["NOT_READY", nick cl]
+            ]
 
 
-handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom] =
-    handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, ""]
+handleCmd_lobby ["CREATE_ROOM", newRoom] =
+    handleCmd_lobby ["CREATE_ROOM", newRoom, ""]
 
+{-
 
 handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, roomPassword]
     | noSuchRoom = [Warning "No such room"]
@@ -185,7 +187,7 @@
         [ClearAccountsCache | isAdministrator client]
     where
         client = clients IntMap.! clID
+-}
 
 
-handleCmd_lobby clID _ _ _ = [ProtocolError "Incorrect command (state: in lobby)"]
--}
+handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]
--- a/gameServer/NetRoutines.hs	Sun Jun 06 19:03:06 2010 +0000
+++ b/gameServer/NetRoutines.hs	Tue Jun 08 18:20:49 2010 +0000
@@ -10,6 +10,7 @@
 -----------------------------
 import CoreTypes
 import Utils
+import RoomsAndClients
 
 acceptLoop :: Socket -> Chan CoreMessage -> IO ()
 acceptLoop servSock chan = forever $ do
@@ -34,7 +35,7 @@
                     ""
                     False
                     0
-                    0
+                    lobbyId
                     0
                     False
                     False
--- a/gameServer/RoomsAndClients.hs	Sun Jun 06 19:03:06 2010 +0000
+++ b/gameServer/RoomsAndClients.hs	Tue Jun 08 18:20:49 2010 +0000
@@ -19,6 +19,7 @@
     room,
     client'sM,
     clientsM,
+    roomClientsM,
     withRoomsAndClients,
     allRooms,
     allClients,
@@ -143,6 +144,9 @@
 clientsM :: MRoomsAndClients r c -> IO [c]
 clientsM (MRoomsAndClients (_, clients)) = indicesM clients >>= mapM (\ci -> liftM client' $ readElem clients ci)
 
+roomClientsM :: MRoomsAndClients r c -> RoomIndex -> IO [c]
+roomClientsM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) >>= mapM (\(ClientIndex ci) -> liftM client' $ readElem clients ci)
+
 withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a
 withRoomsAndClients (MRoomsAndClients (rooms, clients)) f =
     withIStore2 rooms clients (\r c -> f $ IRoomsAndClients (r, c))
--- a/gameServer/ServerState.hs	Sun Jun 06 19:03:06 2010 +0000
+++ b/gameServer/ServerState.hs	Tue Jun 08 18:20:49 2010 +0000
@@ -4,7 +4,8 @@
     clientRoomA,
     ServerState(..),
     client's,
-    allClientsS
+    allClientsS,
+    roomClientsS
     ) where
 
 import Control.Monad.State
@@ -32,4 +33,10 @@
     liftIO $ client'sM rnc f ci
     
 allClientsS :: StateT ServerState IO [ClientInfo]
-allClientsS = gets roomsClients >>= liftIO . clientsM
\ No newline at end of file
+allClientsS = gets roomsClients >>= liftIO . clientsM
+
+roomClientsS :: RoomIndex -> StateT ServerState IO [ClientInfo]
+roomClientsS ri = do
+    rnc <- gets roomsClients
+    liftIO $ roomClientsM rnc ri
+    
\ No newline at end of file