netserver/HWProto.hs
author unc0rr
Tue, 04 Nov 2008 15:02:18 +0000
changeset 1470 ebaca3b66d92
parent 1469 5218aa76939e
child 1473 60e1fad78d58
permissions -rw-r--r--
Give more specific explanation when deny to add team

module HWProto where

import IO
import Data.List
import Data.Word
import Miscutils
import Maybe
import qualified Data.Map as Map
import Opts

teamToNet team = ["ADD_TEAM", teamname team, teamgrave team, teamfort team, show $ difficulty team] ++ hhsInfo
	where
		hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team

answerServerMessage clients = [(clientOnly, "SERVER_MESSAGE" : [mainbody ++ clientsIn])]
	where
		mainbody = serverMessage globalOptions ++ if isDedicated globalOptions then "<p align=center>Dedicated server</p>" else "<p align=center>Private server</p>"
		clientsIn = "<p align=left>" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "</p>"
		clientslist = if not $ null nicks then foldr1 (\a b -> a  ++ ", " ++ b) nicks else ""
		nicks = filter (not . null) $ map nick clients
		
answerBadCmd = [(clientOnly, ["ERROR", "Bad command, state or incorrect parameter"])]
answerNotMaster = [(clientOnly, ["ERROR", "You cannot configure room parameters"])]
answerBadParam = [(clientOnly, ["ERROR", "Bad parameter"])]
answerQuit = [(clientOnly, ["BYE"])]
answerAbandoned = [(othersInRoom, ["BYE"])]
answerQuitInform nick = [(othersInRoom, ["LEFT", nick])]
answerNickChosen = [(clientOnly, ["ERROR", "The nick already chosen"])]
answerNickChooseAnother = [(clientOnly, ["WARNING", "Choose another nick"])]
answerNick nick = [(clientOnly, ["NICK", nick])]
answerProtocolKnown = [(clientOnly, ["ERROR", "Protocol number already known"])]
answerBadInput = [(clientOnly, ["ERROR", "Bad input"])]
answerProto protoNum = [(clientOnly, ["PROTO", show protoNum])]
answerRoomsList list = [(clientOnly, ["ROOMS"] ++ list)]
answerRoomExists = [(clientOnly, ["WARNING", "There's already a room with that name"])]
answerJoined nick = [(sameRoom, ["JOINED", nick])]
answerNoRoom = [(clientOnly, ["WARNING", "There's no room with that name"])]
answerWrongPassword = [(clientOnly, ["WARNING", "Wrong password"])]
answerChatString nick msg = [(othersInRoom, ["CHAT_STRING", nick, msg])]
answerConfigParam paramName paramStrs = [(othersInRoom, "CONFIG_PARAM" : paramName : paramStrs)]
answerFullConfig room = map toAnswer (Map.toList $ params room) ++ [(clientOnly, ["MAP", gamemap room])]
	where
		toAnswer (paramName, paramStrs) =
			(clientOnly, "CONFIG_PARAM" : paramName : paramStrs)
answerCantAdd reason = [(clientOnly, ["WARNING", "Cannot add team: " ++ reason])]
answerTeamAccepted team = [(clientOnly, ["TEAM_ACCEPTED", teamname team])]
answerAddTeam team = [(othersInRoom, teamToNet team)]
answerHHNum teamName hhNumber = [(othersInRoom, ["HH_NUM", teamName, show hhNumber])]
answerRemoveTeam teamName = [(othersInRoom, ["REMOVE_TEAM", teamName])]
answerNotOwner = [(clientOnly, ["ERROR", "You do not own this team"])]
answerTeamColor teamName newColor = [(othersInRoom, ["TEAM_COLOR", teamName, newColor])]
answerAllTeams room = concatMap toAnswer (teams room)
	where
		toAnswer team =
			[(clientOnly, teamToNet team),
			(clientOnly, ["TEAM_COLOR", teamname team, teamcolor team]),
			(clientOnly, ["HH_NUM", teamname team, show $ hhnum team])]
