# HG changeset patch # User koda # Date 1289551786 -3600 # Node ID 3084dc7b4624f1f857f1eaf1f1ebaf4522362666 # Parent 5e3c5fe2cb1454085ac3397d48028a9fd67ab1a4# Parent bf46b4bdf27dcfae6ea511a529f5e031e08ba3cd merge this two safe commits from trunk to release branch diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/Actions.hs --- a/gameServer/Actions.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/Actions.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,134 +1,171 @@ -{-# LANGUAGE OverloadedStrings #-} module Actions where -import Control.Concurrent +import Control.Concurrent.STM import Control.Concurrent.Chan +import Data.IntMap import qualified Data.IntSet as IntSet -import qualified Data.Set as Set import qualified Data.Sequence as Seq import System.Log.Logger -import Control.Monad +import Monad import Data.Time -import Data.Maybe -import Control.Monad.Reader -import Control.Monad.State.Strict -import qualified Data.ByteString.Char8 as B +import Maybe ----------------------------- import CoreTypes import Utils -import ClientIO -import ServerState data Action = - AnswerClients ![ClientChan] ![B.ByteString] + AnswerThisClient [String] + | AnswerAll [String] + | AnswerAllOthers [String] + | AnswerThisRoom [String] + | AnswerOthersInRoom [String] + | AnswerSameClan [String] + | AnswerLobby [String] | SendServerMessage | SendServerVars - | MoveToRoom RoomIndex - | MoveToLobby B.ByteString - | RemoveTeam B.ByteString + | RoomAddThisClient Int -- roomID + | RoomRemoveThisClient String + | RemoveTeam String | RemoveRoom | UnreadyRoomClients - | JoinLobby - | ProtocolError B.ByteString - | Warning B.ByteString - | ByeClient B.ByteString - | KickClient ClientIndex - | KickRoomClient ClientIndex - | BanClient B.ByteString -- nick - | RemoveClientTeams ClientIndex + | MoveToLobby + | ProtocolError String + | Warning String + | ByeClient String + | KickClient Int -- clID + | KickRoomClient Int -- clID + | BanClient String -- nick + | RemoveClientTeams Int -- clID | ModifyClient (ClientInfo -> ClientInfo) - | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo) + | ModifyClient2 Int (ClientInfo -> ClientInfo) | ModifyRoom (RoomInfo -> RoomInfo) | ModifyServerInfo (ServerInfo -> ServerInfo) - | AddRoom B.ByteString B.ByteString + | AddRoom String String | CheckRegistered | ClearAccountsCache | ProcessAccountInfo AccountInfo | Dump | AddClient ClientInfo - | DeleteClient ClientIndex | PingAll | StatsAction -type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] +type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action] + +replaceID a (b, c, d, e) = (a, c, d, e) + +processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms) + + +processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do + writeChan (sendChan $ clients ! clID) msg + return (clID, serverInfo, clients, rooms) -processAction :: Action -> StateT ServerState IO () +processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do + mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients) + return (clID, serverInfo, clients, rooms) + + +processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do + mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ + Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients) + return (clID, serverInfo, clients, rooms) + + +processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do + mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients + return (clID, serverInfo, clients, rooms) + where + roomClients = IntSet.elems $ playersIDs room + room = rooms ! rID + rID = roomID client + client = clients ! clID -processAction (AnswerClients chans msg) = do - liftIO $ map (flip seq ()) chans `seq` map (flip seq ()) msg `seq` mapM_ (flip writeChan msg) chans +processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do + mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ Prelude.filter (/= clID) roomClients + return (clID, serverInfo, clients, rooms) + where + roomClients = IntSet.elems $ playersIDs room + room = rooms ! rID + rID = roomID client + client = clients ! clID + + +processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do + mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients + return (clID, serverInfo, clients, rooms) + where + roomClients = IntSet.elems $ playersIDs room + room = rooms ! 0 -processAction SendServerMessage = do - chan <- client's sendChan - protonum <- client's clientProto - si <- liftM serverInfo get - let message = if protonum < latestReleaseVersion si then +processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do + mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec + return (clID, serverInfo, clients, rooms) + where + otherRoomClients = Prelude.map ((!) clients) $ IntSet.elems $ clID `IntSet.delete` (playersIDs room) + sameClanOrSpec = if teamsInGame client > 0 then sameClanClients else spectators + spectators = Prelude.filter (\cl -> teamsInGame cl == 0) otherRoomClients + sameClanClients = Prelude.filter (\cl -> teamsInGame cl > 0 && clientClan cl == thisClan) otherRoomClients + thisClan = clientClan client + room = rooms ! rID + rID = roomID client + client = clients ! clID + + +processAction (clID, serverInfo, clients, rooms) SendServerMessage = do + writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo] + return (clID, serverInfo, clients, rooms) + where + client = clients ! clID + message si = if clientProto client < latestReleaseVersion si then serverMessageForOldVersions si else serverMessage si - processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message] -{- -processAction (clID, serverInfo, rnc) SendServerVars = do +processAction (clID, serverInfo, clients, rooms) SendServerVars = do writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars) - return (clID, serverInfo, rnc) + return (clID, serverInfo, clients, rooms) where client = clients ! clID vars = [ - "MOTD_NEW", serverMessage serverInfo, - "MOTD_OLD", serverMessageForOldVersions serverInfo, + "MOTD_NEW", serverMessage serverInfo, + "MOTD_OLD", serverMessageForOldVersions serverInfo, "LATEST_PROTO", show $ latestReleaseVersion serverInfo ] --} +processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do + writeChan (sendChan $ clients ! clID) ["ERROR", msg] + return (clID, serverInfo, clients, rooms) -processAction (ProtocolError msg) = do - chan <- client's sendChan - processAction $ AnswerClients [chan] ["ERROR", msg] + +processAction (clID, serverInfo, clients, rooms) (Warning msg) = do + writeChan (sendChan $ clients ! clID) ["WARNING", msg] + return (clID, serverInfo, clients, rooms) -processAction (Warning msg) = do - chan <- client's sendChan - processAction $ AnswerClients [chan] ["WARNING", msg] - -processAction (ByeClient msg) = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - ri <- clientRoomA - - chan <- client's sendChan - ready <- client's isReady +processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do + infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg) + (_, _, newClients, newRooms) <- + if roomID client /= 0 then + processAction (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit" + else + return (clID, serverInfo, clients, rooms) - when (ri /= lobbyId) $ do - processAction $ MoveToLobby ("quit: " `B.append` msg) - liftIO $ modifyRoom rnc (\r -> r{ - --playersIDs = IntSet.delete ci (playersIDs r) - playersIn = (playersIn r) - 1, - readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r - }) ri - return () - - liftIO $ do - infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg)) - - --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom - - processAction $ AnswerClients [chan] ["BYE", msg] - - s <- get - put $! s{removedClients = ci `Set.insert` removedClients s} - -processAction (DeleteClient ci) = do - rnc <- gets roomsClients - liftIO $ removeClient rnc ci - - s <- get - put $! s{removedClients = ci `Set.delete` removedClients s} - -{- + mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom + writeChan (sendChan $ clients ! clID) ["BYE", msg] + return ( + 0, + serverInfo, + delete clID newClients, + adjust (\r -> r{ + playersIDs = IntSet.delete clID (playersIDs r), + playersIn = (playersIn r) - 1, + readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r + }) (roomID $ newClients ! clID) newRooms + ) where client = clients ! clID clientNick = nick client @@ -147,57 +184,46 @@ else [AnswerAll ["LOBBY:LEFT", clientNick]] else - [] --} + [] + + +processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = + return (clID, serverInfo, adjust func clID clients, rooms) + -processAction (ModifyClient f) = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - liftIO $ modifyClient rnc f ci - return () +processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) = + return (clID, serverInfo, adjust func cl2ID clients, rooms) + -processAction (ModifyClient2 ci f) = do - rnc <- gets roomsClients - liftIO $ modifyClient rnc f ci - return () +processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = + return (clID, serverInfo, clients, adjust func rID rooms) + where + rID = roomID $ clients ! clID -processAction (ModifyRoom f) = do - rnc <- gets roomsClients - ri <- clientRoomA - liftIO $ modifyRoom rnc f ri - return () +processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) = + return (clID, func serverInfo, clients, rooms) -{- - -processAction (clID, serverInfo, rnc) (ModifyServerInfo func) = - return (clID, func serverInfo, rnc) - --} -processAction (MoveToRoom ri) = 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}) ri - - liftIO $ moveClientToRoom rnc ri ci - - chans <- liftM (map sendChan) $ roomClientsS ri - clNick <- client's nick +processAction (clID, serverInfo, clients, rooms) (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 $ AnswerClients chans ["JOINED", clNick] -processAction (MoveToLobby msg) = do - (Just ci) <- gets clientIndex - --ri <- clientRoomA - rnc <- gets roomsClients - - liftIO $ moveClientToLobby rnc ci - -{- +processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do (_, _, newClients, newRooms) <- + if roomID client /= 0 then if isMaster client then if (gameinprogress room) && (playersIn room > 1) then (changeMaster >>= (\state -> foldM processAction state @@ -205,15 +231,16 @@ AnswerOthersInRoom ["WARNING", "Admin left the room"], RemoveClientTeams clID])) else -- not in game - processAction (clID, serverInfo, rnc) RemoveRoom + processAction (clID, serverInfo, clients, rooms) RemoveRoom else -- not master foldM processAction - (clID, serverInfo, rnc) + (clID, serverInfo, clients, rooms) [AnswerOthersInRoom ["LEFT", nick client, msg], RemoveClientTeams clID] - - + else -- in lobby + return (clID, serverInfo, clients, rooms) + return ( clID, serverInfo, @@ -232,7 +259,7 @@ } insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)} changeMaster = do - processAction (newMasterId, serverInfo, rnc) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] + processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] return ( clID, serverInfo, @@ -243,35 +270,34 @@ otherPlayersSet = IntSet.delete clID (playersIDs room) newMasterId = IntSet.findMin otherPlayersSet newMasterClient = clients ! newMasterId --} + -processAction (AddRoom roomName roomPassword) = do - Just clId <- gets clientIndex - rnc <- gets roomsClients - proto <- liftIO $ client'sM rnc clientProto clId - +processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do + let newServerInfo = serverInfo {nextRoomID = newID} let room = newRoom{ - masterID = clId, + roomUID = newID, + masterID = clID, name = roomName, password = roomPassword, - roomProto = proto + roomProto = (clientProto client) } - rId <- liftIO $ addRoom rnc room - - processAction $ MoveToRoom rId - - chans <- liftM (map sendChan) $! roomClientsS lobbyId + processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName] - mapM_ processAction [ - AnswerClients chans ["ROOM", "ADD", roomName] - , ModifyClient (\cl -> cl{isMaster = True}) - ] + processAction ( + clID, + newServerInfo, + adjust (\cl -> cl{isMaster = True}) clID clients, + insert newID room rooms + ) $ RoomAddThisClient newID + where + newID = (nextRoomID serverInfo) - 1 + client = clients ! clID -{- -processAction (clID, serverInfo, rnc) (RemoveRoom) = do - processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "DEL", name room] - processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["ROOMABANDONED", name room] + +processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do + processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room] + processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room] return (clID, serverInfo, Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients, @@ -282,163 +308,139 @@ rID = roomID client client = clients ! clID --} -processAction (UnreadyRoomClients) = do - rnc <- gets roomsClients - ri <- clientRoomA - roomPlayers <- roomClientsS ri - roomClIDs <- liftIO $ roomClientsIndicesM rnc ri - processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers) - liftIO $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs - processAction $ ModifyRoom (\r -> r{readyPlayers = 0}) + +processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do + processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers) + return (clID, + serverInfo, + Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients, + adjust (\r -> r{readyPlayers = 0}) rID rooms) + where + room = rooms ! rID + rID = roomID client + client = clients ! clID + roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs + roomPlayersIDs = IntSet.elems $ playersIDs room -processAction (RemoveTeam teamName) = do - rnc <- gets roomsClients - cl <- client's id - ri <- clientRoomA - inGame <- liftIO $ room'sM rnc gameinprogress ri - chans <- liftM (map sendChan . filter (/= cl)) $ roomClientsS ri - if inGame then - mapM_ processAction [ - AnswerClients chans ["REMOVE_TEAM", teamName], - ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) - ] +processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do + newRooms <- if not $ gameinprogress room then + do + processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName] + return $ + adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms else - mapM_ processAction [ - AnswerClients chans ["EM", rmTeamMsg], - ModifyRoom (\r -> r{ - teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, - leftTeams = teamName : leftTeams r, - roundMsgs = roundMsgs r Seq.|> rmTeamMsg - }) - ] + do + processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg] + return $ + adjust (\r -> r{ + teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, + leftTeams = teamName : leftTeams r, + roundMsgs = roundMsgs r Seq.|> rmTeamMsg + }) rID rooms + return (clID, serverInfo, clients, newRooms) where - rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName + room = rooms ! rID + rID = roomID client + client = clients ! clID + rmTeamMsg = toEngineMsg $ 'F' : teamName -processAction CheckRegistered = do - (Just ci) <- gets clientIndex - n <- client's nick - h <- client's host - db <- gets (dbQueries . serverInfo) - liftIO $ writeChan db $ CheckAccount ci n h - return () -{- -processAction (clID, serverInfo, rnc) (ClearAccountsCache) = do - writeChan (dbQueries serverInfo) ClearCache - return (clID, serverInfo, rnc) +processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do + writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client) + return (clID, serverInfo, clients, rooms) where client = clients ! clID -processAction (clID, serverInfo, rnc) (Dump) = do +processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do + writeChan (dbQueries serverInfo) ClearCache + return (clID, serverInfo, clients, rooms) + where + client = clients ! clID + + +processAction (clID, serverInfo, clients, rooms) (Dump) = do writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] - return (clID, serverInfo, rnc) --} + return (clID, serverInfo, clients, rooms) -processAction (ProcessAccountInfo info) = + +processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) = case info of HasAccount passwd isAdmin -> do - chan <- client's sendChan - processAction $ AnswerClients [chan] ["ASKPASSWORD"] + infoM "Clients" $ show clID ++ " has account" + writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"] + return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms) Guest -> do - processAction JoinLobby + infoM "Clients" $ show clID ++ " is guest" + processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby Admin -> do - mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] - chan <- client's sendChan - processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] + infoM "Clients" $ show clID ++ " is admin" + foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]] -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 - mapM_ processAction $ - (AnswerClients clientsChans ["LOBBY:JOINED", clientNick]) - : [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)] - ++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage] +processAction (clID, serverInfo, clients, rooms) (MoveToLobby) = + foldM processAction (clID, serverInfo, clients, rooms) $ + (RoomAddThisClient 0) + : answerLobbyNicks + ++ [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 + -- ++ (answerServerMessage client clients) 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") + lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients + answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks] -processAction (clID, serverInfo, rnc) (BanClient banNick) = - return (clID, serverInfo, rnc) +processAction (clID, serverInfo, clients, rooms) (KickClient kickID) = + liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked") + + +processAction (clID, serverInfo, clients, rooms) (BanClient banNick) = + return (clID, serverInfo, clients, rooms) -processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do +processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do writeChan (sendChan $ clients ! kickID) ["KICKED"] - liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked") + liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked") -processAction (clID, serverInfo, rnc) (RemoveClientTeams teamsClID) = +processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) = liftM2 replaceID (return clID) $ - foldM processAction (teamsClID, serverInfo, rnc) removeTeamsActions + foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions where client = clients ! teamsClID room = rooms ! (roomID client) teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove --} + -processAction (AddClient client) = do - rnc <- gets roomsClients - si <- gets serverInfo - liftIO $ do - ci <- addClient rnc client - forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci - forkIO $ clientSendLoop (clientSocket client) (sendChan client) ci +processAction (clID, serverInfo, clients, rooms) (AddClient client) = do + let updatedClients = insert (clientUID client) client clients + infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client)) + writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] - infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client)) - - processAction $ AnswerClients [sendChan client] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] -{- let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo + let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo - if False && (isJust $ host client `Prelude.lookup` newLogins) then - processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast" - else - return (ci, serverInfo) --} - + if isJust $ host client `Prelude.lookup` newLogins then + processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast" + else + return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms) -processAction PingAll = do - rnc <- gets roomsClients - liftIO (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) - cis <- liftIO $ allClientsM rnc - chans <- liftIO $ mapM (client'sM rnc sendChan) cis - liftIO $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis - processAction $ AnswerClients chans ["PING"] +processAction (clID, serverInfo, clients, rooms) PingAll = do + (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients + processAction (clID, + serverInfo, + Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients, + newRooms) $ AnswerAll ["PING"] where - kickTimeouted rnc ci = do - pq <- liftIO $ client'sM rnc pingsQueue ci - when (pq > 0) $ - withStateT (\as -> as{clientIndex = Just ci}) $ - processAction (ByeClient "Ping timeout") + kickTimeouted (clID, serverInfo, clients, rooms) client = + if pingsQueue client > 0 then + processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout" + else + return (clID, serverInfo, clients, rooms) -processAction (StatsAction) = do - rnc <- gets roomsClients - si <- gets serverInfo - (roomsNum, clientsNum) <- liftIO $ withRoomsAndClients rnc stats - liftIO $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1) - where - stats irnc = (length $ allRooms irnc, length $ allClients irnc) - +processAction (clID, serverInfo, clients, rooms) (StatsAction) = do + writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1) + return (clID, serverInfo, clients, rooms) diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/CMakeLists.txt --- a/gameServer/CMakeLists.txt Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/CMakeLists.txt Fri Nov 12 09:49:46 2010 +0100 @@ -1,48 +1,43 @@ find_program(ghc_executable ghc) if(NOT ghc_executable) - message(FATAL_ERROR "Cannot find GHC") + message(FATAL_ERROR "Cannot find GHC") endif(NOT ghc_executable) set(hwserver_sources - OfficialServer/DBInteraction.hs - Actions.hs - ClientIO.hs - CoreTypes.hs - HWProtoCore.hs - HWProtoInRoomState.hs - HWProtoLobbyState.hs - HWProtoNEState.hs - HandlerUtils.hs - NetRoutines.hs - Opts.hs - RoomsAndClients.hs - ServerCore.hs - ServerState.hs - Store.hs - Utils.hs - hedgewars-server.hs - ) + OfficialServer/DBInteraction.hs + Actions.hs + ClientIO.hs + CoreTypes.hs + HWProtoCore.hs + HWProtoInRoomState.hs + HWProtoLobbyState.hs + HWProtoNEState.hs + NetRoutines.hs + Opts.hs + ServerCore.hs + Utils.hs + hedgewars-server.hs + ) set(hwserv_main ${hedgewars_SOURCE_DIR}/gameServer/hedgewars-server.hs) set(ghc_flags - -Wall - --make ${hwserv_main} - -i${hedgewars_SOURCE_DIR}/gameServer - -o ${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX} - -odir ${CMAKE_CURRENT_BINARY_DIR} - -hidir ${CMAKE_CURRENT_BINARY_DIR}) + --make ${hwserv_main} + -i${hedgewars_SOURCE_DIR}/gameServer + -o ${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX} + -odir ${CMAKE_CURRENT_BINARY_DIR} + -hidir ${CMAKE_CURRENT_BINARY_DIR}) set(ghc_flags ${haskell_compiler_flags_cmn} ${ghc_flags}) add_custom_command(OUTPUT "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}" - COMMAND "${ghc_executable}" - ARGS ${ghc_flags} - MAIN_DEPENDENCY ${hwserv_main} - DEPENDS ${hwserver_sources} - ) + COMMAND "${ghc_executable}" + ARGS ${ghc_flags} + MAIN_DEPENDENCY ${hwserv_main} + DEPENDS ${hwserver_sources} + ) add_custom_target(hedgewars-server ALL DEPENDS "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}") diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/ClientIO.hs --- a/gameServer/ClientIO.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/ClientIO.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module ClientIO where import qualified Control.Exception as Exception @@ -6,71 +6,45 @@ import Control.Concurrent import Control.Monad import System.IO -import Network -import Network.Socket.ByteString -import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.UTF8 as BUTF8 +import qualified Data.ByteString as B ---------------- import CoreTypes -import RoomsAndClients -import Utils - -pDelim :: B.ByteString -pDelim = B.pack "\n\n" - -bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString) -bs2Packets buf = unfoldrE extractPackets buf - where - extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString) - extractPackets buf = - let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in - let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in - if B.null bufTail then - Left bsPacket - else - if B.null bsPacket then - Left bufTail - else - Right (B.splitWith (== '\n') bsPacket, bufTail) - +listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO () +listenLoop handle linesNumber buf chan clientID = do + str <- liftM BUTF8.toString $ B.hGetLine handle + if (linesNumber > 50) || (length str > 450) then + writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"]) + else + if str == "" then do + writeChan chan $ ClientMessage (clientID, buf) + yield + listenLoop handle 0 [] chan clientID + else + listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID -listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () -listenLoop sock chan ci = recieveWithBufferLoop B.empty - where - recieveWithBufferLoop recvBuf = do - recvBS <- recv sock 4096 --- 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 - recieveWithBufferLoop newrecvBuf - - sendPacket packet = writeChan chan $ ClientMessage (ci, packet) - +clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO () +clientRecvLoop handle chan clientID = + listenLoop handle 0 [] chan clientID + `catch` (\e -> clientOff (show e) >> return ()) + where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message -clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () -clientRecvLoop s chan ci = do - msg <- (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show) - clientOff msg - where - clientOff msg = mapM_ (writeChan chan) [ClientMessage (ci, ["QUIT", msg]), Remove ci] - - +clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO() +clientSendLoop handle coreChan chan clientID = do + answer <- readChan chan + doClose <- Exception.handle + (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do + B.hPutStrLn handle $ BUTF8.fromString $ unlines answer + hFlush handle + return $ isQuit answer -clientSendLoop :: Socket -> Chan [B.ByteString] -> ClientIndex -> IO () -clientSendLoop s chan ci = do - answer <- readChan chan - Exception.handle - (\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do - sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n') - - if (isQuit answer) then - Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s + if doClose then + Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle else - clientSendLoop s chan ci + clientSendLoop handle coreChan chan clientID where - --sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e]) - sendQuit e = putStrLn $ show e + sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e]) isQuit ("BYE":xs) = True isQuit _ = False diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/CoreTypes.hs --- a/gameServer/CoreTypes.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/CoreTypes.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module CoreTypes where import System.IO @@ -6,95 +5,102 @@ import Control.Concurrent.STM import Data.Word import qualified Data.Map as Map +import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import Data.Sequence(Seq, empty) import Data.Time import Network import Data.Function -import Data.ByteString.Char8 as B -import RoomsAndClients - -type ClientChan = Chan [B.ByteString] data ClientInfo = ClientInfo { - sendChan :: ClientChan, - clientSocket :: Socket, - host :: B.ByteString, + clientUID :: !Int, + sendChan :: Chan [String], + clientHandle :: Handle, + host :: String, connectTime :: UTCTime, - nick :: B.ByteString, - webPassword :: B.ByteString, + nick :: String, + webPassword :: String, logonPassed :: Bool, clientProto :: !Word16, - roomID :: RoomIndex, + roomID :: !Int, pingsQueue :: !Word, isMaster :: Bool, - isReady :: !Bool, + isReady :: Bool, isAdministrator :: Bool, - clientClan :: B.ByteString, + clientClan :: String, teamsInGame :: Word } instance Show ClientInfo where - show ci = " nick: " ++ (unpack $ nick ci) ++ " host: " ++ (unpack $ host ci) + show ci = show (clientUID ci) + ++ " nick: " ++ (nick ci) + ++ " host: " ++ (host ci) instance Eq ClientInfo where - (==) = (==) `on` clientSocket + (==) = (==) `on` clientHandle data HedgehogInfo = - HedgehogInfo B.ByteString B.ByteString + HedgehogInfo String String data TeamInfo = TeamInfo { - teamownerId :: ClientIndex, - teamowner :: B.ByteString, - teamname :: B.ByteString, - teamcolor :: B.ByteString, - teamgrave :: B.ByteString, - teamfort :: B.ByteString, - teamvoicepack :: B.ByteString, - teamflag :: B.ByteString, + teamownerId :: !Int, + teamowner :: String, + teamname :: String, + teamcolor :: String, + teamgrave :: String, + teamfort :: String, + teamvoicepack :: String, + teamflag :: String, difficulty :: Int, hhnum :: Int, hedgehogs :: [HedgehogInfo] } instance Show TeamInfo where - show ti = "owner: " ++ (unpack $ teamowner ti) - ++ "name: " ++ (unpack $ teamname ti) - ++ "color: " ++ (unpack $ teamcolor ti) + show ti = "owner: " ++ (teamowner ti) + ++ "name: " ++ (teamname ti) + ++ "color: " ++ (teamcolor ti) data RoomInfo = RoomInfo { - masterID :: ClientIndex, - name :: B.ByteString, - password :: B.ByteString, + roomUID :: !Int, + masterID :: !Int, + name :: String, + password :: String, roomProto :: Word16, teams :: [TeamInfo], gameinprogress :: Bool, playersIn :: !Int, readyPlayers :: !Int, + playersIDs :: IntSet.IntSet, isRestrictedJoins :: Bool, isRestrictedTeams :: Bool, - roundMsgs :: Seq B.ByteString, - leftTeams :: [B.ByteString], + roundMsgs :: Seq String, + leftTeams :: [String], teamsAtStart :: [TeamInfo], - params :: Map.Map B.ByteString [B.ByteString] + params :: Map.Map String [String] } instance Show RoomInfo where - show ri = ", players: " ++ show (playersIn ri) + show ri = show (roomUID ri) + ++ ", players ids: " ++ show (IntSet.size $ playersIDs ri) + ++ ", players: " ++ show (playersIn ri) ++ ", ready: " ++ show (readyPlayers ri) ++ ", teams: " ++ show (teams ri) -newRoom :: RoomInfo +instance Eq RoomInfo where + (==) = (==) `on` roomUID + newRoom = ( RoomInfo - undefined + 0 + 0 "" "" 0 @@ -102,6 +108,7 @@ False 0 0 + IntSet.empty False False Data.Sequence.empty @@ -121,24 +128,23 @@ ServerInfo { isDedicated :: Bool, - serverMessage :: B.ByteString, - serverMessageForOldVersions :: B.ByteString, + serverMessage :: String, + serverMessageForOldVersions :: String, latestReleaseVersion :: Word16, listenPort :: PortNumber, nextRoomID :: Int, - dbHost :: B.ByteString, - dbLogin :: B.ByteString, - dbPassword :: B.ByteString, - lastLogins :: [(B.ByteString, UTCTime)], + dbHost :: String, + dbLogin :: String, + dbPassword :: String, + lastLogins :: [(String, UTCTime)], stats :: TMVar StatisticsInfo, coreChan :: Chan CoreMessage, dbQueries :: Chan DBQuery } instance Show ServerInfo where - show _ = "Server Info" + show si = "Server Info" -newServerInfo :: TMVar StatisticsInfo -> Chan CoreMessage -> Chan DBQuery -> ServerInfo newServerInfo = ( ServerInfo True @@ -154,31 +160,29 @@ ) data AccountInfo = - HasAccount B.ByteString Bool + HasAccount String Bool | Guest | Admin deriving (Show, Read) data DBQuery = - CheckAccount ClientIndex B.ByteString B.ByteString + CheckAccount Int String String | ClearCache | SendStats Int Int deriving (Show, Read) data CoreMessage = Accept ClientInfo - | ClientMessage (ClientIndex, [B.ByteString]) - | ClientAccountInfo (ClientIndex, AccountInfo) + | ClientMessage (Int, [String]) + | ClientAccountInfo (Int, AccountInfo) | TimerAction Int - | Remove ClientIndex + +type Clients = IntMap.IntMap ClientInfo +type Rooms = IntMap.IntMap RoomInfo -instance Show CoreMessage where - show (Accept _) = "Accept" - show (ClientMessage _) = "ClientMessage" - show (ClientAccountInfo _) = "ClientAccountInfo" - show (TimerAction _) = "TimerAction" - show (Remove _) = "Remove" - -type MRnC = MRoomsAndClients RoomInfo ClientInfo -type IRnC = IRoomsAndClients RoomInfo ClientInfo +--type ClientsTransform = [ClientInfo] -> [ClientInfo] +--type RoomsTransform = [RoomInfo] -> [RoomInfo] +--type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo] +--type Answer = ServerInfo -> (HandlesSelector, [String]) +type ClientsSelector = Clients -> Rooms -> [Int] diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/HWProtoCore.hs --- a/gameServer/HWProtoCore.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/HWProtoCore.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,10 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} module HWProtoCore where import qualified Data.IntMap as IntMap import Data.Foldable -import Data.Maybe -import Control.Monad.Reader +import Maybe -------------------------------------- import CoreTypes import Actions @@ -12,37 +10,35 @@ import HWProtoNEState import HWProtoLobbyState import HWProtoInRoomState -import HandlerUtils -import RoomsAndClients handleCmd, handleCmd_loggedin :: CmdHandler - -handleCmd ["PING"] = answerClient ["PONG"] +handleCmd clID _ _ ["PING"] = [AnswerThisClient ["PONG"]] - -handleCmd ("QUIT" : xs) = return [ByeClient msg] +handleCmd clID clients rooms ("QUIT" : xs) = + [ByeClient msg] where msg = if not $ null xs then head xs else "" -{- -handleCmd ["PONG"] = + +handleCmd clID clients _ ["PONG"] = if pingsQueue client == 0 then [ProtocolError "Protocol violation"] else [ModifyClient (\cl -> cl{pingsQueue = pingsQueue cl - 1})] where client = clients IntMap.! clID --} + -handleCmd cmd = do - (ci, irnc) <- ask - if logonPassed (irnc `client` ci) then - handleCmd_loggedin cmd - else - handleCmd_NotEntered cmd +handleCmd clID clients rooms cmd = + if not $ logonPassed client then + handleCmd_NotEntered clID clients rooms cmd + else + handleCmd_loggedin clID clients rooms cmd + where + client = clients IntMap.! clID -{- + handleCmd_loggedin clID clients rooms ["INFO", asknick] = if noSuchClient then [] @@ -66,12 +62,11 @@ then if teamsInGame client > 0 then "(playing)" else "(spectating)" else "" --} - -handleCmd_loggedin cmd = do - (ci, rnc) <- ask - if clientRoom rnc ci == lobbyId then - handleCmd_lobby cmd - else - handleCmd_inRoom cmd +handleCmd_loggedin clID clients rooms cmd = + if roomID client == 0 then + handleCmd_lobby clID clients rooms cmd + else + handleCmd_inRoom clID clients rooms cmd + where + client = clients IntMap.! clID diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/HWProtoInRoomState.hs --- a/gameServer/HWProtoInRoomState.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/HWProtoInRoomState.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,240 +1,182 @@ -{-# LANGUAGE OverloadedStrings #-} module HWProtoInRoomState where import qualified Data.Foldable as Foldable +import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Sequence(Seq, (|>), (><), fromList, empty) import Data.List -import Data.Maybe -import qualified Data.ByteString.Char8 as B -import Control.Monad -import Control.Monad.Reader +import Maybe -------------------------------------- import CoreTypes import Actions import Utils -import HandlerUtils -import RoomsAndClients + handleCmd_inRoom :: CmdHandler -handleCmd_inRoom ["CHAT", msg] = do - n <- clientNick - s <- roomOthersChans - return [AnswerClients s ["CHAT", n, msg]] +handleCmd_inRoom clID clients _ ["CHAT", msg] = + [AnswerOthersInRoom ["CHAT", clientNick, msg]] + where + clientNick = nick $ clients IntMap.! clID -handleCmd_inRoom ["PART"] = return [MoveToLobby "part"] -handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg] +handleCmd_inRoom clID clients rooms ["PART"] = + [RoomRemoveThisClient "part"] + where + client = clients IntMap.! clID -handleCmd_inRoom ("CFG" : paramName : paramStrs) - | null paramStrs = return [ProtocolError "Empty config entry"] - | otherwise = do - chans <- roomOthersChans - cl <- thisClient - if isMaster cl then - return [ - ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}), - AnswerClients chans ("CFG" : paramName : paramStrs)] - else - return [ProtocolError "Not room master"] +handleCmd_inRoom clID clients rooms ("CFG" : paramName : paramStrs) + | null paramStrs = [ProtocolError "Empty config entry"] + | isMaster client = + [ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}), + AnswerOthersInRoom ("CFG" : paramName : paramStrs)] + | otherwise = [ProtocolError "Not room master"] + where + client = clients IntMap.! clID -handleCmd_inRoom ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo) - | length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"] - | otherwise = do - (ci, rnc) <- ask - r <- thisRoom - clNick <- clientNick - clChan <- thisClientChans - othersChans <- roomOthersChans - return $ - if not . null . drop 5 $ teams r then - [Warning "too many teams"] - else if canAddNumber r <= 0 then - [Warning "too many hedgehogs"] - else if isJust $ findTeam r then - [Warning "There's already a team with same name in the list"] - else if gameinprogress r then - [Warning "round in progress"] - else if isRestrictedTeams r then - [Warning "restricted"] - else - [ModifyRoom (\r -> r{teams = teams r ++ [newTeam ci clNick r]}), - ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}), - AnswerClients clChan ["TEAM_ACCEPTED", name], - AnswerClients othersChans $ teamToNet $ newTeam ci clNick r, - AnswerClients othersChans ["TEAM_COLOR", name, color] - ] - where - canAddNumber r = 48 - (sum . map hhnum $ teams r) - findTeam = find (\t -> name == teamname t) . teams - newTeam ci clNick r = (TeamInfo ci clNick name color grave fort voicepack flag difficulty (newTeamHHNum r) (hhsList hhsInfo)) - difficulty = case B.readInt difStr of - Just (i, t) | B.null t -> fromIntegral i - otherwise -> 0 +handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo) + | length hhsInfo == 15 && clientProto client < 30 = handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : " " : flag : difStr : hhsInfo) + | length hhsInfo /= 16 = [ProtocolError "Corrupted hedgehogs info"] + | length (teams room) == 6 = [Warning "too many teams"] + | canAddNumber <= 0 = [Warning "too many hedgehogs"] + | isJust findTeam = [Warning "There's already a team with same name in the list"] + | gameinprogress room = [Warning "round in progress"] + | isRestrictedTeams room = [Warning "restricted"] + | otherwise = + [ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}), + ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}), + AnswerThisClient ["TEAM_ACCEPTED", name], + AnswerOthersInRoom $ teamToNet (clientProto client) newTeam, + AnswerOthersInRoom ["TEAM_COLOR", name, color] + ] + where + client = clients IntMap.! clID + room = rooms IntMap.! (roomID client) + canAddNumber = 48 - (sum . map hhnum $ teams room) + findTeam = find (\t -> name == teamname t) $ teams room + newTeam = (TeamInfo clID (nick client) name color grave fort voicepack flag difficulty newTeamHHNum (hhsList hhsInfo)) + difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int) 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 - r <- thisRoom - clNick <- clientNick - - let maybeTeam = findTeam r - let team = fromJust maybeTeam + newTeamHHNum = min 4 canAddNumber - return $ - if isNothing $ findTeam r then - [Warning "REMOVE_TEAM: no such team"] - else if clNick /= teamowner team then - [ProtocolError "Not team owner!"] - else - [RemoveTeam name, - ModifyClient - (\c -> c{ - teamsInGame = teamsInGame c - 1, - clientClan = if teamsInGame c == 1 then undefined else anotherTeamClan ci r - }) - ] +handleCmd_inRoom clID clients rooms ["REMOVE_TEAM", teamName] + | noSuchTeam = [Warning "REMOVE_TEAM: no such team"] + | nick client /= teamowner team = [ProtocolError "Not team owner!"] + | otherwise = + [RemoveTeam teamName, + ModifyClient (\c -> c{teamsInGame = teamsInGame c - 1, clientClan = if teamsInGame client == 1 then undefined else anotherTeamClan}) + ] where - anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams - findTeam = find (\t -> name == teamname t) . teams + client = clients IntMap.! clID + room = rooms IntMap.! (roomID client) + noSuchTeam = isNothing findTeam + team = fromJust findTeam + findTeam = find (\t -> teamName == teamname t) $ teams room + anotherTeamClan = teamcolor $ fromJust $ find (\t -> teamownerId t == clID) $ teams room -handleCmd_inRoom ["HH_NUM", teamName, numberStr] = 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 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]] +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]] where - 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 - + 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) -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], +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], ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})] where - findTeam = find (\t -> teamName == teamname t) . teams + noSuchTeam = isNothing findTeam + team = fromJust findTeam + findTeam = find (\t -> teamName == teamname t) $ teams room + client = clients IntMap.! clID + room = rooms IntMap.! (roomID client) -handleCmd_inRoom ["TOGGLE_READY"] = do - cl <- thisClient - chans <- roomClientsChans - return [ - ModifyClient (\c -> c{isReady = not $ isReady cl}), - ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)}), - AnswerClients chans [if isReady cl then "NOT_READY" else "READY", nick cl] - ] +handleCmd_inRoom clID clients rooms ["TOGGLE_READY"] = + [ModifyClient (\c -> c{isReady = not $ isReady client}), + ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady client then -1 else 1)}), + AnswerThisRoom [if isReady client then "NOT_READY" else "READY", nick client]] + where + client = clients IntMap.! clID -handleCmd_inRoom ["START_GAME"] = do - cl <- thisClient - r <- thisRoom - chans <- roomClientsChans - if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then - if enoughClans r then - return [ - ModifyRoom +handleCmd_inRoom clID clients rooms ["START_GAME"] = + if isMaster client && (playersIn room == readyPlayers room) && (not . gameinprogress) room then + if enoughClans then + [ModifyRoom (\r -> r{ gameinprogress = True, roundMsgs = empty, leftTeams = [], teamsAtStart = teams r} ), - AnswerClients chans ["RUN_GAME"] - ] - else - return [Warning "Less than two clans!"] + AnswerThisRoom ["RUN_GAME"]] else - return [] + [Warning "Less than two clans!"] + else + [] where - enoughClans = not . null . drop 1 . group . map teamcolor . teams + client = clients IntMap.! clID + room = rooms IntMap.! (roomID client) + enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room -handleCmd_inRoom ["EM", msg] = do - cl <- thisClient - r <- thisRoom - chans <- roomOthersChans - - if (teamsInGame cl > 0) && isLegal then - return $ (AnswerClients chans ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive] - else - return [] +handleCmd_inRoom clID clients rooms ["EM", msg] = + if (teamsInGame client > 0) && isLegal then + (AnswerOthersInRoom ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive] + else + [] where + client = clients IntMap.! clID (isLegal, isKeepAlive) = checkNetCmd msg - -handleCmd_inRoom ["ROUNDFINISHED"] = do - cl <- thisClient - r <- thisRoom - chans <- roomClientsChans - - if isMaster cl && (gameinprogress r) then - return $ (ModifyRoom +handleCmd_inRoom clID clients rooms ["ROUNDFINISHED"] = + if isMaster client then + [ModifyRoom (\r -> r{ gameinprogress = False, readyPlayers = 0, roundMsgs = empty, leftTeams = [], teamsAtStart = []} - )) - : UnreadyRoomClients - : answerRemovedTeams chans r - else - return [] + ), + UnreadyRoomClients + ] ++ answerRemovedTeams + else + [] where - answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams - -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})] + client = clients IntMap.! clID + room = rooms IntMap.! (roomID client) + answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room -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_JOINS"] + | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})] + | otherwise = [ProtocolError "Not room master"] + where + client = clients IntMap.! clID + -{- +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 @@ -250,5 +192,5 @@ where client = clients IntMap.! clID engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20") --} -handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"] + +handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"] diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/HWProtoLobbyState.hs --- a/gameServer/HWProtoLobbyState.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/HWProtoLobbyState.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,102 +1,73 @@ -{-# LANGUAGE OverloadedStrings #-} 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 Data.Maybe +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 +answerAllTeams protocol teams = concatMap toAnswer teams where toAnswer team = [AnswerThisClient $ teamToNet protocol team, AnswerThisClient ["TEAM_COLOR", teamname team, teamcolor team], AnswerThisClient ["HH_NUM", teamname team, show $ hhnum team]] --} + handleCmd_lobby :: CmdHandler - -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)] +handleCmd_lobby clID clients rooms ["LIST"] = + [AnswerThisClient ("ROOMS" : roomsInfoList)] where - roomInfo irnc room = [ - showB $ gameinprogress room, + 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 = [ name room, - showB $ playersIn room, - showB $ length $ teams room, - nick $ irnc `client` masterID room, + show (playersIn room) ++ "(" ++ show (length $ teams room) ++ ")", + show $ gameinprogress room + ] + | otherwise = [ + show $ gameinprogress room, + name room, + show $ playersIn room, + show $ length $ teams room, + nick $ clients IntMap.! (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 - s <- roomOthersChans - return [AnswerClients s ["CHAT", n, msg]] - -handleCmd_lobby ["CREATE_ROOM", newRoom, roomPassword] - | illegalName newRoom = return [Warning "Illegal room name"] - | otherwise = do - rs <- allRoomInfos - cl <- thisClient - 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 ["CREATE_ROOM", newRoom] = - handleCmd_lobby ["CREATE_ROOM", newRoom, ""] +handleCmd_lobby clID clients _ ["CHAT", msg] = + [AnswerOthersInRoom ["CHAT", clientNick, msg]] + where + clientNick = nick $ clients IntMap.! clID -handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do - (ci, irnc) <- ask - let ris = allRooms irnc - cl <- thisClient - let maybeRI = find (\ri -> roomName == name (irnc `room` ri)) ris - let jRI = fromJust maybeRI - let jRoom = irnc `room` jRI - let jRoomClients = map (client irnc) $! roomClients irnc jRI -- no lazyness here! - return $ - if isNothing maybeRI then - [Warning "No such rooms"] - else if isRestrictedJoins jRoom then - [Warning "Joining restricted"] - else if roomPassword /= password jRoom then - [Warning "Wrong password"] - else - [ - MoveToRoom jRI, - AnswerClients (map sendChan $ cl : jRoomClients) ["NOT_READY", nick cl] - ] - ++ [ AnswerClients [sendChan cl] $ "JOINED" : map nick jRoomClients | playersIn jRoom /= 0] - ++ (map (readynessMessage cl) jRoomClients) - +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 - readynessMessage cl c = AnswerClients [sendChan cl] [if isReady c then "READY" else "NOT_READY", nick c] + clientNick = nick $ clients IntMap.! clID + haveSameRoom = isJust $ find (\room -> newRoom == name room) $ IntMap.elems rooms +handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom] = + handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, ""] -{- handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, roomPassword] | noSuchRoom = [Warning "No such room"] @@ -112,6 +83,12 @@ ++ answerTeams ++ watchRound where + noSuchRoom = isNothing mbRoom + mbRoom = find (\r -> roomName == name r && roomProto r == clientProto client) $ IntMap.elems rooms + jRoom = fromJust mbRoom + rID = roomUID jRoom + client = clients IntMap.! clID + roomClientsIDs = IntSet.elems $ playersIDs jRoom answerNicks = [AnswerThisClient $ "JOINED" : map (\clID -> nick $ clients IntMap.! clID) roomClientsIDs | playersIn jRoom /= 0] @@ -123,7 +100,7 @@ roomClientsIDs toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs - + answerFullConfig = map toAnswer (leftConfigPart ++ rightConfigPart) (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p /= "MAP") (Map.toList $ params jRoom) @@ -137,12 +114,12 @@ answerAllTeams (clientProto client) (teamsAtStart jRoom) else answerAllTeams (clientProto client) (teams jRoom) --} + -handleCmd_lobby ["JOIN_ROOM", roomName] = - handleCmd_lobby ["JOIN_ROOM", roomName, ""] +handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName] = + handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, ""] + -{- handleCmd_lobby clID clients rooms ["FOLLOW", asknick] = if noSuchClient || roomID followClient == 0 then [] @@ -203,7 +180,6 @@ [ClearAccountsCache | isAdministrator client] where client = clients IntMap.! clID --} -handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"] +handleCmd_lobby clID _ _ _ = [ProtocolError "Incorrect command (state: in lobby)"] diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/HWProtoNEState.hs --- a/gameServer/HWProtoNEState.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/HWProtoNEState.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,66 +1,54 @@ -{-# LANGUAGE OverloadedStrings #-} module HWProtoNEState where import qualified Data.IntMap as IntMap -import Data.Maybe +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 RoomsAndClients handleCmd_NotEntered :: CmdHandler -handleCmd_NotEntered ["NICK", newNick] = do - (ci, irnc) <- ask - let cl = irnc `client` ci - if not . B.null $ nick cl then return [ProtocolError "Nickname already chosen"] - else - if haveSameNick irnc (nick cl) then return [AnswerClients [sendChan cl] ["WARNING", "Nickname already in use"], ByeClient ""] - else - if illegalName newNick then return [ByeClient "Illegal nickname"] - else - return $ - ModifyClient (\c -> c{nick = newNick}) : - AnswerClients [sendChan cl] ["NICK", newNick] : - [CheckRegistered | clientProto cl /= 0] +handleCmd_NotEntered clID clients _ ["NICK", newNick] + | not . null $ nick client = [ProtocolError "Nickname already chosen"] + | haveSameNick = [AnswerThisClient ["WARNING", "Nickname already in use"], ByeClient ""] + | illegalName newNick = [ByeClient "Illegal nickname"] + | otherwise = + ModifyClient (\c -> c{nick = newNick}) : + AnswerThisClient ["NICK", newNick] : + [CheckRegistered | clientProto client /= 0] where - haveSameNick irnc clNick = isJust $ find (\cl -> newNick == clNick) $ map (client irnc) $ allClients irnc - -handleCmd_NotEntered ["PROTO", protoNum] = do - (ci, irnc) <- ask - let cl = irnc `client` ci - if clientProto cl > 0 then return [ProtocolError "Protocol already known"] - else - if parsedProto == 0 then return [ProtocolError "Bad number"] - else - return $ - ModifyClient (\c -> c{clientProto = parsedProto}) : - AnswerClients [sendChan cl] ["PROTO", B.pack $ show parsedProto] : - [CheckRegistered | not . B.null $ nick cl] - where - parsedProto = case B.readInt protoNum of - Just (i, t) | B.null t -> fromIntegral i - otherwise -> 0 + client = clients IntMap.! clID + haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients -handleCmd_NotEntered ["PASSWORD", passwd] = do - (ci, irnc) <- ask - let cl = irnc `client` ci +handleCmd_NotEntered clID clients _ ["PROTO", protoNum] + | clientProto client > 0 = [ProtocolError "Protocol already known"] + | parsedProto == 0 = [ProtocolError "Bad number"] + | otherwise = + ModifyClient (\c -> c{clientProto = parsedProto}) : + AnswerThisClient ["PROTO", show parsedProto] : + [CheckRegistered | (not . null) (nick client)] + where + client = clients IntMap.! clID + parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16) - if passwd == webPassword cl then - return $ JoinLobby : [AnswerClients [sendChan cl] ["ADMIN_ACCESS"] | isAdministrator cl] - else - return [ByeClient "Authentication failed"] -{- +handleCmd_NotEntered clID clients _ ["PASSWORD", passwd] = + if passwd == webPassword client then + [ModifyClient (\cl -> cl{logonPassed = True}), + MoveToLobby] ++ adminNotice + else + [ByeClient "Authentication failed"] + where + client = clients IntMap.! clID + adminNotice = [AnswerThisClient ["ADMIN_ACCESS"] | isAdministrator client] + handleCmd_NotEntered clID clients _ ["DUMP"] = if isAdministrator (clients IntMap.! clID) then [Dump] else [] --} + -handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"] +handleCmd_NotEntered clID _ _ _ = [ProtocolError "Incorrect command (state: not entered)"] diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/HandlerUtils.hs --- a/gameServer/HandlerUtils.hs Fri Nov 12 00:11:22 2010 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -module HandlerUtils where - -import Control.Monad.Reader -import qualified Data.ByteString.Char8 as B - -import RoomsAndClients -import CoreTypes -import Actions - -thisClient :: Reader (ClientIndex, IRnC) ClientInfo -thisClient = do - (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 - -roomOthersChans :: Reader (ClientIndex, IRnC) [ClientChan] -roomOthersChans = do - (ci, rnc) <- ask - let ri = clientRoom rnc ci - return $ map (sendChan . client rnc) $ filter (/= ci) (roomClients rnc ri) - -roomClientsChans :: Reader (ClientIndex, IRnC) [ClientChan] -roomClientsChans = do - (ci, rnc) <- ask - let ri = clientRoom rnc ci - return $ map (sendChan . client rnc) (roomClients rnc ri) - -thisClientChans :: Reader (ClientIndex, IRnC) [ClientChan] -thisClientChans = do - (ci, rnc) <- ask - return $ [sendChan (rnc `client` ci)] - -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 diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/NetRoutines.hs --- a/gameServer/NetRoutines.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/NetRoutines.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,41 +1,46 @@ -{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module NetRoutines where +import Network import Network.Socket import System.IO +import Control.Concurrent import Control.Concurrent.Chan +import Control.Concurrent.STM import qualified Control.Exception as Exception import Data.Time -import Control.Monad ----------------------------- import CoreTypes +import ClientIO import Utils -import RoomsAndClients -acceptLoop :: Socket -> Chan CoreMessage -> IO () -acceptLoop servSock chan = forever $ do +acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO () +acceptLoop servSock coreChan clientCounter = do Exception.handle (\(_ :: Exception.IOException) -> putStrLn "exception on connect") $ do - (sock, sockAddr) <- Network.Socket.accept servSock + (socket, sockAddr) <- Network.Socket.accept servSock + cHandle <- socketToHandle socket ReadWriteMode + hSetBuffering cHandle LineBuffering clientHost <- sockAddr2String sockAddr currentTime <- getCurrentTime - - sendChan' <- newChan + + sendChan <- newChan let newClient = (ClientInfo - sendChan' - sock + nextID + sendChan + cHandle clientHost currentTime "" "" False 0 - lobbyId + 0 0 False False @@ -44,5 +49,12 @@ undefined ) - writeChan chan $ Accept newClient + writeChan coreChan $ Accept newClient + + forkIO $ clientRecvLoop cHandle coreChan nextID + forkIO $ clientSendLoop cHandle coreChan sendChan nextID return () + + acceptLoop servSock coreChan nextID + where + nextID = clientCounter + 1 diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/OfficialServer/DBInteraction.hs --- a/gameServer/OfficialServer/DBInteraction.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/OfficialServer/DBInteraction.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} module OfficialServer.DBInteraction ( startDBConnection @@ -11,7 +11,8 @@ import qualified Control.Exception as Exception import Control.Monad import qualified Data.Map as Map -import Data.Maybe +import Monad +import Maybe import System.Log.Logger import Data.Time ------------------------ @@ -20,7 +21,7 @@ localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"] -fakeDbConnection serverInfo = forever $ do +fakeDbConnection serverInfo = do q <- readChan $ dbQueries serverInfo case q of CheckAccount clUid _ clHost -> do @@ -29,6 +30,8 @@ ClearCache -> return () SendStats {} -> return () + fakeDbConnection serverInfo + #if defined(OFFICIAL_SERVER) pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/OfficialServer/extdbinterface.hs --- a/gameServer/OfficialServer/extdbinterface.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/OfficialServer/extdbinterface.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -26,7 +26,7 @@ case q of CheckAccount clUid clNick _ -> do statement <- prepare dbConn dbQueryAccount - execute statement [SqlByteString $ clNick] + execute statement [SqlString $ clNick] passAndRole <- fetchRow statement finish statement let response = @@ -47,7 +47,7 @@ dbConnectionLoop mySQLConnectionInfo = - Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $ + Control.Exception.handle (\(_ :: IOException) -> return ()) $ handleSqlError $ bracket (connectMySQL mySQLConnectionInfo) (disconnect) diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/Opts.hs --- a/gameServer/Opts.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/Opts.hs Fri Nov 12 09:49:46 2010 +0100 @@ -3,12 +3,10 @@ getOpts, ) where -import System.Environment +import System import System.Console.GetOpt import Network import Data.Maybe ( fromMaybe ) -import qualified Data.ByteString.Char8 as B - import CoreTypes import Utils @@ -32,9 +30,9 @@ where readDedicated = fromMaybe True (maybeRead str :: Maybe Bool) -readDbLogin str opts = opts{dbLogin = B.pack str} -readDbPassword str opts = opts{dbPassword = B.pack str} -readDbHost str opts = opts{dbHost = B.pack str} +readDbLogin str opts = opts{dbLogin = str} +readDbPassword str opts = opts{dbPassword = str} +readDbHost str opts = opts{dbHost = str} getOpts :: ServerInfo -> IO ServerInfo getOpts opts = do diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/RoomsAndClients.hs --- a/gameServer/RoomsAndClients.hs Fri Nov 12 00:11:22 2010 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,196 +0,0 @@ -module RoomsAndClients( - RoomIndex(), - ClientIndex(), - MRoomsAndClients(), - IRoomsAndClients(), - newRoomsAndClients, - addRoom, - addClient, - removeRoom, - removeClient, - modifyRoom, - modifyClient, - lobbyId, - moveClientToLobby, - moveClientToRoom, - clientRoomM, - clientExists, - client, - room, - client'sM, - room'sM, - allClientsM, - clientsM, - roomClientsM, - roomClientsIndicesM, - withRoomsAndClients, - allRooms, - allClients, - clientRoom, - showRooms, - roomClients - ) where - - -import Store -import Control.Monad - - -data Room r = Room { - roomClients' :: [ClientIndex], - room' :: r - } - - -data Client c = Client { - clientRoom' :: RoomIndex, - client' :: c - } - - -newtype RoomIndex = RoomIndex ElemIndex - deriving (Eq) -newtype ClientIndex = ClientIndex ElemIndex - deriving (Eq, Show, Read, Ord) - -instance Show RoomIndex where - show (RoomIndex i) = 'r' : show i - -unRoomIndex :: RoomIndex -> ElemIndex -unRoomIndex (RoomIndex r) = r - -unClientIndex :: ClientIndex -> ElemIndex -unClientIndex (ClientIndex c) = c - - -newtype MRoomsAndClients r c = MRoomsAndClients (MStore (Room r), MStore (Client c)) -newtype IRoomsAndClients r c = IRoomsAndClients (IStore (Room r), IStore (Client c)) - - -lobbyId :: RoomIndex -lobbyId = RoomIndex firstIndex - - -newRoomsAndClients :: r -> IO (MRoomsAndClients r c) -newRoomsAndClients r = do - rooms <- newStore - clients <- newStore - let rnc = MRoomsAndClients (rooms, clients) - ri <- addRoom rnc r - when (ri /= lobbyId) $ error "Empty struct inserts not at firstIndex index" - return rnc - - -roomAddClient :: ClientIndex -> Room r -> Room r -roomAddClient cl room = let cls = cl : roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr - -roomRemoveClient :: ClientIndex -> Room r -> Room r -roomRemoveClient cl room = let cls = filter (/= cl) $ roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr - - -addRoom :: MRoomsAndClients r c -> r -> IO RoomIndex -addRoom (MRoomsAndClients (rooms, _)) room = do - i <- addElem rooms (Room [] room) - return $ RoomIndex i - - -addClient :: MRoomsAndClients r c -> c -> IO ClientIndex -addClient (MRoomsAndClients (rooms, clients)) client = do - i <- addElem clients (Client lobbyId client) - modifyElem rooms (roomAddClient (ClientIndex i)) (unRoomIndex lobbyId) - return $ ClientIndex i - -removeRoom :: MRoomsAndClients r c -> RoomIndex -> IO () -removeRoom rnc@(MRoomsAndClients (rooms, _)) room@(RoomIndex ri) - | room == lobbyId = error "Cannot delete lobby" - | otherwise = do - clIds <- liftM roomClients' $ readElem rooms ri - forM_ clIds (moveClientToLobby rnc) - removeElem rooms ri - - -removeClient :: MRoomsAndClients r c -> ClientIndex -> IO () -removeClient (MRoomsAndClients (rooms, clients)) cl@(ClientIndex ci) = do - RoomIndex ri <- liftM clientRoom' $ readElem clients ci - modifyElem rooms (roomRemoveClient cl) ri - removeElem clients ci - - -modifyRoom :: MRoomsAndClients r c -> (r -> r) -> RoomIndex -> IO () -modifyRoom (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = modifyElem rooms (\r -> r{room' = f $ room' r}) ri - -modifyClient :: MRoomsAndClients r c -> (c -> c) -> ClientIndex -> IO () -modifyClient (MRoomsAndClients (_, clients)) f (ClientIndex ci) = modifyElem clients (\c -> c{client' = f $ client' c}) ci - -moveClientInRooms :: MRoomsAndClients r c -> RoomIndex -> RoomIndex -> ClientIndex -> IO () -moveClientInRooms (MRoomsAndClients (rooms, clients)) (RoomIndex riFrom) rt@(RoomIndex riTo) cl@(ClientIndex ci) = do - modifyElem rooms (roomRemoveClient cl) riFrom - modifyElem rooms (roomAddClient cl) riTo - modifyElem clients (\c -> c{clientRoom' = rt}) ci - - -moveClientToLobby :: MRoomsAndClients r c -> ClientIndex -> IO () -moveClientToLobby rnc ci = do - room <- clientRoomM rnc ci - moveClientInRooms rnc room lobbyId ci - - -moveClientToRoom :: MRoomsAndClients r c -> RoomIndex -> ClientIndex -> IO () -moveClientToRoom rnc ri ci = moveClientInRooms rnc lobbyId ri ci - - -clientExists :: MRoomsAndClients r c -> ClientIndex -> IO Bool -clientExists (MRoomsAndClients (_, clients)) (ClientIndex ci) = elemExists clients ci - -clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex -clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (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) - -room'sM :: MRoomsAndClients r c -> (r -> a) -> RoomIndex -> IO a -room'sM (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = liftM (f . room') (rooms `readElem` ri) - -allClientsM :: MRoomsAndClients r c -> IO [ClientIndex] -allClientsM (MRoomsAndClients (_, clients)) = liftM (map ClientIndex) $ indicesM clients - -clientsM :: MRoomsAndClients r c -> IO [c] -clientsM (MRoomsAndClients (_, clients)) = indicesM clients >>= mapM (\ci -> liftM client' $ readElem clients ci) - -roomClientsIndicesM :: MRoomsAndClients r c -> RoomIndex -> IO [ClientIndex] -roomClientsIndicesM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) - -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)) - ----------------------------------------- ------------ IRoomsAndClients ----------- - -showRooms :: (Show r, Show c) => IRoomsAndClients r c -> String -showRooms rnc@(IRoomsAndClients (rooms, clients)) = concatMap showRoom (allRooms rnc) - where - showRoom r = unlines $ ((show r) ++ ": " ++ (show $ room' $ rooms ! (unRoomIndex r))) : (map showClient (roomClients' $ rooms ! (unRoomIndex r))) - showClient c = " " ++ (show c) ++ ": " ++ (show $ client' $ clients ! (unClientIndex c)) - - -allRooms :: IRoomsAndClients r c -> [RoomIndex] -allRooms (IRoomsAndClients (rooms, _)) = map RoomIndex $ indices rooms - -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) diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/ServerCore.hs --- a/gameServer/ServerCore.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/ServerCore.hs Fri Nov 12 09:49:46 2010 +0100 @@ -2,75 +2,69 @@ import Network import Control.Concurrent +import Control.Concurrent.STM import Control.Concurrent.Chan import Control.Monad import qualified Data.IntMap as IntMap import System.Log.Logger -import Control.Monad.Reader -import Control.Monad.State.Strict -import Data.Set as Set -import qualified Data.ByteString.Char8 as B -------------------------------------- import CoreTypes import NetRoutines +import Utils import HWProtoCore import Actions import OfficialServer.DBInteraction -import ServerState - - -timerLoop :: Int -> Chan CoreMessage -> IO () -timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan -reactCmd :: [B.ByteString] -> StateT ServerState IO () -reactCmd cmd = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) - forM_ actions processAction +timerLoop :: Int -> Chan CoreMessage -> IO() +timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan + +firstAway (_, a, b, c) = (a, b, c) + +reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) +reactCmd serverInfo clID cmd clients rooms = + liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd -mainLoop :: StateT ServerState IO () -mainLoop = forever $ do - get >>= \s -> put $! s - - si <- gets serverInfo - r <- liftIO $ readChan $ coreChan si - - case r of - Accept ci -> processAction (AddClient ci) - - ClientMessage (ci, cmd) -> do - liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd) +mainLoop :: ServerInfo -> Clients -> Rooms -> IO () +mainLoop serverInfo clients rooms = do + r <- readChan $ coreChan serverInfo + + (newServerInfo, mClients, mRooms) <- + case r of + Accept ci -> + liftM firstAway $ processAction + (clientUID ci, serverInfo, clients, rooms) (AddClient ci) - removed <- gets removedClients - when (not $ ci `Set.member` removed) $ do - as <- get - put $! as{clientIndex = Just ci} - reactCmd cmd - - Remove ci -> do - liftIO $ debugM "Clients" $ "DeleteClient: " ++ show ci - processAction (DeleteClient ci) + ClientMessage (clID, cmd) -> do + debugM "Clients" $ (show clID) ++ ": " ++ (show cmd) + if clID `IntMap.member` clients then + reactCmd serverInfo clID cmd clients rooms + else + do + debugM "Clients" "Message from dead client" + return (serverInfo, clients, rooms) - --else - --do - --debugM "Clients" "Message from dead client" - --return (serverInfo, rnc) + ClientAccountInfo (clID, info) -> + if clID `IntMap.member` clients then + liftM firstAway $ processAction + (clID, serverInfo, clients, rooms) + (ProcessAccountInfo info) + else + do + debugM "Clients" "Got info for dead client" + return (serverInfo, clients, rooms) - ClientAccountInfo (ci, info) -> do - rnc <- gets roomsClients - exists <- liftIO $ clientExists rnc ci - when (exists) $ do - as <- get - put $! as{clientIndex = Just ci} - processAction (ProcessAccountInfo info) - return () + TimerAction tick -> + liftM firstAway $ + foldM processAction (0, serverInfo, clients, rooms) $ + PingAll : [StatsAction | even tick] + - TimerAction tick -> - mapM_ processAction $ - PingAll : [StatsAction | even tick] + {- let hadRooms = (not $ null rooms) && (null mrooms) + in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ + mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} + mainLoop newServerInfo mClients mRooms startServer :: ServerInfo -> Socket -> IO () startServer serverInfo serverSocket = do @@ -80,15 +74,14 @@ acceptLoop serverSocket (coreChan serverInfo) + 0 return () - - --forkIO $ timerLoop 0 $ coreChan serverInfo + + forkIO $ timerLoop 0 $ coreChan serverInfo startDBConnection serverInfo - rnc <- newRoomsAndClients newRoom + forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom) - forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo Set.empty rnc) - - forever $ threadDelay (60 * 60 * 10^6) + forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" \ No newline at end of file diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/ServerState.hs --- a/gameServer/ServerState.hs Fri Nov 12 00:11:22 2010 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -module ServerState - ( - module RoomsAndClients, - clientRoomA, - ServerState(..), - client's, - allClientsS, - roomClientsS - ) where - -import Control.Monad.State.Strict -import Data.Set as Set ----------------------- -import RoomsAndClients -import CoreTypes - -data ServerState = ServerState { - clientIndex :: !(Maybe ClientIndex), - serverInfo :: !ServerInfo, - removedClients :: !(Set.Set ClientIndex), - roomsClients :: !MRnC - } - - -clientRoomA :: StateT ServerState IO RoomIndex -clientRoomA = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - liftIO $ clientRoomM rnc ci - -client's :: (ClientInfo -> a) -> StateT ServerState IO a -client's f = do - (Just ci) <- gets clientIndex - rnc <- gets roomsClients - liftIO $ client'sM rnc f ci - -allClientsS :: StateT ServerState IO [ClientInfo] -allClientsS = gets roomsClients >>= liftIO . clientsM - -roomClientsS :: RoomIndex -> StateT ServerState IO [ClientInfo] -roomClientsS ri = do - rnc <- gets roomsClients - liftIO $ roomClientsM rnc ri diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/Store.hs --- a/gameServer/Store.hs Fri Nov 12 00:11:22 2010 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,145 +0,0 @@ -module Store( - ElemIndex(), - MStore(), - IStore(), - newStore, - addElem, - removeElem, - readElem, - writeElem, - modifyElem, - elemExists, - firstIndex, - indicesM, - withIStore, - withIStore2, - (!), - indices - ) where - -import qualified Data.Array.IArray as IA -import qualified Data.Array.IO as IOA -import qualified Data.IntSet as IntSet -import Data.IORef -import Control.Monad - - -newtype ElemIndex = ElemIndex Int - 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) - - -firstIndex :: ElemIndex -firstIndex = ElemIndex 0 - --- MStore code -initialSize :: Int -initialSize = 10 - - -growFunc :: Int -> Int -growFunc a = a * 3 `div` 2 - - -newStore :: IO (MStore e) -newStore = do - newar <- IOA.newArray_ (0, initialSize - 1) - new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar) - return (MStore new) - - -growStore :: MStore e -> IO () -growStore (MStore ref) = do - (busyElems, freeElems, arr) <- readIORef ref - (_, m') <- IOA.getBounds arr - let newM' = growFunc (m' + 1) - 1 - newArr <- IOA.newArray_ (0, newM') - sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']] - writeIORef ref (busyElems, freeElems `IntSet.union` (IntSet.fromAscList [m'+1..newM']), newArr) - - -growIfNeeded :: MStore e -> IO () -growIfNeeded m@(MStore ref) = do - (_, freeElems, _) <- readIORef ref - when (IntSet.null freeElems) $ growStore m - - -addElem :: MStore e -> e -> IO ElemIndex -addElem m@(MStore ref) element = do - growIfNeeded m - (busyElems, freeElems, arr) <- readIORef ref - let (n, freeElems') = IntSet.deleteFindMin freeElems - IOA.writeArray arr n element - writeIORef ref (IntSet.insert n busyElems, freeElems', arr) - return $ ElemIndex n - - -removeElem :: MStore e -> ElemIndex -> IO () -removeElem (MStore ref) (ElemIndex n) = do - (busyElems, freeElems, arr) <- readIORef ref - IOA.writeArray arr n (error $ "Store: no element " ++ show n) - writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr) - - -readElem :: MStore e -> ElemIndex -> IO e -readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n - - -writeElem :: MStore e -> ElemIndex -> e -> IO () -writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el - - -modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO () -modifyElem (MStore ref) f (ElemIndex n) = do - (_, _, arr) <- readIORef ref - IOA.readArray arr n >>= IOA.writeArray arr n . f - -elemExists :: MStore e -> ElemIndex -> IO Bool -elemExists (MStore ref) (ElemIndex n) = do - (_, free, _) <- readIORef ref - return $ n `IntSet.notMember` free - -indicesM :: MStore e -> IO [ElemIndex] -indicesM (MStore ref) = do - (busy, _, _) <- readIORef ref - return $ map ElemIndex $ IntSet.toList busy - - --- A way to see MStore elements in pure code via IStore -m2i :: MStore e -> IO (IStore e) -m2i (MStore ref) = do - (a, _, c') <- readIORef ref - c <- IOA.unsafeFreeze c' - return $ IStore (a, c) - -i2m :: (MStore e) -> IStore e -> IO () -i2m (MStore ref) (IStore (_, arr)) = do - (b, e, _) <- readIORef ref - a <- IOA.unsafeThaw arr - writeIORef ref (b, e, a) - -withIStore :: MStore e -> (IStore e -> a) -> IO a -withIStore m f = do - i <- m2i m - let res = f i - res `seq` i2m m i - return res - - -withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a -withIStore2 m1 m2 f = do - i1 <- m2i m1 - i2 <- m2i m2 - let res = f i1 i2 - res `seq` i2m m1 i1 - i2m m2 i2 - return res - - --- IStore code -(!) :: IStore e -> ElemIndex -> e -(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i - -indices :: IStore e -> [ElemIndex] -indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/Utils.hs --- a/gameServer/Utils.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/Utils.hs Fri Nov 12 09:49:46 2010 +0100 @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Utils where import Control.Concurrent @@ -14,33 +13,36 @@ import System.IO import qualified Data.List as List import Control.Monad -import Data.Maybe +import Maybe ------------------------------------------------- import qualified Codec.Binary.Base64 as Base64 -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString as BW +import qualified Data.ByteString.UTF8 as BUTF8 +import qualified Data.ByteString as B import CoreTypes -sockAddr2String :: SockAddr -> IO B.ByteString -sockAddr2String (SockAddrInet _ hostAddr) = liftM B.pack $ inet_ntoa hostAddr +sockAddr2String :: SockAddr -> IO String +sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) = - return $ B.pack $ (foldr1 (.) + return $ (foldr1 (.) $ List.intersperse (\a -> ':':a) $ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) [] -toEngineMsg :: B.ByteString -> B.ByteString -toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : (BW.unpack msg)) +toEngineMsg :: String -> String +toEngineMsg msg = Base64.encode (fromIntegral (B.length encodedMsg) : (B.unpack encodedMsg)) + where + encodedMsg = BUTF8.fromString msg -fromEngineMsg :: B.ByteString -> Maybe B.ByteString -fromEngineMsg msg = Base64.decode (B.unpack msg) >>= removeLength >>= return . BW.pack +fromEngineMsg :: String -> Maybe String +fromEngineMsg msg = liftM (map w2c) (Base64.decode msg >>= removeLength) where removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing removeLength _ = Nothing -checkNetCmd :: B.ByteString -> (Bool, Bool) -checkNetCmd = check . liftM B.unpack . fromEngineMsg +checkNetCmd :: String -> (Bool, Bool) +checkNetCmd msg = check decoded where + decoded = fromEngineMsg msg check Nothing = (False, False) check (Just (m:ms)) = (m `Set.member` legalMessages, m == '+') check _ = (False, False) @@ -52,17 +54,29 @@ [(x, rest)] | all isSpace rest -> Just x _ -> Nothing -teamToNet :: TeamInfo -> [B.ByteString] -teamToNet team = - "ADD_TEAM" - : teamname team - : teamgrave team - : teamfort team - : teamvoicepack team - : teamflag team - : teamowner team - : (B.pack $ show $ difficulty team) - : hhsInfo +teamToNet :: Word16 -> TeamInfo -> [String] +teamToNet protocol team + | protocol < 30 = [ + "ADD_TEAM", + teamname team, + teamgrave team, + teamfort team, + teamvoicepack team, + teamowner team, + show $ difficulty team + ] + ++ hhsInfo + | otherwise = [ + "ADD_TEAM", + teamname team, + teamgrave team, + teamfort team, + teamvoicepack team, + teamflag team, + teamowner team, + show $ difficulty team + ] + ++ hhsInfo where hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team @@ -76,10 +90,10 @@ else t : replaceTeam team teams -illegalName :: B.ByteString -> Bool -illegalName = all isSpace . B.unpack +illegalName :: String -> Bool +illegalName = all isSpace -protoNumber2ver :: Word16 -> B.ByteString +protoNumber2ver :: Word16 -> String protoNumber2ver 17 = "0.9.7-dev" protoNumber2ver 19 = "0.9.7" protoNumber2ver 20 = "0.9.8-dev" @@ -102,13 +116,3 @@ putStr msg hFlush stdout getLine - - -unfoldrE :: (b -> Either b (a, b)) -> b -> ([a], b) -unfoldrE f b = - 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 diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/hedgewars-server.cabal --- a/gameServer/hedgewars-server.cabal Fri Nov 12 00:11:22 2010 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -Name: hedgewars-server -Version: 0.1 -Synopsis: hedgewars server -Description: hedgewars server -Homepage: http://www.hedgewars.org/ -License: GPL-2 -Author: unC0Rr -Maintainer: unC0Rr@hedgewars.org -Category: Game -Build-type: Simple -Cabal-version: >=1.2 - - -Executable hedgewars-server - main-is: hedgewars-server.hs - - Build-depends: - base >= 4, - unix, - containers, - array, - bytestring, - network-bytestring, - network, - time, - stm, - mtl, - dataenc, - hslogger, - process - - ghc-options: -O2 \ No newline at end of file diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/hedgewars-server.hs --- a/gameServer/hedgewars-server.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/hedgewars-server.hs Fri Nov 12 09:49:46 2010 +0100 @@ -2,15 +2,22 @@ module Main where -import Network +import Network.Socket +import qualified Network import Control.Concurrent.STM import Control.Concurrent.Chan +#if defined(NEW_EXCEPTIONS) +import qualified Control.OldException as Exception +#else import qualified Control.Exception as Exception +#endif import System.Log.Logger ----------------------------------- import Opts import CoreTypes +import OfficialServer.DBInteraction import ServerCore +import Utils #if !defined(mingw32_HOST_OS) @@ -18,12 +25,10 @@ #endif -setupLoggers :: IO () setupLoggers = updateGlobalLogger "Clients" (setLevel INFO) -main :: IO () main = withSocketsDo $ do #if !defined(mingw32_HOST_OS) installHandler sigPIPE Ignore Nothing; @@ -32,11 +37,11 @@ setupLoggers - stats' <- atomically $ newTMVar (StatisticsInfo 0 0) + stats <- atomically $ newTMVar (StatisticsInfo 0 0) dbQueriesChan <- newChan - coreChan' <- newChan - serverInfo' <- getOpts $ newServerInfo stats' coreChan' dbQueriesChan - + coreChan <- newChan + serverInfo' <- getOpts $ newServerInfo stats coreChan dbQueriesChan + #if defined(OFFICIAL_SERVER) dbHost' <- askFromConsole "DB host: " dbLogin' <- askFromConsole "login: " diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/stresstest.hs --- a/gameServer/stresstest.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/stresstest.hs Fri Nov 12 09:49:46 2010 +0100 @@ -6,7 +6,7 @@ import System.IO import Control.Concurrent import Network -import Control.OldException +import Control.Exception import Control.Monad import System.Random @@ -14,24 +14,24 @@ import System.Posix #endif -session1 nick room = ["NICK", nick, "", "PROTO", "32", "", "PING", "", "CHAT", "lobby 1", "", "CREATE_ROOM", room, "", "CHAT", "room 1", "", "QUIT", "creator", ""] -session2 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROOM", room, "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "part-quit", ""] -session3 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROON", room, "", "CHAT", "room 2", "", "QUIT", "quit", ""] +session1 nick room = ["NICK", nick, "", "PROTO", "24", "", "CHAT", "lobby 1", "", "CREATE", room, "", "CHAT", "room 1", "", "QUIT", "bye-bye", ""] +session2 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "bye-bye", ""] +session3 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT", "room 2", "", "QUIT", "bye-bye", ""] emulateSession sock s = do - mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (30000::Int, 59000) >>= threadDelay) s + mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (50000::Int, 90000) >>= threadDelay) s hFlush sock threadDelay 225000 -testing = Control.OldException.handle print $ do +testing = Control.Exception.handle print $ do putStrLn "Start" sock <- connectTo "127.0.0.1" (PortNumber 46631) num1 <- randomRIO (70000::Int, 70100) num2 <- randomRIO (0::Int, 2) num3 <- randomRIO (0::Int, 5) - let nick1 = 'n' : show num1 - let room1 = 'r' : show num2 + let nick1 = show num1 + let room1 = show num2 case num2 of 0 -> emulateSession sock $ session1 nick1 room1 1 -> emulateSession sock $ session2 nick1 room1 @@ -40,7 +40,7 @@ putStrLn "Finish" forks = forever $ do - delay <- randomRIO (30000::Int, 59000) + delay <- randomRIO (10000::Int, 19000) threadDelay delay forkIO testing diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/stresstest2.hs --- a/gameServer/stresstest2.hs Fri Nov 12 00:11:22 2010 +0100 +++ b/gameServer/stresstest2.hs Fri Nov 12 09:49:46 2010 +0100 @@ -6,7 +6,7 @@ import System.IO import Control.Concurrent import Network -import Control.OldException +import Control.Exception import Control.Monad import System.Random @@ -14,28 +14,22 @@ import System.Posix #endif -session1 nick room = ["NICK", nick, "", "PROTO", "32", ""] - - - -testing = Control.OldException.handle print $ do - putStrLn "Start" +testing = Control.Exception.handle print $ do + delay <- randomRIO (100::Int, 300) + threadDelay delay sock <- connectTo "127.0.0.1" (PortNumber 46631) + hClose sock - num1 <- randomRIO (70000::Int, 70100) - num2 <- randomRIO (0::Int, 2) - num3 <- randomRIO (0::Int, 5) - let nick1 = 'n' : show num1 - let room1 = 'r' : show num2 - mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (300::Int, 590) >>= threadDelay) $ session1 nick1 room1 - mapM_ (\x -> hPutStrLn sock x >> hFlush sock) $ concatMap (\x -> ["CHAT_MSG", show x, ""]) [1..] - hClose sock - putStrLn "Finish" - -forks = testing +forks i = do + delay <- randomRIO (50::Int, 190) + if i `mod` 10 == 0 then putStr (show i) else putStr "." + hFlush stdout + threadDelay delay + forkIO testing + forks (i + 1) main = withSocketsDo $ do #if !defined(mingw32_HOST_OS) installHandler sigPIPE Ignore Nothing; #endif - forks + forks 1 diff -r bf46b4bdf27d -r 3084dc7b4624 gameServer/stresstest3.hs --- a/gameServer/stresstest3.hs Fri Nov 12 00:11:22 2010 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Main where - -import IO -import System.IO -import Control.Concurrent -import Network -import Control.OldException -import Control.Monad -import System.Random -import Control.Monad.State -import Data.List - -#if !defined(mingw32_HOST_OS) -import System.Posix -#endif - -type SState = Handle -io = liftIO - -readPacket :: StateT SState IO [String] -readPacket = do - h <- get - p <- io $ hGetPacket h [] - return p - where - hGetPacket h buf = do - l <- hGetLine h - if (not $ null l) then hGetPacket h (buf ++ [l]) else return buf - -waitPacket :: String -> StateT SState IO Bool -waitPacket s = do - p <- readPacket - return $ head p == s - -sendPacket :: [String] -> StateT SState IO () -sendPacket s = do - h <- get - io $ do - mapM_ (hPutStrLn h) s - hPutStrLn h "" - hFlush h - -emulateSession :: StateT SState IO () -emulateSession = do - n <- io $ randomRIO (100000::Int, 100100) - waitPacket "CONNECTED" - sendPacket ["NICK", "test" ++ (show n)] - waitPacket "NICK" - sendPacket ["PROTO", "31"] - waitPacket "PROTO" - b <- waitPacket "LOBBY:JOINED" - --io $ print b - sendPacket ["QUIT", "BYE"] - return () - -testing = Control.OldException.handle print $ do - putStr "+" - sock <- connectTo "127.0.0.1" (PortNumber 46631) - evalStateT emulateSession sock - --hClose sock - putStr "-" - hFlush stdout - -forks = forM_ [1..100] $ const $ do - delay <- randomRIO (10000::Int, 30000) - threadDelay delay - forkIO testing - -main = withSocketsDo $ do -#if !defined(mingw32_HOST_OS) - installHandler sigPIPE Ignore Nothing; -#endif - forks