--- a/CMakeLists.txt Wed Feb 02 09:05:48 2011 +0100
+++ b/CMakeLists.txt Wed Feb 02 11:28:38 2011 +0300
@@ -159,10 +159,10 @@
if(Optz)
# set(pascal_compiler_flags_cmn "-O3" "-OpPENTIUM4" "-CfSSE3" "-Xs" "-Si" ${pascal_compiler_flags_cmn})
set(pascal_compiler_flags_cmn "-O2" "-Xs" "-Si" ${pascal_compiler_flags_cmn})
- set(haskell_compiler_flags_cmn "-O2" "-w")
+ set(haskell_compiler_flags_cmn "-O2" "-w" "-fno-warn-unused-do-bind")
else(Optz)
set(pascal_compiler_flags_cmn "-O-" "-g" "-gh" "-gl" "-dDEBUGFILE" ${pascal_compiler_flags_cmn})
- set(haskell_compiler_flags_cmn "-Wall" "-debug" "-dcore-lint")
+ set(haskell_compiler_flags_cmn "-Wall" "-debug" "-dcore-lint" "-fno-warn-unused-do-bind")
endif(Optz)
--- a/gameServer/Actions.hs Wed Feb 02 09:05:48 2011 +0100
+++ b/gameServer/Actions.hs Wed Feb 02 11:28:38 2011 +0300
@@ -1,449 +1,414 @@
-module Actions where
-
-import Control.Concurrent.STM
-import Control.Concurrent.Chan
-import Data.IntMap
-import qualified Data.IntSet as IntSet
-import qualified Data.Sequence as Seq
-import System.Log.Logger
-import Control.Monad
-import Data.Time
-import Data.Maybe
------------------------------
-import CoreTypes
-import Utils
-
-data Action =
- AnswerThisClient [String]
- | AnswerAll [String]
- | AnswerAllOthers [String]
- | AnswerThisRoom [String]
- | AnswerOthersInRoom [String]
- | AnswerSameClan [String]
- | AnswerLobby [String]
- | SendServerMessage
- | SendServerVars
- | RoomAddThisClient Int -- roomID
- | RoomRemoveThisClient String
- | RemoveTeam String
- | RemoveRoom
- | UnreadyRoomClients
- | MoveToLobby
- | ProtocolError String
- | Warning String
- | ByeClient String
- | KickClient Int -- clID
- | KickRoomClient Int -- clID
- | BanClient String -- nick
- | RemoveClientTeams Int -- clID
- | ModifyClient (ClientInfo -> ClientInfo)
- | ModifyClient2 Int (ClientInfo -> ClientInfo)
- | ModifyRoom (RoomInfo -> RoomInfo)
- | ModifyServerInfo (ServerInfo -> ServerInfo)
- | AddRoom String String
- | CheckRegistered
- | ClearAccountsCache
- | ProcessAccountInfo AccountInfo
- | Dump
- | AddClient ClientInfo
- | PingAll
- | StatsAction
-
-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 (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 (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 (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 (clID, serverInfo, clients, rooms) SendServerVars = do
- writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)
- return (clID, serverInfo, clients, rooms)
- where
- client = clients ! clID
- vars = [
- "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 (clID, serverInfo, clients, rooms) (Warning msg) = do
- writeChan (sendChan $ clients ! clID) ["WARNING", msg]
- return (clID, serverInfo, clients, rooms)
-
-
-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)
-
- 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
- answerInformRoom =
- if roomID client /= 0 then
- if not $ Prelude.null msg then
- [AnswerThisRoom ["LEFT", clientNick, msg]]
- else
- [AnswerThisRoom ["LEFT", clientNick]]
- else
- []
- answerOthersQuit =
- if logonPassed client then
- if not $ Prelude.null msg then
- [AnswerAll ["LOBBY:LEFT", clientNick, msg]]
- else
- [AnswerAll ["LOBBY:LEFT", clientNick]]
- else
- []
-
-
-processAction (clID, serverInfo, clients, rooms) (ModifyClient func) =
- return (clID, serverInfo, adjust func clID clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) =
- return (clID, serverInfo, adjust func cl2ID clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) =
- return (clID, serverInfo, clients, adjust func rID rooms)
- where
- rID = roomID $ clients ! clID
-
-
-processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) =
- return (clID, func serverInfo, clients, rooms)
-
-
-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 (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
- [AnswerOthersInRoom ["LEFT", nick client, msg],
- AnswerOthersInRoom ["WARNING", "Admin left the room"],
- RemoveClientTeams clID]))
- else -- not in game
- processAction (clID, serverInfo, clients, rooms) RemoveRoom
- else -- not master
- foldM
- processAction
- (clID, serverInfo, clients, rooms)
- [AnswerOthersInRoom ["LEFT", nick client, msg],
- RemoveClientTeams clID]
- else -- in lobby
- return (clID, serverInfo, clients, rooms)
-
- return (
- clID,
- serverInfo,
- adjust resetClientFlags clID newClients,
- adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
- )
- where
- rID = roomID client
- client = clients ! clID
- room = rooms ! rID
- resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined}
- removeClientFromRoom r = r{
- playersIDs = otherPlayersSet,
- playersIn = (playersIn r) - 1,
- readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r
- }
- insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}
- changeMaster = do
- processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
- return (
- clID,
- serverInfo,
- adjust (\cl -> cl{isMaster = True}) newMasterId clients,
- adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms
- )
- newRoomName = nick newMasterClient
- otherPlayersSet = IntSet.delete clID (playersIDs room)
- newMasterId = IntSet.findMin otherPlayersSet
- newMasterClient = clients ! newMasterId
-
-
-processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do
- let newServerInfo = serverInfo {nextRoomID = newID}
- let room = newRoom{
- roomUID = newID,
- masterID = clID,
- name = roomName,
- password = roomPassword,
- roomProto = (clientProto client)
- }
-
- processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName]
-
- 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, 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,
- delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms
- )
- where
- room = rooms ! rID
- rID = roomID client
- client = clients ! clID
-
-
-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 (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
- 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
- room = rooms ! rID
- rID = roomID client
- client = clients ! clID
- rmTeamMsg = toEngineMsg $ 'F' : teamName
-
-
-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, 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, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) =
- case info of
- HasAccount passwd isAdmin -> do
- infoM "Clients" $ show clID ++ " has account"
- writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]
- return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms)
- Guest -> do
- infoM "Clients" $ show clID ++ " is guest"
- processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby
- Admin -> do
- 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 (clID, serverInfo, clients, rooms) (MoveToLobby) =
- foldM processAction (clID, serverInfo, clients, rooms) $
- (RoomAddThisClient 0)
- : answerLobbyNicks
- ++ [SendServerMessage]
-
- -- ++ (answerServerMessage client clients)
- where
- lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients
- answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]
-
-
-processAction (clID, serverInfo, clients, rooms) (KickClient kickID) = do
- let client = clients ! kickID
- currentTime <- getCurrentTime
- liftM2 replaceID (return clID) (processAction (kickID, serverInfo{lastLogins = (host client, (addUTCTime 60 $ currentTime, "60 seconds ban")) : lastLogins serverInfo}, clients, rooms) $ ByeClient "Kicked")
-
-
-processAction (clID, serverInfo, clients, rooms) (BanClient banNick) =
- return (clID, serverInfo, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do
- writeChan (sendChan $ clients ! kickID) ["KICKED"]
- liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked")
-
-
-processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) =
- liftM2 replaceID (return clID) $
- 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 (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/"]
-
- let newLogins = takeWhile (\(_ , (time, _)) -> (connectTime client) `diffUTCTime` time <= 0) $ lastLogins serverInfo
-
- let info = host client `Prelude.lookup` newLogins
- if isJust info then
- processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient (snd . fromJust $ info)
- else
- return (clID, serverInfo{lastLogins = (host client, (addUTCTime 10 $ connectTime client, "Reconnected too fast")) : newLogins}, updatedClients, rooms)
-
-
-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 (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 (clID, serverInfo, clients, rooms) (StatsAction) = do
- writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)
- return (clID, serverInfo, clients, rooms)
+{-# LANGUAGE OverloadedStrings #-}
+module Actions where
+
+import Control.Concurrent
+import Control.Concurrent.Chan
+import qualified Data.IntSet as IntSet
+import qualified Data.Set as Set
+import qualified Data.Sequence as Seq
+import System.Log.Logger
+import Control.Monad
+import Data.Time
+import Data.Maybe
+import Control.Monad.Reader
+import Control.Monad.State.Strict
+import qualified Data.ByteString.Char8 as B
+import Control.DeepSeq
+-----------------------------
+import CoreTypes
+import Utils
+import ClientIO
+import ServerState
+
+data Action =
+ AnswerClients ![ClientChan] ![B.ByteString]
+ | SendServerMessage
+ | SendServerVars
+ | MoveToRoom RoomIndex
+ | MoveToLobby B.ByteString
+ | RemoveTeam B.ByteString
+ | RemoveRoom
+ | UnreadyRoomClients
+ | JoinLobby
+ | ProtocolError B.ByteString
+ | Warning B.ByteString
+ | NoticeMessage Notice
+ | ByeClient B.ByteString
+ | KickClient ClientIndex
+ | KickRoomClient ClientIndex
+ | BanClient B.ByteString
+ | ChangeMaster
+ | RemoveClientTeams ClientIndex
+ | ModifyClient (ClientInfo -> ClientInfo)
+ | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
+ | ModifyRoom (RoomInfo -> RoomInfo)
+ | ModifyServerInfo (ServerInfo -> ServerInfo)
+ | AddRoom B.ByteString B.ByteString
+ | CheckRegistered
+ | ClearAccountsCache
+ | ProcessAccountInfo AccountInfo
+ | AddClient ClientInfo
+ | DeleteClient ClientIndex
+ | PingAll
+ | StatsAction
+
+type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
+
+instance NFData Action where
+ rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
+ rnf a = a `seq` ()
+
+instance NFData B.ByteString
+instance NFData (Chan a)
+
+othersChans = do
+ cl <- client's id
+ ri <- clientRoomA
+ liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
+
+processAction :: Action -> StateT ServerState IO ()
+
+
+processAction (AnswerClients chans msg) = do
+ io $ mapM_ (flip writeChan (msg `deepseq` msg)) (chans `deepseq` chans)
+
+
+processAction SendServerMessage = do
+ chan <- client's sendChan
+ protonum <- client's clientProto
+ si <- liftM serverInfo get
+ let message = if protonum < latestReleaseVersion si then
+ serverMessageForOldVersions si
+ else
+ serverMessage si
+ processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
+
+
+processAction SendServerVars = do
+ chan <- client's sendChan
+ si <- gets serverInfo
+ io $ writeChan chan ("SERVER_VARS" : vars si)
+ where
+ vars si = [
+ "MOTD_NEW", serverMessage si,
+ "MOTD_OLD", serverMessageForOldVersions si,
+ "LATEST_PROTO", B.pack . show $ latestReleaseVersion si
+ ]
+
+
+processAction (ProtocolError msg) = do
+ chan <- client's sendChan
+ processAction $ AnswerClients [chan] ["ERROR", msg]
+
+
+processAction (Warning msg) = do
+ chan <- client's sendChan
+ processAction $ AnswerClients [chan] ["WARNING", msg]
+
+processAction (NoticeMessage n) = do
+ chan <- client's sendChan
+ processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n]
+
+processAction (ByeClient msg) = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ ri <- clientRoomA
+
+ chan <- client's sendChan
+ clNick <- client's nick
+
+ when (ri /= lobbyId) $ do
+ processAction $ MoveToLobby ("quit: " `B.append` msg)
+ return ()
+
+ clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
+ io $ do
+ infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg))
+
+ processAction $ AnswerClients [chan] ["BYE", msg]
+ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
+
+ s <- get
+ put $! s{removedClients = ci `Set.insert` removedClients s}
+
+processAction (DeleteClient ci) = do
+ rnc <- gets roomsClients
+ io $ removeClient rnc ci
+
+ s <- get
+ put $! s{removedClients = ci `Set.delete` removedClients s}
+
+processAction (ModifyClient f) = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ io $ modifyClient rnc f ci
+ return ()
+
+processAction (ModifyClient2 ci f) = do
+ rnc <- gets roomsClients
+ io $ modifyClient rnc f ci
+ return ()
+
+
+processAction (ModifyRoom f) = do
+ rnc <- gets roomsClients
+ ri <- clientRoomA
+ io $ modifyRoom rnc f ri
+ return ()
+
+
+processAction (ModifyServerInfo f) =
+ modify (\s -> s{serverInfo = f $ serverInfo s})
+
+
+processAction (MoveToRoom ri) = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+
+ io $ do
+ modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci
+ modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri
+ moveClientToRoom rnc ri ci
+
+ chans <- liftM (map sendChan) $ roomClientsS ri
+ clNick <- client's nick
+
+ processAction $ AnswerClients chans ["JOINED", clNick]
+
+
+processAction (MoveToLobby msg) = do
+ (Just ci) <- gets clientIndex
+ ri <- clientRoomA
+ rnc <- gets roomsClients
+ (gameProgress, playersNum) <- io $ room'sM rnc (\r -> (gameinprogress r, playersIn r)) ri
+ ready <- client's isReady
+ master <- client's isMaster
+-- client <- client's id
+ clNick <- client's nick
+ chans <- othersChans
+
+ if master then
+ if gameProgress && playersNum > 1 then
+ mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci]
+ else
+ processAction RemoveRoom
+ else
+ mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
+
+ io $ do
+ modifyRoom rnc (\r -> r{
+ playersIn = (playersIn r) - 1,
+ readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
+ }) ri
+ moveClientToLobby rnc ci
+
+processAction ChangeMaster = do
+ ri <- clientRoomA
+ rnc <- gets roomsClients
+ newMasterId <- liftM head . io $ roomClientsIndicesM rnc ri
+ newMaster <- io $ client'sM rnc id newMasterId
+ let newRoomName = nick newMaster
+ mapM_ processAction [
+ ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}),
+ ModifyClient2 newMasterId (\c -> c{isMaster = True}),
+ AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
+ ]
+
+processAction (AddRoom roomName roomPassword) = do
+ Just clId <- gets clientIndex
+ rnc <- gets roomsClients
+ proto <- io $ client'sM rnc clientProto clId
+
+ let room = newRoom{
+ masterID = clId,
+ name = roomName,
+ password = roomPassword,
+ roomProto = proto
+ }
+
+ rId <- io $ addRoom rnc room
+
+ processAction $ MoveToRoom rId
+
+ chans <- liftM (map sendChan) $! roomClientsS lobbyId
+
+ mapM_ processAction [
+ AnswerClients chans ["ROOM", "ADD", roomName]
+ , ModifyClient (\cl -> cl{isMaster = True})
+ ]
+
+
+processAction RemoveRoom = do
+ Just clId <- gets clientIndex
+ rnc <- gets roomsClients
+ ri <- io $ clientRoomM rnc clId
+ roomName <- io $ room'sM rnc name ri
+ others <- othersChans
+ lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId
+
+ mapM_ processAction [
+ AnswerClients lobbyChans ["ROOM", "DEL", roomName],
+ AnswerClients others ["ROOMABANDONED", roomName]
+ ]
+
+ io $ removeRoom rnc ri
+
+
+processAction (UnreadyRoomClients) = do
+ rnc <- gets roomsClients
+ ri <- clientRoomA
+ roomPlayers <- roomClientsS ri
+ roomClIDs <- io $ roomClientsIndicesM rnc ri
+ processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers)
+ io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
+ processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
+
+
+processAction (RemoveTeam teamName) = do
+ rnc <- gets roomsClients
+ cl <- client's id
+ ri <- clientRoomA
+ inGame <- io $ room'sM rnc gameinprogress ri
+ chans <- othersChans
+ if inGame then
+ mapM_ processAction [
+ AnswerClients chans ["REMOVE_TEAM", teamName],
+ ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r})
+ ]
+ 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
+ })
+ ]
+ where
+ rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName
+
+
+processAction (RemoveClientTeams clId) = do
+ rnc <- gets roomsClients
+
+ removeTeamActions <- io $ do
+ clNick <- client'sM rnc nick clId
+ rId <- clientRoomM rnc clId
+ roomTeams <- room'sM rnc teams rId
+ return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
+
+ mapM_ processAction removeTeamActions
+
+
+
+processAction CheckRegistered = do
+ (Just ci) <- gets clientIndex
+ n <- client's nick
+ h <- client's host
+ db <- gets (dbQueries . serverInfo)
+ io $ writeChan db $ CheckAccount ci n h
+ return ()
+
+
+processAction ClearAccountsCache = do
+ dbq <- gets (dbQueries . serverInfo)
+ io $ writeChan dbq ClearCache
+ return ()
+
+
+processAction (ProcessAccountInfo info) =
+ case info of
+ HasAccount passwd isAdmin -> do
+ chan <- client's sendChan
+ processAction $ AnswerClients [chan] ["ASKPASSWORD"]
+ Guest -> do
+ processAction JoinLobby
+ Admin -> do
+ mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
+ chan <- client's sendChan
+ processAction $ AnswerClients [chan] ["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, rnc) (RoomAddThisClient rID) =
+ processAction (
+ clID,
+ serverInfo,
+ adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
+ adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
+ adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
+ ) joinMsg
+ where
+ client = clients ! clID
+ joinMsg = if rID == 0 then
+ AnswerAllOthers ["LOBBY:JOINED", nick client]
+ else
+ AnswerThisRoom ["JOINED", nick client]
+
+processAction (clID, serverInfo, rnc) (KickClient kickID) =
+ liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked")
+
+
+processAction (clID, serverInfo, rnc) (BanClient banNick) =
+ return (clID, serverInfo, rnc)
+
+
+processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do
+ writeChan (sendChan $ clients ! kickID) ["KICKED"]
+ liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked")
+
+-}
+
+processAction (AddClient client) = do
+ rnc <- gets roomsClients
+ si <- gets serverInfo
+ io $ do
+ ci <- addClient rnc client
+ t <- forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci
+ forkIO $ clientSendLoop (clientSocket client) t (coreChan si) (sendChan client) ci
+
+ 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
+
+ if False && (isJust $ host client `Prelude.lookup` newLogins) then
+ processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast"
+ else
+ return (ci, serverInfo)
+-}
+
+
+
+processAction PingAll = do
+ rnc <- gets roomsClients
+ io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
+ cis <- io $ allClientsM rnc
+ chans <- io $ mapM (client'sM rnc sendChan) cis
+ io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
+ processAction $ AnswerClients chans ["PING"]
+ where
+ kickTimeouted rnc ci = do
+ pq <- io $ client'sM rnc pingsQueue ci
+ when (pq > 0) $
+ withStateT (\as -> as{clientIndex = Just ci}) $
+ processAction (ByeClient "Ping timeout")
+
+
+processAction (StatsAction) = do
+ rnc <- gets roomsClients
+ si <- gets serverInfo
+ (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc stats
+ io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
+ where
+ stats irnc = (length $ allRooms irnc, length $ allClients irnc)
+
--- a/gameServer/ClientIO.hs Wed Feb 02 09:05:48 2011 +0100
+++ b/gameServer/ClientIO.hs Wed Feb 02 11:28:38 2011 +0300
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
module ClientIO where
import qualified Control.Exception as Exception
@@ -6,45 +6,75 @@
import Control.Concurrent
import Control.Monad
import System.IO
-import qualified Data.ByteString.UTF8 as BUTF8
-import qualified Data.ByteString as B
+import Network
+import Network.Socket.ByteString
+import qualified Data.ByteString.Char8 as B
----------------
import CoreTypes
+import RoomsAndClients
+import Utils
-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 > 20000) 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
+
+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)
+
-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
+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)
-clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO()
-clientSendLoop handle coreChan chan clientID = do
+
+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 = writeChan chan $ ClientMessage (ci, ["QUIT", msg])
+
+
+
+clientSendLoop :: Socket -> ThreadId -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO ()
+clientSendLoop s tId coreChan chan ci = 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
+ Exception.handle
+ (\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do
+ sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n')
- if doClose then
- Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle
+ if (isQuit answer) then
+ do
+ Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s
+ killThread tId
+ writeChan coreChan $ Remove ci
else
- clientSendLoop handle coreChan chan clientID
+ clientSendLoop s tId coreChan chan ci
where
- sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
+ sendQuit e = do
+ putStrLn $ show e
+ writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e])
isQuit ("BYE":xs) = True
isQuit _ = False
--- a/gameServer/CoreTypes.hs Wed Feb 02 09:05:48 2011 +0100
+++ b/gameServer/CoreTypes.hs Wed Feb 02 11:28:38 2011 +0300
@@ -1,106 +1,101 @@
+{-# LANGUAGE OverloadedStrings #-}
module CoreTypes where
import System.IO
+import Control.Concurrent
import Control.Concurrent.Chan
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
{
- clientUID :: !Int,
- sendChan :: Chan [String],
- clientHandle :: Handle,
- host :: String,
+ sendChan :: ClientChan,
+ clientSocket :: Socket,
+ host :: B.ByteString,
connectTime :: UTCTime,
- nick :: String,
- webPassword :: String,
+ nick :: B.ByteString,
+ webPassword :: B.ByteString,
logonPassed :: Bool,
clientProto :: !Word16,
- roomID :: !Int,
+ roomID :: RoomIndex,
pingsQueue :: !Word,
isMaster :: Bool,
- isReady :: Bool,
+ isReady :: !Bool,
isAdministrator :: Bool,
- clientClan :: String,
+ clientClan :: B.ByteString,
teamsInGame :: Word
}
instance Show ClientInfo where
- show ci = show (clientUID ci)
- ++ " nick: " ++ (nick ci)
- ++ " host: " ++ (host ci)
+ show ci = " nick: " ++ (unpack $ nick ci) ++ " host: " ++ (unpack $ host ci)
instance Eq ClientInfo where
- (==) = (==) `on` clientHandle
+ (==) = (==) `on` clientSocket
data HedgehogInfo =
- HedgehogInfo String String
+ HedgehogInfo B.ByteString B.ByteString
data TeamInfo =
TeamInfo
{
- teamownerId :: !Int,
- teamowner :: String,
- teamname :: String,
- teamcolor :: String,
- teamgrave :: String,
- teamfort :: String,
- teamvoicepack :: String,
- teamflag :: String,
+ teamownerId :: ClientIndex,
+ teamowner :: B.ByteString,
+ teamname :: B.ByteString,
+ teamcolor :: B.ByteString,
+ teamgrave :: B.ByteString,
+ teamfort :: B.ByteString,
+ teamvoicepack :: B.ByteString,
+ teamflag :: B.ByteString,
difficulty :: Int,
hhnum :: Int,
hedgehogs :: [HedgehogInfo]
}
instance Show TeamInfo where
- show ti = "owner: " ++ (teamowner ti)
- ++ "name: " ++ (teamname ti)
- ++ "color: " ++ (teamcolor ti)
+ show ti = "owner: " ++ (unpack $ teamowner ti)
+ ++ "name: " ++ (unpack $ teamname ti)
+ ++ "color: " ++ (unpack $ teamcolor ti)
data RoomInfo =
RoomInfo
{
- roomUID :: !Int,
- masterID :: !Int,
- name :: String,
- password :: String,
+ masterID :: ClientIndex,
+ name :: B.ByteString,
+ password :: B.ByteString,
roomProto :: Word16,
teams :: [TeamInfo],
gameinprogress :: Bool,
playersIn :: !Int,
readyPlayers :: !Int,
- playersIDs :: IntSet.IntSet,
isRestrictedJoins :: Bool,
isRestrictedTeams :: Bool,
- roundMsgs :: Seq String,
- leftTeams :: [String],
+ roundMsgs :: Seq B.ByteString,
+ leftTeams :: [B.ByteString],
teamsAtStart :: [TeamInfo],
- params :: Map.Map String [String]
+ params :: Map.Map B.ByteString [B.ByteString]
}
instance Show RoomInfo where
- show ri = show (roomUID ri)
- ++ ", players ids: " ++ show (IntSet.size $ playersIDs ri)
- ++ ", players: " ++ show (playersIn ri)
+ show ri = ", players: " ++ show (playersIn ri)
++ ", ready: " ++ show (readyPlayers ri)
++ ", teams: " ++ show (teams ri)
-instance Eq RoomInfo where
- (==) = (==) `on` roomUID
-
+newRoom :: RoomInfo
newRoom = (
RoomInfo
- 0
- 0
+ undefined
""
""
0
@@ -108,7 +103,6 @@
False
0
0
- IntSet.empty
False
False
Data.Sequence.empty
@@ -128,15 +122,15 @@
ServerInfo
{
isDedicated :: Bool,
- serverMessage :: String,
- serverMessageForOldVersions :: String,
+ serverMessage :: B.ByteString,
+ serverMessageForOldVersions :: B.ByteString,
latestReleaseVersion :: Word16,
listenPort :: PortNumber,
nextRoomID :: Int,
- dbHost :: String,
- dbLogin :: String,
- dbPassword :: String,
- lastLogins :: [(String, (UTCTime, String))],
+ dbHost :: B.ByteString,
+ dbLogin :: B.ByteString,
+ dbPassword :: B.ByteString,
+ lastLogins :: [(B.ByteString, UTCTime)],
stats :: TMVar StatisticsInfo,
coreChan :: Chan CoreMessage,
dbQueries :: Chan DBQuery
@@ -145,12 +139,13 @@
instance Show ServerInfo where
show _ = "Server Info"
+newServerInfo :: TMVar StatisticsInfo -> Chan CoreMessage -> Chan DBQuery -> ServerInfo
newServerInfo = (
ServerInfo
True
"<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>"
- "<font color=yellow><h3 align=center>Hedgewars 0.9.15 is out! Please update.</h3><p align=center><a href=http://hedgewars.org/download.html>Download page here</a></font>"
- 37
+ "<font color=yellow><h3 align=center>Hedgewars 0.9.14.1 is out! Please update.</h3><p align=center><a href=http://hedgewars.org/download.html>Download page here</a></font>"
+ 35
46631
0
""
@@ -160,29 +155,35 @@
)
data AccountInfo =
- HasAccount String Bool
+ HasAccount B.ByteString Bool
| Guest
| Admin
deriving (Show, Read)
data DBQuery =
- CheckAccount Int String String
+ CheckAccount ClientIndex B.ByteString B.ByteString
| ClearCache
| SendStats Int Int
deriving (Show, Read)
data CoreMessage =
Accept ClientInfo
- | ClientMessage (Int, [String])
- | ClientAccountInfo (Int, AccountInfo)
+ | ClientMessage (ClientIndex, [B.ByteString])
+ | ClientAccountInfo (ClientIndex, AccountInfo)
| TimerAction Int
-
-type Clients = IntMap.IntMap ClientInfo
-type Rooms = IntMap.IntMap RoomInfo
+ | Remove ClientIndex
---type ClientsTransform = [ClientInfo] -> [ClientInfo]
---type RoomsTransform = [RoomInfo] -> [RoomInfo]
---type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo]
---type Answer = ServerInfo -> (HandlesSelector, [String])
+instance Show CoreMessage where
+ show (Accept _) = "Accept"
+ show (ClientMessage _) = "ClientMessage"
+ show (ClientAccountInfo _) = "ClientAccountInfo"
+ show (TimerAction _) = "TimerAction"
+ show (Remove _) = "Remove"
-type ClientsSelector = Clients -> Rooms -> [Int]
+type MRnC = MRoomsAndClients RoomInfo ClientInfo
+type IRnC = IRoomsAndClients RoomInfo ClientInfo
+
+data Notice =
+ NickAlreadyInUse
+ | AdminLeft
+ deriving Enum
\ No newline at end of file
--- a/gameServer/HWProtoCore.hs Wed Feb 02 09:05:48 2011 +0100
+++ b/gameServer/HWProtoCore.hs Wed Feb 02 11:28:38 2011 +0300
@@ -1,72 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
module HWProtoCore where
-import qualified Data.IntMap as IntMap
-import Data.Foldable
+import Control.Monad.Reader
import Data.Maybe
+import qualified Data.ByteString.Char8 as B
--------------------------------------
import CoreTypes
import Actions
-import Utils
import HWProtoNEState
import HWProtoLobbyState
import HWProtoInRoomState
+import HandlerUtils
+import RoomsAndClients
+import Utils
handleCmd, handleCmd_loggedin :: CmdHandler
-handleCmd clID _ _ ["PING"] = [AnswerThisClient ["PONG"]]
+
+handleCmd ["PING"] = answerClient ["PONG"]
+
-handleCmd clID clients rooms ("QUIT" : xs) =
- [ByeClient msg]
+handleCmd ("QUIT" : xs) = return [ByeClient msg]
where
- msg = if not $ null xs then head xs else ""
+ msg = if not $ null xs then head xs else "bye"
-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 ["PONG"] = do
+ cl <- thisClient
+ if pingsQueue cl == 0 then
+ return [ProtocolError "Protocol violation"]
+ else
+ return [ModifyClient (\c -> c{pingsQueue = pingsQueue c - 1})]
-
-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 cmd = do
+ (ci, irnc) <- ask
+ if logonPassed (irnc `client` ci) then
+ handleCmd_loggedin cmd
+ else
+ handleCmd_NotEntered cmd
-handleCmd_loggedin clID clients rooms ["INFO", asknick] =
+handleCmd_loggedin ["INFO", asknick] = do
+ (_, rnc) <- ask
+ maybeClientId <- clientByNick asknick
+ let noSuchClient = isNothing maybeClientId
+ let clientId = fromJust maybeClientId
+ let cl = rnc `client` fromJust maybeClientId
+ let roomId = clientRoom rnc clientId
+ let clRoom = room rnc roomId
+ let roomMasterSign = if isMaster cl then "@" else ""
+ let adminSign = if isAdministrator cl then "@" else ""
+ let roomInfo = if roomId /= lobbyId then roomMasterSign `B.append` "room " `B.append` (name clRoom) else adminSign `B.append` "lobby"
+ let roomStatus = if gameinprogress clRoom then
+ if teamsInGame cl > 0 then "(playing)" else "(spectating)"
+ else
+ ""
if noSuchClient then
- []
- else
- [AnswerThisClient
- ["INFO",
- nick client,
- "[" ++ host client ++ "]",
- protoNumber2ver $ clientProto client,
- "[" ++ roomInfo ++ "]" ++ roomStatus]]
- where
- maybeClient = find (\cl -> asknick == nick cl) clients
- noSuchClient = isNothing maybeClient
- client = fromJust maybeClient
- room = rooms IntMap.! roomID client
- roomInfo = if roomID client /= 0 then roomMasterSign ++ "room " ++ (name room) else adminSign ++ "lobby"
- roomMasterSign = if isMaster client then "@" else ""
- adminSign = if isAdministrator client then "@" else ""
- roomStatus =
- if gameinprogress room
- then if teamsInGame client > 0 then "(playing)" else "(spectating)"
- else ""
+ return []
+ else
+ answerClient [
+ "INFO",
+ nick cl,
+ "[" `B.append` host cl `B.append` "]",
+ protoNumber2ver $ clientProto cl,
+ "[" `B.append` roomInfo `B.append` "]" `B.append` roomStatus
+ ]
-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
+handleCmd_loggedin cmd = do
+ (ci, rnc) <- ask
+ if clientRoom rnc ci == lobbyId then
+ handleCmd_lobby cmd
+ else
+ handleCmd_inRoom cmd
--- a/gameServer/HWProtoInRoomState.hs Wed Feb 02 09:05:48 2011 +0100
+++ b/gameServer/HWProtoInRoomState.hs Wed Feb 02 11:28:38 2011 +0300
@@ -1,196 +1,254 @@
+{-# 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.Sequence((|>), empty)
import Data.List
import Data.Maybe
+import qualified Data.ByteString.Char8 as B
+import Control.Monad
+import Control.Monad.Reader
--------------------------------------
import CoreTypes
import Actions
import Utils
-
+import HandlerUtils
+import RoomsAndClients
handleCmd_inRoom :: CmdHandler
-handleCmd_inRoom clID clients _ ["CHAT", msg] =
- [AnswerOthersInRoom ["CHAT", clientNick, msg]]
- where
- clientNick = nick $ clients IntMap.! clID
+handleCmd_inRoom ["CHAT", msg] = do
+ n <- clientNick
+ s <- roomOthersChans
+ return [AnswerClients s ["CHAT", n, msg]]
-handleCmd_inRoom clID clients rooms ["PART"] =
- [RoomRemoveThisClient "part"]
- where
- client = clients IntMap.! clID
+handleCmd_inRoom ["PART"] = return [MoveToLobby "part"]
+handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg]
-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 ("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 ("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) == 8 = [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]
- ]
+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
+ 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
+
+ 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
+ })
+ ]
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 (n:h:hhs) = HedgehogInfo n h : hhsList hhs
- newTeamHHNum = min 4 canAddNumber
-
-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
- 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
+ anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams
+ findTeam = find (\t -> name == teamname t) . teams
-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]]
+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]]
where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
- noSuchTeam = isNothing findTeam
- team = fromJust findTeam
- findTeam = find (\t -> teamName == teamname t) $ teams room
- canAddNumber = 48 - (sum . map hhnum $ teams room)
+ hhNumber = case B.readInt numberStr of
+ Just (i, t) | B.null t -> fromIntegral i
+ otherwise -> 0
+ findTeam = find (\t -> teamName == teamname t) . teams
+ canAddNumber = (-) 48 . sum . map hhnum . teams
+
-handleCmd_inRoom clID clients rooms ["TEAM_COLOR", teamName, newColor]
- | not $ isMaster client = [ProtocolError "Not room master"]
- | noSuchTeam = []
- | otherwise = [ModifyRoom $ modifyTeam team{teamcolor = newColor},
- AnswerOthersInRoom ["TEAM_COLOR", teamName, newColor],
+handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do
+ cl <- thisClient
+ others <- roomOthersChans
+ r <- thisRoom
+
+ let maybeTeam = findTeam r
+ let team = fromJust maybeTeam
+
+ return $
+ if not $ isMaster cl then
+ [ProtocolError "Not room master"]
+ else if isNothing maybeTeam then
+ []
+ else
+ [ModifyRoom $ modifyTeam team{teamcolor = newColor},
+ AnswerClients others ["TEAM_COLOR", teamName, newColor],
ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})]
where
- noSuchTeam = isNothing findTeam
- team = fromJust findTeam
- findTeam = find (\t -> teamName == teamname t) $ teams room
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
+ findTeam = find (\t -> teamName == teamname t) . teams
-handleCmd_inRoom 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 ["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 ["START_GAME"] = do
+ cl <- thisClient
+ r <- thisRoom
+ chans <- roomClientsChans
-handleCmd_inRoom clID clients rooms ["START_GAME"] =
- if isMaster client && (playersIn room == readyPlayers room) && (not . gameinprogress) room then
- if enoughClans then
- [ModifyRoom
+ if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then
+ if enoughClans r then
+ return [
+ ModifyRoom
(\r -> r{
gameinprogress = True,
roundMsgs = empty,
leftTeams = [],
teamsAtStart = teams r}
),
- AnswerThisRoom ["RUN_GAME"]]
+ AnswerClients chans ["RUN_GAME"]
+ ]
+ else
+ return [Warning "Less than two clans!"]
else
- [Warning "Less than two clans!"]
- else
- []
+ return []
where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room
+ enoughClans = not . null . drop 1 . group . map teamcolor . teams
-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
- []
+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 []
where
- client = clients IntMap.! clID
(isLegal, isKeepAlive) = checkNetCmd msg
-handleCmd_inRoom clID clients rooms ["ROUNDFINISHED"] =
- if isMaster client then
- [ModifyRoom
+
+handleCmd_inRoom ["ROUNDFINISHED"] = do
+ cl <- thisClient
+ r <- thisRoom
+ chans <- roomClientsChans
+
+ if isMaster cl && (gameinprogress r) then
+ return $ (ModifyRoom
(\r -> r{
gameinprogress = False,
readyPlayers = 0,
roundMsgs = empty,
leftTeams = [],
teamsAtStart = []}
- ),
- UnreadyRoomClients
- ] ++ answerRemovedTeams
- else
- []
+ ))
+ : UnreadyRoomClients
+ : answerRemovedTeams chans r
+ else
+ return []
where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room
-
+ answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams
-handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_JOINS"]
- | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
- | otherwise = [ProtocolError "Not room master"]
- where
- client = clients IntMap.! clID
+handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do
+ cl <- thisClient
+ return $
+ if not $ isMaster cl then
+ [ProtocolError "Not room master"]
+ else
+ [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
-handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_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
- client = clients IntMap.! clID
- maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients
- noSuchClient = isNothing maybeClient
- kickClient = fromJust maybeClient
- kickID = clientUID kickClient
+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 _ ["TEAMCHAT", msg] =
- [AnswerSameClan ["EM", engineMsg]]
+handleCmd_inRoom ["KICK", kickNick] = do
+ (thisClientId, rnc) <- ask
+ maybeClientId <- clientByNick kickNick
+ master <- liftM isMaster thisClient
+ let kickId = fromJust maybeClientId
+ let sameRoom = (clientRoom rnc thisClientId) == (clientRoom rnc kickId)
+ return
+ [KickRoomClient kickId | master && isJust maybeClientId && (kickId /= thisClientId) && sameRoom]
+
+
+handleCmd_inRoom ["TEAMCHAT", msg] = do
+ cl <- thisClient
+ chans <- roomSameClanChans
+ return [AnswerClients chans ["EM", engineMsg cl]]
where
- client = clients IntMap.! clID
- engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20")
+ engineMsg cl = toEngineMsg $ "b" `B.append` (nick cl) `B.append` "(team): " `B.append` msg `B.append` "\x20\x20"
-handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"]
+handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"]
--- a/gameServer/HWProtoLobbyState.hs Wed Feb 02 09:05:48 2011 +0100
+++ b/gameServer/HWProtoLobbyState.hs Wed Feb 02 11:28:38 2011 +0300
@@ -1,149 +1,145 @@
+{-# 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 Data.List
import Data.Word
+import Control.Monad.Reader
+import qualified Data.ByteString.Char8 as B
+import Control.DeepSeq
--------------------------------------
import CoreTypes
import Actions
import Utils
+import HandlerUtils
+import RoomsAndClients
-answerAllTeams protocol teams = concatMap toAnswer teams
+answerAllTeams cl = concatMap toAnswer
where
+ clChan = sendChan cl
toAnswer team =
- [AnswerThisClient $ teamToNet protocol team,
- AnswerThisClient ["TEAM_COLOR", teamname team, teamcolor team],
- AnswerThisClient ["HH_NUM", teamname team, show $ hhnum team]]
+ [AnswerClients [clChan] $ teamToNet team,
+ AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team],
+ AnswerClients [clChan] ["HH_NUM", teamname team, B.pack . show $ hhnum team]]
handleCmd_lobby :: CmdHandler
-handleCmd_lobby clID clients rooms ["LIST"] =
- [AnswerThisClient ("ROOMS" : roomsInfoList)]
+
+handleCmd_lobby ["LIST"] = do
+ (ci, irnc) <- ask
+ let cl = irnc `client` ci
+ rooms <- allRoomInfos
+ let roomsInfoList = concatMap (roomInfo irnc) . filter (\r -> (roomProto r == clientProto cl) && not (isRestrictedJoins r))
+ return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
where
- roomsInfoList = concatMap roomInfo sameProtoRooms
- sameProtoRooms = filter (\r -> (roomProto r == protocol) && not (isRestrictedJoins r)) roomsList
- roomsList = IntMap.elems rooms
- protocol = clientProto client
- client = clients IntMap.! clID
- roomInfo room
- | clientProto client < 28 = [
+ roomInfo irnc room = [
+ showB $ gameinprogress room,
name 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),
+ showB $ playersIn room,
+ showB $ length $ teams room,
+ nick $ irnc `client` masterID room,
head (Map.findWithDefault ["+gen+"] "MAP" (params room)),
head (Map.findWithDefault ["Default"] "SCHEME" (params room)),
head (Map.findWithDefault ["Default"] "AMMO" (params room))
]
-handleCmd_lobby clID clients _ ["CHAT", msg] =
- [AnswerOthersInRoom ["CHAT", clientNick, msg]]
- where
- clientNick = nick $ clients IntMap.! clID
+
+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 clID clients rooms ["CREATE_ROOM", newRoom, roomPassword]
- | haveSameRoom = [Warning "Room exists"]
- | illegalName newRoom = [Warning "Illegal room name"]
- | otherwise =
- [RoomRemoveThisClient "", -- leave lobby
- AddRoom newRoom roomPassword,
- AnswerThisClient ["NOT_READY", clientNick]
- ]
- where
- clientNick = nick $ clients IntMap.! clID
- haveSameRoom = isJust $ find (\room -> newRoom == name room) $ IntMap.elems rooms
-
-
-handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom] =
- handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, ""]
+handleCmd_lobby ["CREATE_ROOM", newRoom] =
+ handleCmd_lobby ["CREATE_ROOM", newRoom, ""]
-handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, roomPassword]
- | noSuchRoom = [Warning "No such room"]
- | isRestrictedJoins jRoom = [Warning "Joining restricted"]
- | roomPassword /= password jRoom = [Warning "Wrong password"]
- | otherwise =
- [RoomRemoveThisClient "", -- leave lobby
- RoomAddThisClient rID] -- join room
- ++ answerNicks
- ++ answerReady
- ++ [AnswerThisRoom ["NOT_READY", nick client]]
- ++ answerFullConfig
- ++ 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]
- answerReady = map
- ((\ c ->
- AnswerThisClient
- [if isReady c then "READY" else "NOT_READY", nick c])
- . (\ clID -> clients IntMap.! clID))
- roomClientsIDs
+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
+ let nicks = map nick jRoomClients
+ let chans = map sendChan (cl : jRoomClients)
+ 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 [sendChan cl] $ "JOINED" : nicks,
+ AnswerClients chans ["NOT_READY", nick cl]
+ ]
+ ++ (map (readynessMessage cl) jRoomClients)
+ ++ (answerFullConfig cl $ params jRoom)
+ ++ (answerTeams cl jRoom)
+ ++ (watchRound cl jRoom)
- toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs
-
- answerFullConfig = map toAnswer ((Data.List.reverse . Data.List.sort $ leftConfigPart) ++ rightConfigPart)
- (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p == "MAP" || p == "MAPGEN" || p == "SCHEME") (Map.toList $ params jRoom)
+ where
+ readynessMessage cl c = AnswerClients [sendChan cl] [if isReady c then "READY" else "NOT_READY", nick c]
+
+ toAnswer cl (paramName, paramStrs) = AnswerClients [sendChan cl] $ "CFG" : paramName : paramStrs
- watchRound = if not $ gameinprogress jRoom then
+ answerFullConfig cl params = map (toAnswer cl) (leftConfigPart ++ rightConfigPart)
+ where
+ (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p /= "MAP") $ Map.toList params
+
+ answerTeams cl jRoom = let f = if gameinprogress jRoom then teamsAtStart else teams in answerAllTeams cl $ f jRoom
+
+ watchRound cl jRoom = if not $ gameinprogress jRoom then
[]
else
- [AnswerThisClient ["RUN_GAME"],
- AnswerThisClient $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)]
+ [AnswerClients [sendChan cl] ["RUN_GAME"],
+ AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)]
- answerTeams = if gameinprogress jRoom then
- 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
- []
- else
- handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName]
- where
- maybeClient = Foldable.find (\cl -> asknick == nick cl) clients
- noSuchClient = isNothing maybeClient
- followClient = fromJust maybeClient
- roomName = name $ rooms IntMap.! roomID followClient
-
+handleCmd_lobby ["FOLLOW", asknick] = do
+ (_, rnc) <- ask
+ ci <- clientByNick asknick
+ let ri = clientRoom rnc $ fromJust ci
+ let clRoom = room rnc ri
+ if isNothing ci || ri == lobbyId then
+ return []
+ else
+ handleCmd_lobby ["JOIN_ROOM", name clRoom]
---------------------------
-- Administrator's stuff --
-handleCmd_lobby clID clients rooms ["KICK", kickNick] =
- [KickClient kickID | isAdministrator client && (not noSuchClient) && kickID /= clID]
- where
- client = clients IntMap.! clID
- maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients
- noSuchClient = isNothing maybeClient
- kickID = clientUID $ fromJust maybeClient
+handleCmd_lobby ["KICK", kickNick] = do
+ (ci, _) <- ask
+ cl <- thisClient
+ kickId <- clientByNick kickNick
+ return [KickClient $ fromJust kickId | isAdministrator cl && isJust kickId && fromJust kickId /= ci]
-
+{-
handleCmd_lobby clID clients rooms ["BAN", banNick] =
if not $ isAdministrator client then
[]
@@ -151,35 +147,32 @@
BanClient banNick : handleCmd_lobby clID clients rooms ["KICK", banNick]
where
client = clients IntMap.! clID
-
+ -}
-handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "MOTD_NEW", newMessage] =
- [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator client]
- where
- client = clients IntMap.! clID
+handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = do
+ cl <- thisClient
+ return [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator cl]
-handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "MOTD_OLD", newMessage] =
- [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage}) | isAdministrator client]
- where
- client = clients IntMap.! clID
+handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do
+ cl <- thisClient
+ return [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage}) | isAdministrator cl]
-handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] =
- [ModifyServerInfo (\si -> si{latestReleaseVersion = fromJust readNum}) | isAdministrator client && isJust readNum]
+handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do
+ cl <- thisClient
+ return [ModifyServerInfo (\si -> si{latestReleaseVersion = readNum}) | isAdministrator cl && readNum > 0]
where
- client = clients IntMap.! clID
- readNum = maybeRead protoNum :: Maybe Word16
+ readNum = case B.readInt protoNum of
+ Just (i, t) | B.null t -> fromIntegral i
+ otherwise -> 0
-handleCmd_lobby clID clients rooms ["GET_SERVER_VAR"] =
- [SendServerVars | isAdministrator client]
- where
- client = clients IntMap.! clID
+handleCmd_lobby ["GET_SERVER_VAR"] = do
+ cl <- thisClient
+ return [SendServerVars | isAdministrator cl]
+
+handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do
+ cl <- thisClient
+ return [ClearAccountsCache | isAdministrator cl]
-handleCmd_lobby clID clients rooms ["CLEAR_ACCOUNTS_CACHE"] =
- [ClearAccountsCache | isAdministrator client]
- where
- client = clients IntMap.! clID
-
-
-handleCmd_lobby clID _ _ _ = [ProtocolError "Incorrect command (state: in lobby)"]
+handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]
--- a/gameServer/HWProtoNEState.hs Wed Feb 02 09:05:48 2011 +0100
+++ b/gameServer/HWProtoNEState.hs Wed Feb 02 11:28:38 2011 +0300
@@ -1,54 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
module HWProtoNEState where
import qualified Data.IntMap as IntMap
import Data.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 clID clients _ ["NICK", newNick]
- | not . null $ nick client = [ProtocolError "Nickname already chosen"]
- | haveSameNick = [AnswerThisClient ["WARNING", "Nickname already in use"], ByeClient "Nickname already in use"]
- | illegalName newNick = [ByeClient "Illegal nickname"]
- | otherwise =
- ModifyClient (\c -> c{nick = newNick}) :
- AnswerThisClient ["NICK", newNick] :
- [CheckRegistered | clientProto client /= 0]
+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 then return [NoticeMessage NickAlreadyInUse]
+ 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]
where
- client = clients IntMap.! clID
- haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
+ haveSameNick irnc = isJust . find (== newNick) . map (nick . 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
-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)
+handleCmd_NotEntered ["PASSWORD", passwd] = do
+ (ci, irnc) <- ask
+ let cl = irnc `client` ci
+
+ 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 clID _ _ _ = [ProtocolError "Incorrect command (state: not entered)"]
+handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"]
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/HandlerUtils.hs Wed Feb 02 11:28:38 2011 +0300
@@ -0,0 +1,65 @@
+module HandlerUtils where
+
+import Control.Monad.Reader
+import qualified Data.ByteString.Char8 as B
+import Data.List
+
+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)
+
+roomSameClanChans :: Reader (ClientIndex, IRnC) [ClientChan]
+roomSameClanChans = do
+ (ci, rnc) <- ask
+ let ri = clientRoom rnc ci
+ let otherRoomClients = map (client rnc) . filter (/= ci) $ roomClients rnc ri
+ let cl = rnc `client` ci
+ let thisClan = clientClan cl
+ let sameClanClients = Prelude.filter (\c -> teamsInGame cl > 0 && clientClan c == thisClan) otherRoomClients
+ let spectators = Prelude.filter (\c -> teamsInGame c == 0) otherRoomClients
+ let sameClanOrSpec = if teamsInGame cl > 0 then sameClanClients else spectators
+ return $ map sendChan sameClanOrSpec
+
+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
+
+clientByNick :: B.ByteString -> Reader (ClientIndex, IRnC) (Maybe ClientIndex)
+clientByNick n = do
+ (_, rnc) <- ask
+ let allClientIDs = allClients rnc
+ return $ find (\clId -> n == nick (client rnc clId)) allClientIDs
+
--- a/gameServer/ServerCore.hs Wed Feb 02 09:05:48 2011 +0100
+++ b/gameServer/ServerCore.hs Wed Feb 02 11:28:38 2011 +0300
@@ -2,86 +2,92 @@
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 Control.DeepSeq
--------------------------------------
import CoreTypes
import NetRoutines
-import Utils
import HWProtoCore
import Actions
import OfficialServer.DBInteraction
+import ServerState
+
+
+timerLoop :: Int -> Chan CoreMessage -> IO ()
+timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
-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
+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 `deepseq` actions) processAction
-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)
+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)
- 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)
+ 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)
- 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)
+ --else
+ --do
+ --debugM "Clients" "Message from dead client"
+ --return (serverInfo, rnc)
- TimerAction tick ->
- liftM firstAway $
- foldM processAction (0, serverInfo, clients, rooms) $
- PingAll : [StatsAction | even tick]
+ 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 ->
+ 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
- putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
+startServer si serverSocket = do
+ putStrLn $ "Listening on port " ++ show (listenPort si)
forkIO $
acceptLoop
serverSocket
- (coreChan serverInfo)
- 0
+ (coreChan si)
return ()
-
- forkIO $ timerLoop 0 $ coreChan serverInfo
+
+ forkIO $ timerLoop 0 $ coreChan si
+
+ startDBConnection si
- startDBConnection serverInfo
+ rnc <- newRoomsAndClients newRoom
- forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
+ forkIO $ evalStateT mainLoop (ServerState Nothing si Set.empty rnc)
- forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"
\ No newline at end of file
+ forever $ threadDelay 3600000000 -- one hour
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/ServerState.hs Wed Feb 02 11:28:38 2011 +0300
@@ -0,0 +1,47 @@
+module ServerState
+ (
+ module RoomsAndClients,
+ clientRoomA,
+ ServerState(..),
+ client's,
+ allClientsS,
+ roomClientsS,
+ io
+ ) 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
+ io $ clientRoomM rnc ci
+
+client's :: (ClientInfo -> a) -> StateT ServerState IO a
+client's f = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ io $ 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
+ io $ roomClientsM rnc ri
+
+io :: IO a -> StateT ServerState IO a
+io = liftIO
--- a/gameServer/Utils.hs Wed Feb 02 09:05:48 2011 +0100
+++ b/gameServer/Utils.hs Wed Feb 02 11:28:38 2011 +0300
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
module Utils where
import Control.Concurrent
@@ -13,40 +14,38 @@
import System.IO
import qualified Data.List as List
import Control.Monad
+import Control.Monad.Trans
import Data.Maybe
-------------------------------------------------
import qualified Codec.Binary.Base64 as Base64
-import qualified Data.ByteString.UTF8 as BUTF8
-import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString as BW
import CoreTypes
-sockAddr2String :: SockAddr -> IO String
-sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr
+sockAddr2String :: SockAddr -> IO B.ByteString
+sockAddr2String (SockAddrInet _ hostAddr) = liftM B.pack $ inet_ntoa hostAddr
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) =
- return $ (foldr1 (.)
+ return $ B.pack $ (foldr1 (.)
$ List.intersperse (\a -> ':':a)
$ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) []
-toEngineMsg :: String -> String
-toEngineMsg msg = Base64.encode (fromIntegral (B.length encodedMsg) : (B.unpack encodedMsg))
- where
- encodedMsg = BUTF8.fromString msg
+toEngineMsg :: B.ByteString -> B.ByteString
+toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : (BW.unpack msg))
-fromEngineMsg :: String -> Maybe String
-fromEngineMsg msg = liftM (map w2c) (Base64.decode msg >>= removeLength)
+fromEngineMsg :: B.ByteString -> Maybe B.ByteString
+fromEngineMsg msg = Base64.decode (B.unpack msg) >>= removeLength >>= return . BW.pack
where
removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing
removeLength _ = Nothing
-checkNetCmd :: String -> (Bool, Bool)
-checkNetCmd msg = check decoded
+checkNetCmd :: B.ByteString -> (Bool, Bool)
+checkNetCmd = check . liftM B.unpack . fromEngineMsg
where
- decoded = fromEngineMsg msg
check Nothing = (False, False)
check (Just (m:ms)) = (m `Set.member` legalMessages, m == '+')
check _ = (False, False)
- legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghbc12345" ++ slotMessages
+ legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghb12345" ++ slotMessages
slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"
maybeRead :: Read a => String -> Maybe a
@@ -54,29 +53,17 @@
[(x, rest)] | all isSpace rest -> Just x
_ -> Nothing
-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
+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
where
hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
@@ -90,34 +77,48 @@
else
t : replaceTeam team teams
-illegalName :: String -> Bool
-illegalName s = null s || all isSpace s || isSpace (head s) || isSpace (last s)
+illegalName :: B.ByteString -> Bool
+illegalName b = null s || all isSpace s || isSpace (head s) || isSpace (last s)
+ where
+ s = B.unpack b
-protoNumber2ver :: Word16 -> String
-protoNumber2ver 17 = "0.9.7-dev"
-protoNumber2ver 19 = "0.9.7"
-protoNumber2ver 20 = "0.9.8-dev"
-protoNumber2ver 21 = "0.9.8"
-protoNumber2ver 22 = "0.9.9-dev"
-protoNumber2ver 23 = "0.9.9"
-protoNumber2ver 24 = "0.9.10-dev"
-protoNumber2ver 25 = "0.9.10"
-protoNumber2ver 26 = "0.9.11-dev"
-protoNumber2ver 27 = "0.9.11"
-protoNumber2ver 28 = "0.9.12-dev"
-protoNumber2ver 29 = "0.9.12"
-protoNumber2ver 30 = "0.9.13-dev"
-protoNumber2ver 31 = "0.9.13"
-protoNumber2ver 32 = "0.9.14-dev"
-protoNumber2ver 33 = "0.9.14"
-protoNumber2ver 34 = "0.9.15-dev"
-protoNumber2ver 35 = "0.9.14.1"
-protoNumber2ver 37 = "0.9.15"
-protoNumber2ver 38 = "0.9.16-dev"
-protoNumber2ver w = show w
+protoNumber2ver :: Word16 -> B.ByteString
+protoNumber2ver v = Map.findWithDefault "Unknown" v vermap
+ where
+ vermap = Map.fromList [
+ (17, "0.9.7-dev"),
+ (19, "0.9.7"),
+ (20, "0.9.8-dev"),
+ (21, "0.9.8"),
+ (22, "0.9.9-dev"),
+ (23, "0.9.9"),
+ (24, "0.9.10-dev"),
+ (25, "0.9.10"),
+ (26, "0.9.11-dev"),
+ (27, "0.9.11"),
+ (28, "0.9.12-dev"),
+ (29, "0.9.12"),
+ (30, "0.9.13-dev"),
+ (31, "0.9.13"),
+ (32, "0.9.14-dev"),
+ (33, "0.9.14"),
+ (34, "0.9.15-dev"),
+ (35, "0.9.14.1"),
+ (37, "0.9.15"),
+ (38, "0.9.16-dev")]
askFromConsole :: String -> IO String
askFromConsole msg = do
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
--- a/gameServer/hedgewars-server.cabal Wed Feb 02 09:05:48 2011 +0100
+++ b/gameServer/hedgewars-server.cabal Wed Feb 02 11:28:38 2011 +0300
@@ -28,6 +28,6 @@
dataenc,
hslogger,
process,
- utf8-string
-
- ghc-options: -O2
\ No newline at end of file
+ deepseq
+
+ ghc-options: -O2