answerMap mapName = [(othersInRoom, ["MAP", mapName])]
answerRunGame = [(sameRoom, ["RUN_GAME"])]
answerCannotCreateRoom = [(clientOnly, ["WARNING", "Cannot create more rooms"])]
answerIsReady nick = [(sameRoom, ["READY", nick])]
answerNotReady nick = [(sameRoom, ["NOT_READY", nick])]
answerTooFewClans = [(clientOnly, ["ERROR", "Too few clans in game"])]
answerRestricted = [(clientOnly, ["WARNING", "Room joining restricted"])]
answerPing = [(allClients, ["PING"])]
answerConnected = [(clientOnly, ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"])]

-- Main state-independent cmd handler
handleCmd :: CmdHandler
handleCmd client _ rooms ("QUIT":xs) =
	if null (room client) then
		(noChangeClients, noChangeRooms, answerQuit)
	else if isMaster client then
		(noChangeClients, removeRoom (room client), answerQuit ++ answerAbandoned) -- core disconnects clients on ROOMABANDONED answer
	else
		(noChangeClients, modifyRoom clRoom{teams = othersTeams, playersIn = (playersIn clRoom) - 1, readyPlayers = newReadyPlayers}, answerQuit ++ (answerQuitInform $ nick client) ++ answerRemoveClientTeams)
	where
		clRoom = roomByName (room client) rooms
		answerRemoveClientTeams = map (\tn -> (othersInRoom, ["REMOVE_TEAM", teamname tn])) clientTeams
		(clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom
		newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom

handleCmd _ _ _ ["PING"] = -- core requsted
	(noChangeClients, noChangeRooms, answerPing)

handleCmd _ _ _ ["ASKME"] = -- core requsted
	(noChangeClients, noChangeRooms, answerConnected)

handleCmd _ _ _ ["PONG"] =
	(noChangeClients, noChangeRooms, [])

-- check state and call state-dependent commmand handlers
handleCmd client clients rooms cmd =
	if null (nick client) || protocol client == 0 then
		handleCmd_noInfo client clients rooms cmd
	else if null (room client) then
		handleCmd_noRoom client clients rooms cmd
	else
		handleCmd_inRoom client clients rooms cmd


-- 'no info' state - need to get protocol number and nickname
handleCmd_noInfo :: CmdHandler
handleCmd_noInfo client clients _ ["NICK", newNick] =
	if not . null $ nick client then
		(noChangeClients, noChangeRooms, answerNickChosen)
	else if haveSameNick then
		(noChangeClients, noChangeRooms, answerNickChooseAnother)
	else
		(modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick)
	where
		haveSameNick = isJust $ find (\cl -> newNick == nick cl) clients

handleCmd_noInfo client _ _ ["PROTO", protoNum] =
	if protocol client > 0 then
		(noChangeClients, noChangeRooms, answerProtocolKnown)
	else if parsedProto == 0 then
		(noChangeClients, noChangeRooms, answerBadInput)
	else
		(modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto)
	where
		parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)

handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)


-- 'noRoom' clients state command handlers
handleCmd_noRoom :: CmdHandler
handleCmd_noRoom client clients rooms ["LIST"] =
		(noChangeClients, noChangeRooms, answerServerMessage clients ++ (answerRoomsList $ concatMap roomInfo $ sameProtoRooms))
		where
			roomInfo room = [
					name room,
					(show $ playersIn room) ++ "(" ++ (show $ length $ teams room) ++ ")",
					show $ gameinprogress room
					]
			sameProtoRooms = filter (\r -> (roomProto r == protocol client) && (not $ isRestrictedJoins r)) rooms

handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] =
	if (not $ isDedicated globalOptions) && (not $ null rooms) then
		(noChangeClients, noChangeRooms, answerCannotCreateRoom)
	else
		if haveSameRoom then
			(noChangeClients, noChangeRooms, answerRoomExists)
		else
			(modifyClient client{room = newRoom, isMaster = True}, addRoom createRoom{name = newRoom, password = roomPassword, roomProto = (protocol client)}, (answerJoined $ nick client) ++ (answerNotReady $ nick client))
	where
		haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms

handleCmd_noRoom client clients rooms ["CREATE", newRoom] =
	handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""]
	
