- Unbreak support for client versions prior to 0.9.13-dev
- Replace tabs with spaces (sorry for mixing with code changes)
--- a/gameServer/Actions.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/Actions.hs Thu Feb 25 18:28:33 2010 +0000
@@ -14,39 +14,39 @@
import Utils
data Action =
- AnswerThisClient [String]
- | AnswerAll [String]
- | AnswerAllOthers [String]
- | AnswerThisRoom [String]
- | AnswerOthersInRoom [String]
- | AnswerSameClan [String]
- | AnswerLobby [String]
- | SendServerMessage
- | 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
+ AnswerThisClient [String]
+ | AnswerAll [String]
+ | AnswerAllOthers [String]
+ | AnswerThisRoom [String]
+ | AnswerOthersInRoom [String]
+ | AnswerSameClan [String]
+ | AnswerLobby [String]
+ | SendServerMessage
+ | 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]
@@ -56,379 +56,379 @@
processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do
- writeChan (sendChan $ clients ! clID) msg
- return (clID, serverInfo, clients, rooms)
+ 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)
+ 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)
+ 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
+ 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
+ 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
+ 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
+ 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 = if clientProto client < 29 then
- serverMessageForOldVersions
- else
- serverMessage
+ writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo]
+ return (clID, serverInfo, clients, rooms)
+ where
+ client = clients ! clID
+ message = if clientProto client < 29 then
+ serverMessageForOldVersions
+ else
+ serverMessage
processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do
- writeChan (sendChan $ clients ! clID) ["ERROR", msg]
- return (clID, serverInfo, clients, rooms)
+ 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)
+ 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)
+ 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
- []
+ 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)
+ return (clID, serverInfo, adjust func clID clients, rooms)
processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) =
- return (clID, serverInfo, adjust func cl2ID clients, rooms)
+ 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
+ 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)
+ 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,
+ 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
+ (_, _, 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)
- }
+ 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, 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,
+ 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) $ 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) $ 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
+ 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
+ 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
+ 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)
+ 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"]]
+ 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]
+ 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]
+ -- ++ (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) =
- liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked")
+ liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked")
processAction (clID, serverInfo, clients, rooms) (BanClient banNick) =
- return (clID, serverInfo, clients, rooms)
+ 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")
+ 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
+ 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 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 <= 11) $ lastLogins serverInfo
+ let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins 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)
+ 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 (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)
+ (_, _, 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)
+ writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)
+ return (clID, serverInfo, clients, rooms)
--- a/gameServer/ClientIO.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/ClientIO.hs Thu Feb 25 18:28:33 2010 +0000
@@ -3,6 +3,7 @@
import qualified Control.Exception as Exception
import Control.Concurrent.Chan
+import Control.Concurrent
import Control.Monad
import System.IO
----------------
@@ -10,38 +11,39 @@
listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO ()
listenLoop handle linesNumber buf chan clientID = do
- str <- 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)
- listenLoop handle 0 [] chan clientID
- else
- listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID
+ str <- 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
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 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
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
- forM_ answer (hPutStrLn handle)
- hPutStrLn handle ""
- hFlush handle
- return $ isQuit answer
+ answer <- readChan chan
+ doClose <- Exception.handle
+ (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do
+ forM_ answer (hPutStrLn handle)
+ hPutStrLn handle ""
+ hFlush handle
+ return $ isQuit answer
- if doClose then
- Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle
- else
- clientSendLoop handle coreChan chan clientID
+ if doClose then
+ Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle
+ else
+ clientSendLoop handle coreChan chan clientID
- where
- sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
- isQuit ("BYE":xs) = True
- isQuit _ = False
+ where
+ sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
+ isQuit ("BYE":xs) = True
+ isQuit _ = False
--- a/gameServer/CoreTypes.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/CoreTypes.hs Thu Feb 25 18:28:33 2010 +0000
@@ -14,160 +14,160 @@
data ClientInfo =
- ClientInfo
- {
- clientUID :: !Int,
- sendChan :: Chan [String],
- clientHandle :: Handle,
- host :: String,
- connectTime :: UTCTime,
- nick :: String,
- webPassword :: String,
- logonPassed :: Bool,
- clientProto :: !Word16,
- roomID :: !Int,
- pingsQueue :: !Word,
- isMaster :: Bool,
- isReady :: Bool,
- isAdministrator :: Bool,
- clientClan :: String,
- teamsInGame :: Word
- }
+ ClientInfo
+ {
+ clientUID :: !Int,
+ sendChan :: Chan [String],
+ clientHandle :: Handle,
+ host :: String,
+ connectTime :: UTCTime,
+ nick :: String,
+ webPassword :: String,
+ logonPassed :: Bool,
+ clientProto :: !Word16,
+ roomID :: !Int,
+ pingsQueue :: !Word,
+ isMaster :: Bool,
+ isReady :: Bool,
+ isAdministrator :: Bool,
+ clientClan :: String,
+ teamsInGame :: Word
+ }
instance Show ClientInfo where
- show ci = show (clientUID ci)
- ++ " nick: " ++ (nick ci)
- ++ " host: " ++ (host ci)
+ show ci = show (clientUID ci)
+ ++ " nick: " ++ (nick ci)
+ ++ " host: " ++ (host ci)
instance Eq ClientInfo where
- (==) = (==) `on` clientHandle
+ (==) = (==) `on` clientHandle
data HedgehogInfo =
- HedgehogInfo String String
+ HedgehogInfo String String
data TeamInfo =
- TeamInfo
- {
- teamownerId :: !Int,
- teamowner :: String,
- teamname :: String,
- teamcolor :: String,
- teamgrave :: String,
- teamfort :: String,
- teamvoicepack :: String,
- teamflag :: String,
- difficulty :: Int,
- hhnum :: Int,
- hedgehogs :: [HedgehogInfo]
- }
+ TeamInfo
+ {
+ teamownerId :: !Int,
+ teamowner :: String,
+ teamname :: String,
+ teamcolor :: String,
+ teamgrave :: String,
+ teamfort :: String,
+ teamvoicepack :: String,
+ teamflag :: String,
+ difficulty :: Int,
+ hhnum :: Int,
+ hedgehogs :: [HedgehogInfo]
+ }
data RoomInfo =
- RoomInfo
- {
- 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 String,
- leftTeams :: [String],
- teamsAtStart :: [TeamInfo],
- params :: Map.Map String [String]
- }
+ RoomInfo
+ {
+ 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 String,
+ leftTeams :: [String],
+ teamsAtStart :: [TeamInfo],
+ params :: Map.Map String [String]
+ }
instance Show RoomInfo where
- show ri = show (roomUID ri)
- ++ ", players ids: " ++ show (IntSet.size $ playersIDs ri)
- ++ ", players: " ++ show (playersIn ri)
- ++ ", ready: " ++ show (readyPlayers ri)
+ show ri = show (roomUID ri)
+ ++ ", players ids: " ++ show (IntSet.size $ playersIDs ri)
+ ++ ", players: " ++ show (playersIn ri)
+ ++ ", ready: " ++ show (readyPlayers ri)
instance Eq RoomInfo where
- (==) = (==) `on` roomUID
+ (==) = (==) `on` roomUID
newRoom = (
- RoomInfo
- 0
- 0
- ""
- ""
- 0
- []
- False
- 0
- 0
- IntSet.empty
- False
- False
- Data.Sequence.empty
- []
- []
- (Map.singleton "MAP" ["+rnd+"])
- )
+ RoomInfo
+ 0
+ 0
+ ""
+ ""
+ 0
+ []
+ False
+ 0
+ 0
+ IntSet.empty
+ False
+ False
+ Data.Sequence.empty
+ []
+ []
+ (Map.singleton "MAP" ["+rnd+"])
+ )
data StatisticsInfo =
- StatisticsInfo
- {
- playersNumber :: Int,
- roomsNumber :: Int
- }
+ StatisticsInfo
+ {
+ playersNumber :: Int,
+ roomsNumber :: Int
+ }
data ServerInfo =
- ServerInfo
- {
- isDedicated :: Bool,
- serverMessage :: String,
- serverMessageForOldVersions :: String,
- listenPort :: PortNumber,
- nextRoomID :: Int,
- dbHost :: String,
- dbLogin :: String,
- dbPassword :: String,
- lastLogins :: [(String, UTCTime)],
- stats :: TMVar StatisticsInfo,
- coreChan :: Chan CoreMessage,
- dbQueries :: Chan DBQuery
- }
+ ServerInfo
+ {
+ isDedicated :: Bool,
+ serverMessage :: String,
+ serverMessageForOldVersions :: String,
+ listenPort :: PortNumber,
+ nextRoomID :: Int,
+ dbHost :: String,
+ dbLogin :: String,
+ dbPassword :: String,
+ lastLogins :: [(String, UTCTime)],
+ stats :: TMVar StatisticsInfo,
+ coreChan :: Chan CoreMessage,
+ dbQueries :: Chan DBQuery
+ }
instance Show ServerInfo where
- show si = "Server Info"
+ show si = "Server Info"
newServerInfo = (
- ServerInfo
- True
- "<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>"
- "<font color=yellow><h3>Hedgewars 0.9.12 is out! Please update.</h3><p align=center><a href=http://hedgewars.org/download.html>Download page here</a></font>"
- 46631
- 0
- ""
- ""
- ""
- []
- )
+ ServerInfo
+ True
+ "<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>"
+ "<font color=yellow><h3>Hedgewars 0.9.12 is out! Please update.</h3><p align=center><a href=http://hedgewars.org/download.html>Download page here</a></font>"
+ 46631
+ 0
+ ""
+ ""
+ ""
+ []
+ )
data AccountInfo =
- HasAccount String Bool
- | Guest
- | Admin
- deriving (Show, Read)
+ HasAccount String Bool
+ | Guest
+ | Admin
+ deriving (Show, Read)
data DBQuery =
- CheckAccount Int String String
- | ClearCache
- | SendStats Int Int
- deriving (Show, Read)
+ CheckAccount Int String String
+ | ClearCache
+ | SendStats Int Int
+ deriving (Show, Read)
data CoreMessage =
- Accept ClientInfo
- | ClientMessage (Int, [String])
- | ClientAccountInfo (Int, AccountInfo)
- | TimerAction Int
+ Accept ClientInfo
+ | ClientMessage (Int, [String])
+ | ClientAccountInfo (Int, AccountInfo)
+ | TimerAction Int
type Clients = IntMap.IntMap ClientInfo
type Rooms = IntMap.IntMap RoomInfo
--- a/gameServer/HWProtoCore.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/HWProtoCore.hs Thu Feb 25 18:28:33 2010 +0000
@@ -16,71 +16,71 @@
handleCmd clID _ _ ["PING"] = [AnswerThisClient ["PONG"]]
handleCmd clID clients rooms ("QUIT" : xs) =
- [ByeClient msg]
- where
- msg = if not $ null xs then head xs else ""
+ [ByeClient msg]
+ where
+ msg = if not $ null xs then head xs else ""
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
+ if pingsQueue client == 0 then
+ [ProtocolError "Protocol violation"]
+ else
+ [ModifyClient (\cl -> cl{pingsQueue = pingsQueue cl - 1})]
+ where
+ client = clients IntMap.! clID
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
+ 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
- []
- 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 ""
+ 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 ""
handleCmd_loggedin clID clients rooms ["FOLLOW", asknick] =
- if inLobby || noSuchClient then
- []
- else
- handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomname]
- where
- maybeClient = find (\cl -> asknick == nick cl) clients
- noSuchClient = isNothing maybeClient
- client = fromJust maybeClient
- room = rooms IntMap.! roomID client
- roomname = (name room)
- inLobby = roomname == ""
+ if inLobby || noSuchClient then
+ []
+ else
+ handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomname]
+ where
+ maybeClient = find (\cl -> asknick == nick cl) clients
+ noSuchClient = isNothing maybeClient
+ client = fromJust maybeClient
+ room = rooms IntMap.! roomID client
+ roomname = (name room)
+ inLobby = roomname == ""
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
+ if roomID client == 0 then
+ handleCmd_lobby clID clients rooms cmd
+ else
+ handleCmd_inRoom clID clients rooms cmd
+ where
+ client = clients IntMap.! clID
--- a/gameServer/HWProtoInRoomState.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/HWProtoInRoomState.hs Thu Feb 25 18:28:33 2010 +0000
@@ -16,192 +16,195 @@
handleCmd_inRoom :: CmdHandler
handleCmd_inRoom clID clients _ ["CHAT", msg] =
- [AnswerOthersInRoom ["CHAT", clientNick, msg]]
- where
- clientNick = nick $ clients IntMap.! clID
+ [AnswerOthersInRoom ["CHAT", clientNick, msg]]
+ where
+ clientNick = nick $ clients IntMap.! clID
handleCmd_inRoom clID clients _ ["TEAM_CHAT", msg] =
- [AnswerOthersInRoom ["TEAM_CHAT", clientNick, msg]]
- where
- clientNick = nick $ clients IntMap.! clID
+ [AnswerOthersInRoom ["TEAM_CHAT", clientNick, msg]]
+ where
+ clientNick = nick $ clients IntMap.! clID
handleCmd_inRoom clID clients rooms ["PART"] =
- [RoomRemoveThisClient "part"]
- where
- client = clients IntMap.! clID
+ [RoomRemoveThisClient "part"]
+ where
+ client = clients IntMap.! clID
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
+ | 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 clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo)
- | length hhsInfo /= 16 = []
- | 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 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 (n:h:hhs) = HedgehogInfo n h : hhsList hhs
- newTeamHHNum = min 4 canAddNumber
+ | length hhsInfo /= 16 = []
+ | 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 (n:h:hhs) = HedgehogInfo n h : hhsList hhs
+ newTeamHHNum = min 4 canAddNumber
+
+handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : difStr : hhsInfo) =
+ handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : "" : difStr : hhsInfo)
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})
- ]
- where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- noSuchTeam = isNothing findTeam
- team = fromJust findTeam
- findTeam = find (\t -> teamName == teamname t) $ teams room
+ | 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})
+ ]
+ where
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
+ noSuchTeam = isNothing findTeam
+ team = fromJust findTeam
+ findTeam = find (\t -> teamName == teamname t) $ teams room
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
- 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)
+ | 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
+ 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 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
- noSuchTeam = isNothing findTeam
- team = fromJust findTeam
- findTeam = find (\t -> teamName == teamname t) $ teams room
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
+ | 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
+ 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 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
+ [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 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}
- ),
- AnswerThisRoom ["RUN_GAME"]]
- else
- [Warning "Less than two clans!"]
- else
- []
- where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room
+ 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}
+ ),
+ AnswerThisRoom ["RUN_GAME"]]
+ else
+ [Warning "Less than two clans!"]
+ else
+ []
+ where
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
+ enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room
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
+ 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 clID clients rooms ["ROUNDFINISHED"] =
- if isMaster client then
- [ModifyRoom
- (\r -> r{
- gameinprogress = False,
- readyPlayers = 0,
- roundMsgs = empty,
- leftTeams = [],
- teamsAtStart = []}
- ),
- UnreadyRoomClients
- ] ++ answerRemovedTeams
- else
- []
- where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room
+ if isMaster client then
+ [ModifyRoom
+ (\r -> r{
+ gameinprogress = False,
+ readyPlayers = 0,
+ roundMsgs = empty,
+ leftTeams = [],
+ teamsAtStart = []}
+ ),
+ UnreadyRoomClients
+ ] ++ answerRemovedTeams
+ else
+ []
+ where
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
+ answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room
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
+ | 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
+ | 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
+ [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 clID clients _ ["TEAMCHAT", msg] =
- if (teamsInGame client > 0) then
- [AnswerSameClan ["EM", engineMsg]]
- else
- []
- where
- client = clients IntMap.! clID
- engineMsg = toEngineMsg $ 'b' : (nick client ++ "(team): " ++ decodedMsg ++ "\x20\x20")
- decodedMsg = UTF8.decodeString msg
+ if (teamsInGame client > 0) then
+ [AnswerSameClan ["EM", engineMsg]]
+ else
+ []
+ where
+ client = clients IntMap.! clID
+ engineMsg = toEngineMsg $ 'b' : (nick client ++ "(team): " ++ decodedMsg ++ "\x20\x20")
+ decodedMsg = UTF8.decodeString msg
handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"]
--- a/gameServer/HWProtoLobbyState.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/HWProtoLobbyState.hs Thu Feb 25 18:28:33 2010 +0000
@@ -11,144 +11,144 @@
import Actions
import Utils
-answerAllTeams teams = concatMap toAnswer teams
- where
- toAnswer team =
- [AnswerThisClient $ teamToNet team,
- AnswerThisClient ["TEAM_COLOR", teamname team, teamcolor team],
- AnswerThisClient ["HH_NUM", teamname team, show $ hhnum team]]
+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 clID clients rooms ["LIST"] =
- [AnswerThisClient ("ROOMS" : roomsInfoList)]
- 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 = [
- 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),
- head (Map.findWithDefault ["+gen+"] "MAP" (params room)),
- head (Map.findWithDefault ["Default"] "SCHEME" (params room)),
- head (Map.findWithDefault ["Default"] "AMMO" (params room))
- ]
+ [AnswerThisClient ("ROOMS" : roomsInfoList)]
+ 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 = [
+ 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),
+ 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
+ [AnswerOthersInRoom ["CHAT", clientNick, msg]]
+ where
+ clientNick = nick $ clients IntMap.! clID
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
+ | 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 clID clients rooms ["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
+ | 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
- toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs
-
- answerFullConfig = map toAnswer (leftConfigPart ++ rightConfigPart)
- (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p /= "MAP") (Map.toList $ params jRoom)
+ toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs
+
+ answerFullConfig = map toAnswer (leftConfigPart ++ rightConfigPart)
+ (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p /= "MAP") (Map.toList $ params jRoom)
- watchRound = if not $ gameinprogress jRoom then
- []
- else
- [AnswerThisClient ["RUN_GAME"],
- AnswerThisClient $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)]
+ watchRound = if not $ gameinprogress jRoom then
+ []
+ else
+ [AnswerThisClient ["RUN_GAME"],
+ AnswerThisClient $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)]
- answerTeams = if gameinprogress jRoom then
- answerAllTeams (teamsAtStart jRoom)
- else
- answerAllTeams (teams jRoom)
+ answerTeams = if gameinprogress jRoom then
+ answerAllTeams (clientProto client) (teamsAtStart jRoom)
+ else
+ answerAllTeams (clientProto client) (teams jRoom)
handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName] =
- handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, ""]
+ handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, ""]
- ---------------------------
- -- Administrator's stuff --
+ ---------------------------
+ -- 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
+ [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 clID clients rooms ["BAN", banNick] =
- if not $ isAdministrator client then
- []
- else
- BanClient banNick : handleCmd_lobby clID clients rooms ["KICK", banNick]
- where
- client = clients IntMap.! clID
+ if not $ isAdministrator client then
+ []
+ else
+ BanClient banNick : handleCmd_lobby clID clients rooms ["KICK", banNick]
+ where
+ client = clients IntMap.! clID
handleCmd_lobby clID clients rooms ["SET_SERVER_MESSAGE", newMessage] =
- [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator client]
- where
- client = clients IntMap.! clID
+ [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator client]
+ where
+ client = clients IntMap.! clID
handleCmd_lobby clID clients rooms ["CLEAR_ACCOUNTS_CACHE"] =
- [ClearAccountsCache | isAdministrator client]
- where
- client = clients IntMap.! clID
+ [ClearAccountsCache | isAdministrator client]
+ where
+ client = clients IntMap.! clID
handleCmd_lobby clID _ _ _ = [ProtocolError "Incorrect command (state: in lobby)"]
--- a/gameServer/HWProtoNEState.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/HWProtoNEState.hs Thu Feb 25 18:28:33 2010 +0000
@@ -12,39 +12,39 @@
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 ""]
- | illegalName newNick = [ByeClient "Illegal nickname"]
- | otherwise =
- ModifyClient (\c -> c{nick = newNick}) :
- AnswerThisClient ["NICK", newNick] :
- [CheckRegistered | clientProto client /= 0]
- where
- client = clients IntMap.! clID
- haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
+ | 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
+ client = clients IntMap.! clID
+ haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
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)
+ | 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 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]
+ 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 _ _ _ ["DUMP"] =
--- a/gameServer/NetRoutines.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/NetRoutines.hs Thu Feb 25 18:28:33 2010 +0000
@@ -16,45 +16,45 @@
acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO ()
acceptLoop servSock coreChan clientCounter = do
- Exception.handle
- (\(_ :: Exception.IOException) -> putStrLn "exception on connect") $
- do
- (socket, sockAddr) <- Network.Socket.accept servSock
+ Exception.handle
+ (\(_ :: Exception.IOException) -> putStrLn "exception on connect") $
+ do
+ (socket, sockAddr) <- Network.Socket.accept servSock
- cHandle <- socketToHandle socket ReadWriteMode
- hSetBuffering cHandle LineBuffering
- clientHost <- sockAddr2String sockAddr
+ cHandle <- socketToHandle socket ReadWriteMode
+ hSetBuffering cHandle LineBuffering
+ clientHost <- sockAddr2String sockAddr
- currentTime <- getCurrentTime
-
- sendChan <- newChan
+ currentTime <- getCurrentTime
+
+ sendChan <- newChan
- let newClient =
- (ClientInfo
- nextID
- sendChan
- cHandle
- clientHost
- currentTime
- ""
- ""
- False
- 0
- 0
- 0
- False
- False
- False
- undefined
- undefined
- )
+ let newClient =
+ (ClientInfo
+ nextID
+ sendChan
+ cHandle
+ clientHost
+ currentTime
+ ""
+ ""
+ False
+ 0
+ 0
+ 0
+ False
+ False
+ False
+ undefined
+ undefined
+ )
- writeChan coreChan $ Accept newClient
+ writeChan coreChan $ Accept newClient
- forkIO $ clientRecvLoop cHandle coreChan nextID
- forkIO $ clientSendLoop cHandle coreChan sendChan nextID
- return ()
+ forkIO $ clientRecvLoop cHandle coreChan nextID
+ forkIO $ clientSendLoop cHandle coreChan sendChan nextID
+ return ()
- acceptLoop servSock coreChan nextID
- where
- nextID = clientCounter + 1
+ acceptLoop servSock coreChan nextID
+ where
+ nextID = clientCounter + 1
--- a/gameServer/Opts.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/Opts.hs Thu Feb 25 18:28:33 2010 +0000
@@ -1,6 +1,6 @@
module Opts
(
- getOpts,
+ getOpts,
) where
import System
@@ -12,23 +12,23 @@
options :: [OptDescr (ServerInfo -> ServerInfo)]
options = [
- Option ['p'] ["port"] (ReqArg readListenPort "PORT") "listen on PORT",
- Option ['d'] ["dedicated"] (ReqArg readDedicated "BOOL") "start as dedicated (True or False)"
- ]
+ Option ['p'] ["port"] (ReqArg readListenPort "PORT") "listen on PORT",
+ Option ['d'] ["dedicated"] (ReqArg readDedicated "BOOL") "start as dedicated (True or False)"
+ ]
readListenPort,
- readDedicated,
- readDbLogin,
- readDbPassword,
- readDbHost :: String -> ServerInfo -> ServerInfo
+ readDedicated,
+ readDbLogin,
+ readDbPassword,
+ readDbHost :: String -> ServerInfo -> ServerInfo
readListenPort str opts = opts{listenPort = readPort}
- where
- readPort = fromInteger $ fromMaybe 46631 (maybeRead str :: Maybe Integer)
+ where
+ readPort = fromInteger $ fromMaybe 46631 (maybeRead str :: Maybe Integer)
readDedicated str opts = opts{isDedicated = readDedicated}
- where
- readDedicated = fromMaybe True (maybeRead str :: Maybe Bool)
+ where
+ readDedicated = fromMaybe True (maybeRead str :: Maybe Bool)
readDbLogin str opts = opts{dbLogin = str}
readDbPassword str opts = opts{dbPassword = str}
@@ -36,8 +36,8 @@
getOpts :: ServerInfo -> IO ServerInfo
getOpts opts = do
- args <- getArgs
- case getOpt Permute options args of
- (o, [], []) -> return $ foldr ($) opts o
- (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
- where header = "Usage: newhwserv [OPTION...]"
+ args <- getArgs
+ case getOpt Permute options args of
+ (o, [], []) -> return $ foldr ($) opts o
+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+ where header = "Usage: newhwserv [OPTION...]"
--- a/gameServer/ServerCore.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/ServerCore.hs Thu Feb 25 18:28:33 2010 +0000
@@ -23,65 +23,65 @@
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
+ liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms 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)
+ r <- readChan $ coreChan serverInfo
+
+ (newServerInfo, mClients, mRooms) <-
+ case r of
+ Accept ci ->
+ liftM firstAway $ processAction
+ (clientUID ci, serverInfo, clients, rooms) (AddClient 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)
+ 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)
- 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 (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)
- TimerAction tick ->
- liftM firstAway $
- foldM processAction (0, serverInfo, clients, rooms) $
- PingAll : [StatsAction | even tick]
+ TimerAction tick ->
+ liftM firstAway $
+ foldM processAction (0, serverInfo, clients, rooms) $
+ 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 -}
+ {- 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
+ mainLoop newServerInfo mClients mRooms
startServer :: ServerInfo -> Socket -> IO ()
startServer serverInfo serverSocket = do
- putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
+ putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
- forkIO $
- acceptLoop
- serverSocket
- (coreChan serverInfo)
- 0
+ forkIO $
+ acceptLoop
+ serverSocket
+ (coreChan serverInfo)
+ 0
- return ()
-
- forkIO $ timerLoop 0 $ coreChan serverInfo
+ return ()
+
+ forkIO $ timerLoop 0 $ coreChan serverInfo
- startDBConnection serverInfo
+ startDBConnection serverInfo
- forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
+ forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
- forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"
\ No newline at end of file
+ forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"
\ No newline at end of file
--- a/gameServer/Utils.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/Utils.hs Thu Feb 25 18:28:33 2010 +0000
@@ -23,59 +23,71 @@
sockAddr2String :: SockAddr -> IO String
sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) =
- return $ (foldr1 (.)
- $ List.intersperse (\a -> ':':a)
- $ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) []
+ return $ (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 (length encodedMsg) : encodedMsg)
- where
- encodedMsg = UTF8.encode msg
+ where
+ encodedMsg = UTF8.encode msg
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
+ where
+ removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing
+ removeLength _ = Nothing
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)
- legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghb12345" ++ slotMessages
- slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"
+ 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,sFNpPwtghb12345" ++ slotMessages
+ slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"
maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of
- [(x, rest)] | all isSpace rest -> Just x
- _ -> Nothing
+ [(x, rest)] | all isSpace rest -> Just x
+ _ -> Nothing
-teamToNet team = [
- "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
+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
modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo
modifyTeam team room = room{teams = replaceTeam team $ teams room}
- where
- replaceTeam _ [] = error "modifyTeam: no such team"
- replaceTeam team (t:teams) =
- if teamname team == teamname t then
- team : teams
- else
- t : replaceTeam team teams
+ where
+ replaceTeam _ [] = error "modifyTeam: no such team"
+ replaceTeam team (t:teams) =
+ if teamname team == teamname t then
+ team : teams
+ else
+ t : replaceTeam team teams
illegalName :: String -> Bool
illegalName = all isSpace
@@ -98,6 +110,6 @@
askFromConsole :: String -> IO String
askFromConsole msg = do
- putStr msg
- hFlush stdout
- getLine
+ putStr msg
+ hFlush stdout
+ getLine
--- a/gameServer/hedgewars-server.hs Thu Feb 25 15:58:44 2010 +0000
+++ b/gameServer/hedgewars-server.hs Thu Feb 25 18:28:33 2010 +0000
@@ -26,32 +26,32 @@
setupLoggers =
- updateGlobalLogger "Clients"
- (setLevel INFO)
+ updateGlobalLogger "Clients"
+ (setLevel INFO)
main = withSocketsDo $ do
#if !defined(mingw32_HOST_OS)
- installHandler sigPIPE Ignore Nothing;
- installHandler sigCHLD Ignore Nothing;
+ installHandler sigPIPE Ignore Nothing;
+ installHandler sigCHLD Ignore Nothing;
#endif
- setupLoggers
+ setupLoggers
- stats <- atomically $ newTMVar (StatisticsInfo 0 0)
- dbQueriesChan <- newChan
- coreChan <- newChan
- serverInfo' <- getOpts $ newServerInfo stats coreChan dbQueriesChan
-
+ stats <- atomically $ newTMVar (StatisticsInfo 0 0)
+ dbQueriesChan <- newChan
+ coreChan <- newChan
+ serverInfo' <- getOpts $ newServerInfo stats coreChan dbQueriesChan
+
#if defined(OFFICIAL_SERVER)
- dbHost' <- askFromConsole "DB host: "
- dbLogin' <- askFromConsole "login: "
- dbPassword' <- askFromConsole "password: "
- let serverInfo = serverInfo'{dbHost = dbHost', dbLogin = dbLogin', dbPassword = dbPassword'}
+ dbHost' <- askFromConsole "DB host: "
+ dbLogin' <- askFromConsole "login: "
+ dbPassword' <- askFromConsole "password: "
+ let serverInfo = serverInfo'{dbHost = dbHost', dbLogin = dbLogin', dbPassword = dbPassword'}
#else
- let serverInfo = serverInfo'
+ let serverInfo = serverInfo'
#endif
- Exception.bracket
- (Network.listenOn $ Network.PortNumber $ listenPort serverInfo)
- sClose
- (startServer serverInfo)
+ Exception.bracket
+ (Network.listenOn $ Network.PortNumber $ listenPort serverInfo)
+ sClose
+ (startServer serverInfo)