--- a/gameServer/Actions.hs Sat Jun 26 16:58:19 2010 +0400
+++ b/gameServer/Actions.hs Sun Jun 27 21:06:41 2010 +0400
@@ -4,6 +4,7 @@
import Control.Concurrent
import Control.Concurrent.Chan
import qualified Data.IntSet as IntSet
+import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import System.Log.Logger
import Monad
@@ -19,7 +20,7 @@
import ServerState
data Action =
- AnswerClients [ClientChan] [B.ByteString]
+ AnswerClients ![ClientChan] ![B.ByteString]
| SendServerMessage
| SendServerVars
| MoveToRoom RoomIndex
@@ -45,6 +46,7 @@
| ProcessAccountInfo AccountInfo
| Dump
| AddClient ClientInfo
+ | DeleteClient ClientIndex
| PingAll
| StatsAction
@@ -101,19 +103,26 @@
return ()
chan <- client's sendChan
+ ready <- client's isReady
liftIO $ do
infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg))
-
--mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
writeChan chan ["BYE", msg]
modifyRoom rnc (\r -> r{
--playersIDs = IntSet.delete ci (playersIDs r)
- playersIn = (playersIn r) - 1
- --readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r
+ playersIn = (playersIn r) - 1,
+ readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
}) ri
-
+
+ removeClient rnc ci
+
+ modify (\s -> s{removedClients = ci `Set.insert` removedClients s})
+
+processAction (DeleteClient ci) = do
+ modify (\s -> s{removedClients = ci `Set.delete` removedClients s})
+
{-
where
client = clients ! clID
@@ -227,7 +236,8 @@
-}
processAction (AddRoom roomName roomPassword) = do
- (ServerState (Just clId) _ rnc) <- get
+ Just clId <- gets clientIndex
+ rnc <- gets roomsClients
proto <- liftIO $ client'sM rnc clientProto clId
let room = newRoom{
@@ -335,10 +345,10 @@
processAction JoinLobby = do
chan <- client's sendChan
clientNick <- client's nick
- (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) allClientsS
+ (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) $! allClientsS
mapM_ processAction $
(AnswerClients clientsChans ["LOBBY:JOINED", clientNick])
- : [AnswerClients [chan] ("LOBBY:JOINED" : lobbyNicks) | not $ Prelude.null lobbyNicks]
+ : [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
{-
--- a/gameServer/ClientIO.hs Sat Jun 26 16:58:19 2010 +0400
+++ b/gameServer/ClientIO.hs Sun Jun 27 21:06:41 2010 +0400
@@ -32,7 +32,7 @@
Left bufTail
else
Right (B.splitWith (== '\n') bsPacket, bufTail)
-
+
listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
listenLoop sock chan ci = recieveWithBufferLoop B.empty
@@ -53,7 +53,7 @@
msg <- (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show)
clientOff msg
where
- clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg])
+ clientOff msg = mapM_ (writeChan chan) [ClientMessage (ci, ["QUIT", msg]), Remove ci]
--- a/gameServer/CoreTypes.hs Sat Jun 26 16:58:19 2010 +0400
+++ b/gameServer/CoreTypes.hs Sun Jun 27 21:06:41 2010 +0400
@@ -173,7 +173,7 @@
| ClientMessage (ClientIndex, [B.ByteString])
| ClientAccountInfo (ClientIndex, AccountInfo)
| TimerAction Int
- | FreeClient ClientIndex
+ | Remove ClientIndex
type MRnC = MRoomsAndClients RoomInfo ClientInfo
type IRnC = IRoomsAndClients RoomInfo ClientInfo
--- a/gameServer/HWProtoInRoomState.hs Sat Jun 26 16:58:19 2010 +0400
+++ b/gameServer/HWProtoInRoomState.hs Sun Jun 27 21:06:41 2010 +0400
@@ -48,7 +48,7 @@
clChan <- thisClientChans
othersChans <- roomOthersChans
return $
- if null . drop 5 $ teams r then
+ if not . null . drop 5 $ teams r then
[Warning "too many teams"]
else if canAddNumber r <= 0 then
[Warning "too many hedgehogs"]
@@ -73,6 +73,7 @@
Just (i, t) | B.null t -> fromIntegral i
otherwise -> 0
hhsList [] = []
+ hhsList [_] = error "Hedgehogs list with odd elements number"
hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
newTeamHHNum r = min 4 (canAddNumber r)
--- a/gameServer/HWProtoLobbyState.hs Sat Jun 26 16:58:19 2010 +0400
+++ b/gameServer/HWProtoLobbyState.hs Sun Jun 27 21:06:41 2010 +0400
@@ -33,13 +33,7 @@
let roomsInfoList = concatMap (roomInfo irnc) . filter (\r -> (roomProto r == clientProto cl) && not (isRestrictedJoins r))
return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
where
- roomInfo irnc room
- | roomProto room < 28 = [
- name room,
- B.pack $ show (playersIn room) ++ "(" ++ show (length $ teams room) ++ ")",
- B.pack $ show $ gameinprogress room
- ]
- | otherwise = [
+ roomInfo irnc room = [
showB $ gameinprogress room,
name room,
showB $ playersIn room,
--- a/gameServer/HWProtoNEState.hs Sat Jun 26 16:58:19 2010 +0400
+++ b/gameServer/HWProtoNEState.hs Sun Jun 27 21:06:41 2010 +0400
@@ -35,9 +35,9 @@
(ci, irnc) <- ask
let cl = irnc `client` ci
if clientProto cl > 0 then return [ProtocolError "Protocol already known"]
- else
+ else
if parsedProto == 0 then return [ProtocolError "Bad number"]
- else
+ else
return $
ModifyClient (\c -> c{clientProto = parsedProto}) :
AnswerClients [sendChan cl] ["PROTO", B.pack $ show parsedProto] :
--- a/gameServer/RoomsAndClients.hs Sat Jun 26 16:58:19 2010 +0400
+++ b/gameServer/RoomsAndClients.hs Sun Jun 27 21:06:41 2010 +0400
@@ -48,7 +48,7 @@
newtype RoomIndex = RoomIndex ElemIndex
deriving (Eq)
newtype ClientIndex = ClientIndex ElemIndex
- deriving (Eq, Show, Read)
+ deriving (Eq, Show, Read, Ord)
instance Show RoomIndex where
show (RoomIndex i) = 'r' : show i
--- a/gameServer/ServerCore.hs Sat Jun 26 16:58:19 2010 +0400
+++ b/gameServer/ServerCore.hs Sun Jun 27 21:06:41 2010 +0400
@@ -8,6 +8,7 @@
import System.Log.Logger
import Control.Monad.Reader
import Control.Monad.State
+import Data.Set as Set
import qualified Data.ByteString.Char8 as B
--------------------------------------
import CoreTypes
@@ -35,29 +36,27 @@
r <- liftIO $ readChan $ coreChan si
case r of
- Accept ci -> do
- processAction (AddClient ci)
- return ()
+ Accept ci -> processAction (AddClient ci)
ClientMessage (ci, cmd) -> do
liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd)
- modify (\as -> as{clientIndex = Just ci})
- --if clID `IntMap.member` clients then
- reactCmd cmd
- return ()
+
+ removed <- gets removedClients
+ when (not $ ci `Set.member` removed) $ do
+ modify (\as -> as{clientIndex = Just ci})
+ reactCmd cmd
+
+ Remove ci -> processAction (DeleteClient ci)
+
--else
--do
--debugM "Clients" "Message from dead client"
--return (serverInfo, rnc)
- ClientAccountInfo (clID, info) -> do
- --if clID `IntMap.member` clients then
- processAction (ProcessAccountInfo info)
- return ()
- --else
- --do
- --debugM "Clients" "Got info for dead client"
- --return (serverInfo, rnc)
+ ClientAccountInfo (ci, info) -> do
+ removed <- gets removedClients
+ when (not $ ci `Set.member` removed) $
+ processAction (ProcessAccountInfo info)
TimerAction tick ->
return ()
@@ -65,10 +64,6 @@
-- foldM processAction (0, serverInfo, rnc) $
-- PingAll : [StatsAction | even tick]
- FreeClient ci -> do
- rnc <- gets roomsClients
- liftIO $ removeClient rnc ci
-
startServer :: ServerInfo -> Socket -> IO ()
startServer serverInfo serverSocket = do
@@ -87,6 +82,6 @@
rnc <- newRoomsAndClients newRoom
- forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo rnc)
+ forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo Set.empty rnc)
forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"
--- a/gameServer/ServerState.hs Sat Jun 26 16:58:19 2010 +0400
+++ b/gameServer/ServerState.hs Sun Jun 27 21:06:41 2010 +0400
@@ -9,6 +9,7 @@
) where
import Control.Monad.State
+import Data.Set as Set
----------------------
import RoomsAndClients
import CoreTypes
@@ -16,6 +17,7 @@
data ServerState = ServerState {
clientIndex :: Maybe ClientIndex,
serverInfo :: ServerInfo,
+ removedClients :: Set.Set ClientIndex,
roomsClients :: MRnC
}
--- a/gameServer/Store.hs Sat Jun 26 16:58:19 2010 +0400
+++ b/gameServer/Store.hs Sun Jun 27 21:06:41 2010 +0400
@@ -24,7 +24,7 @@
newtype ElemIndex = ElemIndex Int
- deriving (Eq, Show, Read)
+ deriving (Eq, Show, Read, Ord)
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e))
newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e)
@@ -105,7 +105,7 @@
m2i :: MStore e -> IO (IStore e)
m2i (MStore ref) = do
(a, _, c') <- readIORef ref
- c <- IOA.unsafeFreeze c'
+ c <- IOA.freeze c'
return $ IStore (a, c)