--- 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)