--- a/gameServer/Actions.hs Sun Jun 06 15:29:33 2010 +0000
+++ b/gameServer/Actions.hs Sun Jun 06 19:03:06 2010 +0000
@@ -58,16 +58,16 @@
liftIO $ mapM_ (flip writeChan msg) chans
-{-
-processAction (clID, serverInfo, rnc) SendServerMessage = do
- writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo]
- return (clID, serverInfo, rnc)
- where
- client = clients ! clID
- message si = if clientProto client < latestReleaseVersion si then
+processAction SendServerMessage = do
+ chan <- client's sendChan
+ protonum <- client's clientProto
+ si <- liftM serverInfo get
+ let message = if protonum < latestReleaseVersion si then
serverMessageForOldVersions si
else
serverMessage si
+ liftIO $ writeChan chan ["SERVER_MESSAGE", message]
+{-
processAction (clID, serverInfo, rnc) SendServerVars = do
writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)
@@ -81,15 +81,16 @@
]
-processAction (clID, serverInfo, rnc) (ProtocolError msg) = do
- writeChan (sendChan $ clients ! clID) ["ERROR", msg]
- return (clID, serverInfo, rnc)
+-}
+
+processAction (ProtocolError msg) = do
+ chan <- client's sendChan
+ liftIO $ writeChan chan ["ERROR", msg]
-processAction (clID, serverInfo, rnc) (Warning msg) = do
- writeChan (sendChan $ clients ! clID) ["WARNING", msg]
- return (clID, serverInfo, rnc)
--}
+processAction (Warning msg) = do
+ chan <- client's sendChan
+ liftIO $ writeChan chan ["WARNING", msg]
processAction (ByeClient msg) = do
(Just ci) <- gets clientIndex
@@ -99,7 +100,7 @@
processAction $ RoomRemoveThisClient ("quit: " `B.append` msg)
return ()
- chan <- clients sendChan
+ chan <- client's sendChan
liftIO $ do
infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg))
@@ -297,8 +298,8 @@
processAction CheckRegistered = do
(Just ci) <- gets clientIndex
- n <- clients nick
- h <- clients host
+ n <- client's nick
+ h <- client's host
db <- gets (dbQueries . serverInfo)
liftIO $ writeChan db $ CheckAccount ci n h
return ()
@@ -314,33 +315,29 @@
processAction (clID, serverInfo, rnc) (Dump) = do
writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
return (clID, serverInfo, rnc)
-
+-}
-processAction (clID, serverInfo, rnc) (ProcessAccountInfo info) =
+processAction (ProcessAccountInfo info) =
case info of
HasAccount passwd isAdmin -> do
- infoM "Clients" $ show clID ++ " has account"
- writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]
- return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID rnc)
+ chan <- client's sendChan
+ liftIO $ writeChan chan ["ASKPASSWORD"]
Guest -> do
- infoM "Clients" $ show clID ++ " is guest"
- processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID rnc) MoveToLobby
+ mapM_ processAction [ModifyClient (\cl -> cl{logonPassed = True}), MoveToLobby]
Admin -> do
- infoM "Clients" $ show clID ++ " is admin"
- foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID rnc) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]]
-
+ mapM processAction [ModifyClient (\cl -> cl{logonPassed = True, isAdministrator = True}), MoveToLobby]
+ chan <- client's sendChan
+ liftIO $ writeChan chan ["ADMIN_ACCESS"]
-processAction (clID, serverInfo, rnc) (MoveToLobby) =
- foldM processAction (clID, serverInfo, rnc) $
- (RoomAddThisClient 0)
- : answerLobbyNicks
+processAction MoveToLobby = do
+ chan <- client's sendChan
+ lobbyNicks <- liftM (Prelude.map nick . Prelude.filter logonPassed) allClientsS
+ mapM_ processAction $
+-- (RoomAddThisClient 0)
+ [AnswerClients [chan] ("LOBBY:JOINED" : lobbyNicks) | not $ Prelude.null lobbyNicks]
++ [SendServerMessage]
- -- ++ (answerServerMessage client clients)
- where
- lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients
- answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]
-
+{-
processAction (clID, serverInfo, rnc) (KickClient kickID) =
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked")
--- a/gameServer/ClientIO.hs Sun Jun 06 15:29:33 2010 +0000
+++ b/gameServer/ClientIO.hs Sun Jun 06 19:03:06 2010 +0000
@@ -39,7 +39,7 @@
where
recieveWithBufferLoop recvBuf = do
recvBS <- recv sock 4096
- putStrLn $ show sock ++ " got smth: " ++ (show $ B.length recvBS)
+-- putStrLn $ show sock ++ " got smth: " ++ (show $ B.length recvBS)
unless (B.null recvBS) $ do
let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS
forM_ packets sendPacket
--- a/gameServer/CoreTypes.hs Sun Jun 06 15:29:33 2010 +0000
+++ b/gameServer/CoreTypes.hs Sun Jun 06 19:03:06 2010 +0000
@@ -70,7 +70,7 @@
data RoomInfo =
RoomInfo
{
- masterID :: !Int,
+ masterID :: ClientIndex,
name :: B.ByteString,
password :: B.ByteString,
roomProto :: Word16,
@@ -96,7 +96,7 @@
newRoom :: RoomInfo
newRoom = (
RoomInfo
- 0
+ undefined
""
""
0
@@ -124,7 +124,7 @@
ServerInfo
{
isDedicated :: Bool,
- serverMessage :: String,
+ serverMessage :: B.ByteString,
serverMessageForOldVersions :: B.ByteString,
latestReleaseVersion :: Word16,
listenPort :: PortNumber,
--- a/gameServer/HWProtoLobbyState.hs Sun Jun 06 15:29:33 2010 +0000
+++ b/gameServer/HWProtoLobbyState.hs Sun Jun 06 19:03:06 2010 +0000
@@ -2,17 +2,19 @@
module HWProtoLobbyState where
import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Foldable as Foldable
import Maybe
import Data.List
import Data.Word
+import Control.Monad.Reader
+import qualified Data.ByteString.Char8 as B
--------------------------------------
import CoreTypes
import Actions
import Utils
import HandlerUtils
+import RoomsAndClients
{-answerAllTeams protocol teams = concatMap toAnswer teams
where
@@ -23,32 +25,31 @@
-}
handleCmd_lobby :: CmdHandler
-{-
-handleCmd_lobby clID clients rooms ["LIST"] =
- [AnswerThisClient ("ROOMS" : roomsInfoList)]
+
+handleCmd_lobby ["LIST"] = do
+ (ci, irnc) <- ask
+ let cl = irnc `client` ci
+ rooms <- allRoomInfos
+ let roomsInfoList = concatMap (roomInfo irnc) . filter (\r -> (roomProto r == clientProto cl) && not (isRestrictedJoins r))
+ return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
where
- roomsInfoList = concatMap roomInfo sameProtoRooms
- sameProtoRooms = filter (\r -> (roomProto r == protocol) && not (isRestrictedJoins r)) roomsList
- roomsList = IntMap.elems rooms
- protocol = clientProto client
- client = clients IntMap.! clID
- roomInfo room
- | clientProto client < 28 = [
+ roomInfo irnc room
+ | roomProto room < 28 = [
name room,
- show (playersIn room) ++ "(" ++ show (length $ teams room) ++ ")",
- show $ gameinprogress room
+ B.pack $ show (playersIn room) ++ "(" ++ show (length $ teams room) ++ ")",
+ B.pack $ show $ gameinprogress room
]
| otherwise = [
- show $ gameinprogress room,
+ showB $ gameinprogress room,
name room,
- show $ playersIn room,
- show $ length $ teams room,
- nick $ clients IntMap.! (masterID room),
+ showB $ playersIn room,
+ showB $ length $ teams room,
+ nick $ irnc `client` (masterID room),
head (Map.findWithDefault ["+gen+"] "MAP" (params room)),
head (Map.findWithDefault ["Default"] "SCHEME" (params room)),
head (Map.findWithDefault ["Default"] "AMMO" (params room))
]
--}
+
handleCmd_lobby ["CHAT", msg] = do
n <- clientNick
--- a/gameServer/HandlerUtils.hs Sun Jun 06 15:29:33 2010 +0000
+++ b/gameServer/HandlerUtils.hs Sun Jun 06 19:03:06 2010 +0000
@@ -28,3 +28,6 @@
answerClient :: [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
answerClient msg = thisClientChans >>= return . (: []) . flip AnswerClients msg
+
+allRoomInfos :: Reader (a, IRnC) [RoomInfo]
+allRoomInfos = liftM ((\irnc -> map (room irnc) $ allRooms irnc) . snd) ask
--- a/gameServer/RoomsAndClients.hs Sun Jun 06 15:29:33 2010 +0000
+++ b/gameServer/RoomsAndClients.hs Sun Jun 06 19:03:06 2010 +0000
@@ -16,9 +16,12 @@
clientRoom,
clientRoomM,
client,
+ room,
+ client'sM,
clientsM,
+ withRoomsAndClients,
+ allRooms,
allClients,
- withRoomsAndClients,
showRooms,
roomClients
) where
@@ -89,10 +92,8 @@
addClient :: MRoomsAndClients r c -> c -> IO ClientIndex
addClient (MRoomsAndClients (rooms, clients)) client = do
i <- addElem clients (Client lobbyId client)
- modifyElem rooms (roomAddClient (ClientIndex i)) rid
+ modifyElem rooms (roomAddClient (ClientIndex i)) (unRoomIndex lobbyId)
return $ ClientIndex i
- where
- rid = (\(RoomIndex i) -> i) lobbyId
removeRoom :: MRoomsAndClients r c -> RoomIndex -> IO ()
removeRoom rnc@(MRoomsAndClients (rooms, _)) room@(RoomIndex ri)
@@ -136,9 +137,11 @@
clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex
clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci)
-clientsM :: MRoomsAndClients r c -> (c -> a) -> ClientIndex -> IO a
-clientsM (MRoomsAndClients (_, clients)) f (ClientIndex ci) = liftM (f . client') (clients `readElem` ci)
+client'sM :: MRoomsAndClients r c -> (c -> a) -> ClientIndex -> IO a
+client'sM (MRoomsAndClients (_, clients)) f (ClientIndex ci) = liftM (f . client') (clients `readElem` ci)
+clientsM :: MRoomsAndClients r c -> IO [c]
+clientsM (MRoomsAndClients (_, clients)) = indicesM clients >>= mapM (\ci -> liftM client' $ readElem clients ci)
withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a
withRoomsAndClients (MRoomsAndClients (rooms, clients)) f =
@@ -160,12 +163,14 @@
allClients :: IRoomsAndClients r c -> [ClientIndex]
allClients (IRoomsAndClients (_, clients)) = map ClientIndex $ indices clients
-
clientRoom :: IRoomsAndClients r c -> ClientIndex -> RoomIndex
clientRoom (IRoomsAndClients (_, clients)) (ClientIndex ci) = clientRoom' (clients ! ci)
client :: IRoomsAndClients r c -> ClientIndex -> c
client (IRoomsAndClients (_, clients)) (ClientIndex ci) = client' (clients ! ci)
+room :: IRoomsAndClients r c -> RoomIndex -> r
+room (IRoomsAndClients (rooms, _)) (RoomIndex ri) = room' (rooms ! ri)
+
roomClients :: IRoomsAndClients r c -> RoomIndex -> [ClientIndex]
roomClients (IRoomsAndClients (rooms, _)) (RoomIndex ri) = roomClients' $ (rooms ! ri)
--- a/gameServer/ServerState.hs Sun Jun 06 15:29:33 2010 +0000
+++ b/gameServer/ServerState.hs Sun Jun 06 19:03:06 2010 +0000
@@ -3,7 +3,8 @@
module RoomsAndClients,
clientRoomA,
ServerState(..),
- clients
+ client's,
+ allClientsS
) where
import Control.Monad.State
@@ -24,9 +25,11 @@
rnc <- gets roomsClients
liftIO $ clientRoomM rnc ci
-clients :: (ClientInfo -> a) -> StateT ServerState IO a
-clients f = do
+client's :: (ClientInfo -> a) -> StateT ServerState IO a
+client's f = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
- liftIO $ clientsM rnc f ci
-
\ No newline at end of file
+ liftIO $ client'sM rnc f ci
+
+allClientsS :: StateT ServerState IO [ClientInfo]
+allClientsS = gets roomsClients >>= liftIO . clientsM
\ No newline at end of file
--- a/gameServer/Store.hs Sun Jun 06 15:29:33 2010 +0000
+++ b/gameServer/Store.hs Sun Jun 06 19:03:06 2010 +0000
@@ -9,6 +9,7 @@
writeElem,
modifyElem,
firstIndex,
+ indicesM,
withIStore,
withIStore2,
(!),
@@ -94,6 +95,12 @@
IOA.readArray arr n >>= (IOA.writeArray arr n) . f
+indicesM :: MStore e -> IO [ElemIndex]
+indicesM (MStore ref) = do
+ (busy, _, _) <- readIORef ref
+ return $ map ElemIndex $ IntSet.toList busy
+
+
-- A way to use see MStore elements in pure code via IStore
m2i :: MStore e -> IO (IStore e)
m2i (MStore ref) = do
@@ -101,6 +108,7 @@
c <- IOA.unsafeFreeze c'
return $ IStore (a, c)
+
withIStore :: MStore e -> (IStore e -> a) -> IO a
withIStore m f = liftM f (m2i m)
--- a/gameServer/Utils.hs Sun Jun 06 15:29:33 2010 +0000
+++ b/gameServer/Utils.hs Sun Jun 06 19:03:06 2010 +0000
@@ -119,3 +119,6 @@
case f b of
Right (a, new_b) -> let (a', b') = unfoldrE f new_b in (a : a', b')
Left new_b -> ([], new_b)
+
+showB :: Show a => a -> B.ByteString
+showB = B.pack .show