--- 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