# HG changeset patch # User unc0rr # Date 1277659708 -14400 # Node ID d85bdd5dc835c51ef061dcb28fd52671c110a223 # Parent ae89cf0735dc76c802c1076effac1059490b496b# Parent f7a7ca7270cf16aa910c3e8e202f68aeaa464c12 merge diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/Actions.hs --- a/gameServer/Actions.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/Actions.hs Sun Jun 27 21:28:28 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 @@ -141,7 +150,12 @@ rnc <- gets roomsClients liftIO $ modifyClient rnc f ci return () - + +processAction (ModifyClient2 ci f) = do + rnc <- gets roomsClients + liftIO $ modifyClient rnc f ci + return () + processAction (ModifyRoom f) = do rnc <- gets roomsClients @@ -227,7 +241,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 +350,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] {- diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/ClientIO.hs --- a/gameServer/ClientIO.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/ClientIO.hs Sun Jun 27 21:28:28 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] diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/CoreTypes.hs --- a/gameServer/CoreTypes.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/CoreTypes.hs Sun Jun 27 21:28:28 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 diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/HWProtoInRoomState.hs --- a/gameServer/HWProtoInRoomState.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/HWProtoInRoomState.hs Sun Jun 27 21:28:28 2010 +0400 @@ -43,12 +43,12 @@ | length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"] | otherwise = do (ci, rnc) <- ask - let r = room rnc $ clientRoom rnc ci + r <- thisRoom clNick <- clientNick 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,12 +73,13 @@ 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) handleCmd_inRoom ["REMOVE_TEAM", name] = do (ci, rnc) <- ask - let r = room rnc $ clientRoom rnc ci + r <- thisRoom clNick <- clientNick let maybeTeam = findTeam r @@ -101,37 +102,52 @@ anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams findTeam = find (\t -> name == teamname t) . teams -{- + +handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do + cl <- thisClient + others <- roomOthersChans + r <- thisRoom + + let maybeTeam = findTeam r + let team = fromJust maybeTeam -handleCmd_inRoom clID clients rooms ["HH_NUM", teamName, numberStr] - | not $ isMaster client = [ProtocolError "Not room master"] - | hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) = [] - | otherwise = - [ModifyRoom $ modifyTeam team{hhnum = hhNumber}, - AnswerOthersInRoom ["HH_NUM", teamName, show hhNumber]] + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else if hhNumber < 1 || hhNumber > 8 || isNothing maybeTeam || hhNumber > (canAddNumber r) + (hhnum team) then + [] + else + [ModifyRoom $ modifyTeam team{hhnum = hhNumber}, + AnswerClients others ["HH_NUM", teamName, B.pack $ show hhNumber]] where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int) - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams room - canAddNumber = 48 - (sum . map hhnum $ teams room) + hhNumber = case B.readInt numberStr of + Just (i, t) | B.null t -> fromIntegral i + otherwise -> 0 + findTeam = find (\t -> teamName == teamname t) . teams + canAddNumber = (-) 48 . sum . map hhnum . teams -handleCmd_inRoom clID clients rooms ["TEAM_COLOR", teamName, newColor] - | not $ isMaster client = [ProtocolError "Not room master"] - | noSuchTeam = [] - | otherwise = [ModifyRoom $ modifyTeam team{teamcolor = newColor}, - AnswerOthersInRoom ["TEAM_COLOR", teamName, newColor], + +handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do + cl <- thisClient + others <- roomOthersChans + r <- thisRoom + + let maybeTeam = findTeam r + let team = fromJust maybeTeam + + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else if isNothing maybeTeam then + [] + else + [ModifyRoom $ modifyTeam team{teamcolor = newColor}, + AnswerClients others ["TEAM_COLOR", teamName, newColor], ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})] where - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams room - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) --} + findTeam = find (\t -> teamName == teamname t) . teams + handleCmd_inRoom ["TOGGLE_READY"] = do cl <- thisClient @@ -191,21 +207,26 @@ client = clients IntMap.! clID room = rooms IntMap.! (roomID client) answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room +-} + +handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do + cl <- thisClient + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else + [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})] -handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_JOINS"] - | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})] - | otherwise = [ProtocolError "Not room master"] - where - client = clients IntMap.! clID - +handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do + cl <- thisClient + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else + [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})] -handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_TEAMS"] - | isMaster client = [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})] - | otherwise = [ProtocolError "Not room master"] - where - client = clients IntMap.! clID - +{- handleCmd_inRoom clID clients rooms ["KICK", kickNick] = [KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)] where diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/HWProtoLobbyState.hs --- a/gameServer/HWProtoLobbyState.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/HWProtoLobbyState.hs Sun Jun 27 21:28:28 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, diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/HWProtoNEState.hs --- a/gameServer/HWProtoNEState.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/HWProtoNEState.hs Sun Jun 27 21:28:28 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] : diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/HandlerUtils.hs --- a/gameServer/HandlerUtils.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/HandlerUtils.hs Sun Jun 27 21:28:28 2010 +0400 @@ -12,6 +12,12 @@ (ci, rnc) <- ask return $ rnc `client` ci +thisRoom :: Reader (ClientIndex, IRnC) RoomInfo +thisRoom = do + (ci, rnc) <- ask + let ri = clientRoom rnc ci + return $ rnc `room` ri + clientNick :: Reader (ClientIndex, IRnC) B.ByteString clientNick = liftM nick thisClient diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/RoomsAndClients.hs --- a/gameServer/RoomsAndClients.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/RoomsAndClients.hs Sun Jun 27 21:28:28 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 diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/ServerCore.hs --- a/gameServer/ServerCore.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/ServerCore.hs Sun Jun 27 21:28:28 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 "***" diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/ServerState.hs --- a/gameServer/ServerState.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/ServerState.hs Sun Jun 27 21:28:28 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 } diff -r f7a7ca7270cf -r d85bdd5dc835 gameServer/Store.hs --- a/gameServer/Store.hs Sun Jun 27 18:34:47 2010 +0200 +++ b/gameServer/Store.hs Sun Jun 27 21:28:28 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)