# HG changeset patch # User unc0rr # Date 1276021249 0 # Node ID ad38c653b7d9b356e9572bcd24f88a8e4f8555ae # Parent a3159a410e5c9a87bda4548a3d4dd989c60835c4 Some more progress diff -r a3159a410e5c -r ad38c653b7d9 gameServer/Actions.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") diff -r a3159a410e5c -r ad38c653b7d9 gameServer/CoreTypes.hs --- 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, diff -r a3159a410e5c -r ad38c653b7d9 gameServer/HWProtoLobbyState.hs --- 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)"] diff -r a3159a410e5c -r ad38c653b7d9 gameServer/NetRoutines.hs --- 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 diff -r a3159a410e5c -r ad38c653b7d9 gameServer/RoomsAndClients.hs --- 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)) diff -r a3159a410e5c -r ad38c653b7d9 gameServer/ServerState.hs --- 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