# HG changeset patch # User unc0rr # Date 1267122513 0 # Node ID 9be6693c78cb715ca990310443cbd289a8609499 # Parent 450ca0afcd58597ac649a3eb46e0e4cfbffb1026 - Unbreak support for client versions prior to 0.9.13-dev - Replace tabs with spaces (sorry for mixing with code changes) diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/Actions.hs --- 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) diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/ClientIO.hs --- 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 diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/CoreTypes.hs --- 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 - "

http://www.hedgewars.org/

" - "

Hedgewars 0.9.12 is out! Please update.

Download page here" - 46631 - 0 - "" - "" - "" - [] - ) + ServerInfo + True + "

http://www.hedgewars.org/

" + "

Hedgewars 0.9.12 is out! Please update.

Download page here" + 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 diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/HWProtoCore.hs --- 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 diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/HWProtoInRoomState.hs --- 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)"] diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/HWProtoLobbyState.hs --- 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)"] diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/HWProtoNEState.hs --- 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"] = diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/NetRoutines.hs --- 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 diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/Opts.hs --- 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...]" diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/ServerCore.hs --- 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 diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/Utils.hs --- 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 diff -r 450ca0afcd58 -r 9be6693c78cb gameServer/hedgewars-server.hs --- 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)