handleCmd_noRoom client clients rooms ["JOIN", roomName, roomPassword] =
	if noSuchRoom then
		(noChangeClients, noChangeRooms, answerNoRoom)
	else if roomPassword /= password clRoom then
		(noChangeClients, noChangeRooms, answerWrongPassword)
	else if isRestrictedJoins clRoom then
		(noChangeClients, noChangeRooms, answerRestricted)
	else
		(modifyClient client{room = roomName}, modifyRoom clRoom{playersIn = 1 + playersIn clRoom}, answerNicks ++ answerReady ++ (answerJoined $ nick client) ++ (answerNotReady $ nick client) ++ answerFullConfig clRoom ++ answerAllTeams clRoom)
	where
		noSuchRoom = isNothing $ find (\room -> roomName == name room && roomProto room == protocol client) rooms
		answerNicks = [(clientOnly, ["JOINED"] ++ (map nick $ sameRoomClients))]
		answerReady = map (\c -> (clientOnly, [if isReady c then "READY" else "NOT_READY", nick c])) sameRoomClients
		sameRoomClients = filter (\ci -> room ci == roomName) clients
		clRoom = roomByName roomName rooms

handleCmd_noRoom client clients rooms ["JOIN", roomName] =
	handleCmd_noRoom client clients rooms ["JOIN", roomName, ""]

handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)


-- 'inRoom' clients state command handlers
handleCmd_inRoom :: CmdHandler
handleCmd_inRoom client _ _ ["CHAT_STRING", msg] =
	(noChangeClients, noChangeRooms, answerChatString (nick client) msg)

handleCmd_inRoom client _ rooms ("CONFIG_PARAM" : paramName : paramStrs) =
	if isMaster client then
		(noChangeClients, modifyRoom clRoom{params = Map.insert paramName paramStrs (params clRoom)}, answerConfigParam paramName paramStrs)
	else
		(noChangeClients, noChangeRooms, answerNotMaster)
	where
		clRoom = roomByName (room client) rooms

handleCmd_inRoom client _ rooms ["MAP", mapName] =
	if isMaster client then
		(noChangeClients, modifyRoom clRoom{gamemap = mapName}, answerMap mapName)
	else
		(noChangeClients, noChangeRooms, answerNotMaster)
	where
		clRoom = roomByName (room client) rooms

handleCmd_inRoom client _ rooms ("ADD_TEAM" : name : color : grave : fort : difStr : hhsInfo)
	| length hhsInfo == 16 =
	if length (teams clRoom) == 6 then
		(noChangeClients, noChangeRooms, answerCantAdd "too many teams")
	else if canAddNumber <= 0 then
		(noChangeClients, noChangeRooms, answerCantAdd "too many hedgehogs")
	else if isJust findTeam then
		(noChangeClients, noChangeRooms, answerCantAdd "already has a team with same name")
	else if gameinprogress clRoom then
		(noChangeClients, noChangeRooms, answerCantAdd "round in progress")
	else if isRestrictedTeams clRoom then
		(noChangeClients, noChangeRooms, answerCantAdd "restricted")
	else
		(noChangeClients, modifyRoom clRoom{teams = teams clRoom ++ [newTeam]}, answerTeamAccepted newTeam ++ answerAddTeam newTeam ++ answerTeamColor name color)
	where
		clRoom = roomByName (room client) rooms
		newTeam = (TeamInfo (nick client) name color grave fort difficulty newTeamHHNum (hhsList hhsInfo))
		findTeam = find (\t -> name == teamname t) $ teams clRoom
		difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int)
		hhsList [] = []
		hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
		canAddNumber = 18 - (sum . map hhnum $ teams clRoom)
		newTeamHHNum = min 4 canAddNumber

handleCmd_inRoom client _ rooms ["HH_NUM", teamName, numberStr] =
	if not $ isMaster client then
		(noChangeClients, noChangeRooms, answerNotMaster)
	else
		if hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) then
			(noChangeClients, noChangeRooms, answerBadParam)
		else
			(noChangeClients, modifyRoom $ modifyTeam clRoom team{hhnum = hhNumber}, answerHHNum teamName hhNumber)
	where
		hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
		noSuchTeam = isNothing findTeam
		team = fromJust findTeam
		findTeam = find (\t -> teamName == teamname t) $ teams clRoom
		clRoom = roomByName (room client) rooms
		canAddNumber = 18 - (sum . map hhnum $ teams clRoom)

