hedgewars: gameServer/HWProtoNEState.hs@11cd56019f00 (annotated)

1804 4e78ad846fb6 New game server: unc0rr parents: diff changeset	1	module HWProtoNEState where
4e78ad846fb6 New game server: unc0rr parents: diff changeset	2
4e78ad846fb6 New game server: unc0rr parents: diff changeset	3	import qualified Data.IntMap as IntMap
4e78ad846fb6 New game server: unc0rr parents: diff changeset	4	import Maybe
4e78ad846fb6 New game server: unc0rr parents: diff changeset	5	import Data.List
4e78ad846fb6 New game server: unc0rr parents: diff changeset	6	import Data.Word
3458 11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	7	import Control.Monad.Reader
1804 4e78ad846fb6 New game server: unc0rr parents: diff changeset	8	--------------------------------------
4e78ad846fb6 New game server: unc0rr parents: diff changeset	9	import CoreTypes
4e78ad846fb6 New game server: unc0rr parents: diff changeset	10	import Actions
4e78ad846fb6 New game server: unc0rr parents: diff changeset	11	import Utils
3458 11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	12	import RoomsAndClients
1804 4e78ad846fb6 New game server: unc0rr parents: diff changeset	13
4e78ad846fb6 New game server: unc0rr parents: diff changeset	14	handleCmd_NotEntered :: CmdHandler
4e78ad846fb6 New game server: unc0rr parents: diff changeset	15
3458 11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	16	handleCmd_NotEntered ["NICK", newNick] = do
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	17	(ci, irnc) <- ask
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	18	let cl = irnc `client` ci
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	19	if not . null $ nick cl then return [ProtocolError "Nickname already chosen"]
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	20	else
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	21	if haveSameNick irnc then return [AnswerClients [sendChan cl] ["WARNING", "Nickname already in use"], ByeClient ""]
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	22	else
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	23	if illegalName newNick then return [ByeClient "Illegal nickname"]
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	24	else
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	25	return $
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	26	ModifyClient (\c -> c{nick = newNick}) :
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	27	AnswerClients [sendChan cl] ["NICK", newNick] :
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	28	[CheckRegistered \| clientProto cl /= 0]
2867 9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	29	where
3458 11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	30	haveSameNick irnc = False --isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
1804 4e78ad846fb6 New game server: unc0rr parents: diff changeset	31
3458 11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	32	handleCmd_NotEntered ["PROTO", protoNum] = do
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	33	(ci, irnc) <- ask
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	34	let cl = irnc `client` ci
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	35	if clientProto cl > 0 then return [ProtocolError "Protocol already known"]
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	36	else
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	37	if parsedProto == 0 then return [ProtocolError "Bad number"]
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	38	else
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	39	return $
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	40	ModifyClient (\c -> c{clientProto = parsedProto}) :
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	41	AnswerClients [sendChan cl] ["PROTO", show parsedProto] :
11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	42	[CheckRegistered \| (not . null) (nick cl)]
2867 9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	43	where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	44	parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
1841 fba7210b438b Retrieve client password from web database and ask for it unc0rr parents: 1834 diff changeset	45
3458 11cd56019f00 Make some more protocol commands work unc0rr parents: 3435 diff changeset	46	{-
1879 bb114339eb4e Implement kick from room unc0rr parents: 1847 diff changeset	47
1844 81abed9d4c11 Ask user password and send it to server unc0rr parents: 1841 diff changeset	48	handleCmd_NotEntered clID clients _ ["PASSWORD", passwd] =
2867 9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	49	if passwd == webPassword client then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	50	[ModifyClient (\cl -> cl{logonPassed = True}),
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	51	MoveToLobby] ++ adminNotice
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	52	else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	53	[ByeClient "Authentication failed"]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	54	where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	55	client = clients IntMap.! clID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev unc0rr parents: 2747 diff changeset	56	adminNotice = [AnswerThisClient ["ADMIN_ACCESS"] \| isAdministrator client]
1804 4e78ad846fb6 New game server: unc0rr parents: diff changeset	57
4e78ad846fb6 New game server: unc0rr parents: diff changeset	58
2868 ccb20ecd3503 Some debug stuff unc0rr parents: 2867 diff changeset	59	handleCmd_NotEntered clID clients _ ["DUMP"] =
ccb20ecd3503 Some debug stuff unc0rr parents: 2867 diff changeset	60	if isAdministrator (clients IntMap.! clID) then [Dump] else []
3435 4e4f88a7bdf2 Some more steps in refactoring unc0rr parents: 2868 diff changeset	61	-}
1804 4e78ad846fb6 New game server: unc0rr parents: diff changeset	62
3435 4e4f88a7bdf2 Some more steps in refactoring unc0rr parents: 2868 diff changeset	63	handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"]

author	unc0rr
	Mon, 10 May 2010 17:48:06 +0000
changeset 3458	11cd56019f00
parent 3435	4e4f88a7bdf2
child 3500	af8390d807d6
permissions	-rw-r--r--