handleCmd_inRoom client _ rooms ["TEAM_COLOR", teamName, newColor] =
	if not $ isMaster client then
		(noChangeClients, noChangeRooms, answerNotMaster)
	else
		if noSuchTeam then
			(noChangeClients, noChangeRooms, answerBadParam)
		else
			(noChangeClients, modifyRoom $ modifyTeam clRoom team{teamcolor = newColor}, answerTeamColor teamName newColor)
	where
		noSuchTeam = isNothing findTeam
		team = fromJust findTeam
		findTeam = find (\t -> teamName == teamname t) $ teams clRoom
		clRoom = roomByName (room client) rooms

handleCmd_inRoom client _ rooms ["REMOVE_TEAM", teamName] =
	if noSuchTeam then
		(noChangeClients, noChangeRooms, answerBadParam)
	else
		if not $ nick client == teamowner team then
			(noChangeClients, noChangeRooms, answerNotOwner)
		else
			(noChangeClients, modifyRoom clRoom{teams = filter (\t -> teamName /= teamname t) $ teams clRoom}, answerRemoveTeam teamName)
	where
		noSuchTeam = isNothing findTeam
		team = fromJust findTeam
		findTeam = find (\t -> teamName == teamname t) $ teams clRoom
		clRoom = roomByName (room client) rooms

handleCmd_inRoom client _ rooms ["TOGGLE_READY"] =
	if isReady client then
		(modifyClient client{isReady = False}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerNotReady $ nick client)
	else
		(modifyClient client{isReady = True}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerIsReady $ nick client)
	where
		clRoom = roomByName (room client) rooms
		newReadyPlayers = (readyPlayers clRoom) + if isReady client then -1 else 1

handleCmd_inRoom client _ rooms ["START_GAME"] =
	if isMaster client && (playersIn clRoom == readyPlayers clRoom) && (not $ gameinprogress clRoom) then
		if enoughClans then
			(noChangeClients, modifyRoom clRoom{gameinprogress = True}, answerRunGame)
		else
			(noChangeClients, noChangeRooms, answerTooFewClans)
	else
		(noChangeClients, noChangeRooms, [])
	where
		clRoom = roomByName (room client) rooms
		enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams clRoom

handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_JOINS"] =
	if isMaster client then
		(noChangeClients, modifyRoom clRoom{isRestrictedJoins = newStatus}, [])
	else
		(noChangeClients, noChangeRooms, answerNotMaster)
	where
		clRoom = roomByName (room client) rooms
		newStatus = not $ isRestrictedJoins clRoom

handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_TEAMS"] =
	if isMaster client then
		(noChangeClients, modifyRoom clRoom{isRestrictedTeams = newStatus}, [])
	else
		(noChangeClients, noChangeRooms, answerNotMaster)
	where
		clRoom = roomByName (room client) rooms
		newStatus = not $ isRestrictedTeams clRoom

handleCmd_inRoom client clients rooms ["ROUNDFINISHED"] =
	if isMaster client then
		(modifyRoomClients clRoom (\cl -> cl{isReady = False}), modifyRoom clRoom{gameinprogress = False, readyPlayers = 0}, answerAllNotReady)
	else
		(noChangeClients, noChangeRooms, [])
	where
		clRoom = roomByName (room client) rooms
		sameRoomClients = filter (\ci -> room ci == name clRoom) clients
		answerAllNotReady = map (\cl -> (sameRoom, ["NOT_READY", nick cl])) sameRoomClients

handleCmd_inRoom client _ _ ["GAMEMSG", msg] =
	(noChangeClients, noChangeRooms, [(othersInRoom, ["GAMEMSG", msg])])

handleCmd_inRoom client clients rooms ["KICK", kickNick] =
	if isMaster client then
		if noSuchClient || (kickClient == client) then
			(noChangeClients, noChangeRooms, [])
		else
			(modifyClient kickClient{forceQuit = True}, noChangeRooms, [])
	else
		(noChangeClients, noChangeRooms, [])
	where
		clRoom = roomByName (room client) rooms
		noSuchClient = isNothing findClient
		kickClient = fromJust findClient
		findClient = find (\t -> ((room t) == (room client)) && ((nick t) == kickNick)) $ clients

handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)