hedgewars: netserver/HWProto.hs@05cebf68ebd8 (annotated)

890 1d8c4a5ec622 - Improve server core unc0rr parents: diff changeset	1	module HWProto where
1d8c4a5ec622 - Improve server core unc0rr parents: diff changeset	2
1d8c4a5ec622 - Improve server core unc0rr parents: diff changeset	3	import IO
896 93df8ac94382 Handle password parameter on JOIN unc0rr parents: 895 diff changeset	4	import Data.List
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	5	import Data.Word
890 1d8c4a5ec622 - Improve server core unc0rr parents: diff changeset	6	import Miscutils
896 93df8ac94382 Handle password parameter on JOIN unc0rr parents: 895 diff changeset	7	import Maybe (fromMaybe, fromJust)
890 1d8c4a5ec622 - Improve server core unc0rr parents: diff changeset	8
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	9	answerBadCmd = [(clientOnly, ["ERROR", "Bad command, state or incorrect parameter"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	10	answerQuit = [(clientOnly, ["QUIT"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	11	answerAbandoned = [(sameRoom, ["ROOMABANDONED"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	12	answerQuitInform nick = [(sameRoom, ["QUIT", nick])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	13	answerNickChosen = [(clientOnly, ["ERROR", "The nick already chosen"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	14	answerNickChooseAnother = [(clientOnly, ["WARNING", "Choose another nick"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	15	answerNick nick = [(clientOnly, ["NICK", nick])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	16	answerProtocolKnown = [(clientOnly, ["ERROR", "Protocol number already known"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	17	answerBadInput = [(clientOnly, ["ERROR", "Bad input"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	18	answerProto protoNum = [(clientOnly, ["PROTO", show protoNum])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	19	answerRoomsList list = [(clientOnly, ["ROOMS"] ++ list)]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	20	answerRoomExists = [(clientOnly, ["WARNING", "There's already a room with that name"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	21	answerJoined nick = [(sameRoom, ["JOINED", nick])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	22	answerNoRoom = [(clientOnly, ["WARNING", "There's no room with that name"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	23	answerWrongPassword = [(clientOnly, ["WARNING", "Wrong password"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	24	answerChatString nick msg = [(othersInRoom, ["CHAT_STRING", nick, msg])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	25
1082 596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	26	-- Main state-independent cmd handler
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	27	handleCmd :: CmdHandler
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	28	handleCmd client _ rooms ("QUIT":xs) =
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	29	if null (room client) then
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	30	(noChangeClients, noChangeRooms, answerQuit)
1082 596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	31	else if isMaster client then
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	32	(noChangeClients, removeRoom (room client), (answerQuitInform $ nick client) ++ answerAbandoned) -- core disconnects clients on ROOMABANDONED answer
1082 596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	33	else
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	34	(noChangeClients, noChangeRooms, answerQuitInform $ nick client)
895 6aee2f335726 - Remove old hwserv code unc0rr parents: 894 diff changeset	35
1082 596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	36	-- check state and call state-dependent commmand handlers
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	37	handleCmd client clients rooms cmd =
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	38	if null (nick client) \|\| protocol client == 0 then
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	39	handleCmd_noInfo client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	40	else if null (room client) then
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	41	handleCmd_noRoom client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	42	else
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	43	handleCmd_inRoom client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	44
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	45	-- 'no info' state - need to get protocol number and nickname
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	46	handleCmd_noInfo :: CmdHandler
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	47	handleCmd_noInfo client clients _ ["NICK", newNick] =
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	48	if not . null $ nick client then
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	49	(noChangeClients, noChangeRooms, answerNickChosen)
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	50	else if haveSameNick then
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	51	(noChangeClients, noChangeRooms, answerNickChooseAnother)
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	52	else
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	53	(modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick)
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	54	where
2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	55	haveSameNick = not . null $ filter (\cl -> newNick == nick cl) clients
2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	56
1082 596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	57	handleCmd_noInfo client _ _ ["PROTO", protoNum] =
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	58	if protocol client > 0 then
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	59	(noChangeClients, noChangeRooms, answerProtocolKnown)
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	60	else if parsedProto == 0 then
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	61	(noChangeClients, noChangeRooms, answerBadInput)
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	62	else
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	63	(modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto)
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	64	where
2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	65	parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	66
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	67	handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	68
2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	69	-- 'noRoom' clients state command handlers
1082 596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	70	handleCmd_noRoom :: CmdHandler
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	71	handleCmd_noRoom client _ rooms ["LIST"] =
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	72	(noChangeClients, noChangeRooms, answerRoomsList $ map name rooms)
903 d4e5d8cbe449 Implement LIST command unc0rr parents: 902 diff changeset	73
1082 596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	74	handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] =
895 6aee2f335726 - Remove old hwserv code unc0rr parents: 894 diff changeset	75	if haveSameRoom then
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	76	(noChangeClients, noChangeRooms, answerRoomExists)
895 6aee2f335726 - Remove old hwserv code unc0rr parents: 894 diff changeset	77	else
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	78	(modifyClient client{room = newRoom, isMaster = True}, addRoom (RoomInfo newRoom roomPassword []), answerJoined $ nick client)
895 6aee2f335726 - Remove old hwserv code unc0rr parents: 894 diff changeset	79	where
6aee2f335726 - Remove old hwserv code unc0rr parents: 894 diff changeset	80	haveSameRoom = not . null $ filter (\room -> newRoom == name room) rooms
6aee2f335726 - Remove old hwserv code unc0rr parents: 894 diff changeset	81
1082 596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	82	handleCmd_noRoom client clients rooms ["CREATE", newRoom] =
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	83	handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""]
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	84
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	85	handleCmd_noRoom client _ rooms ["JOIN", roomName, roomPassword] =
902 3cc10f0aae37 Finish conversion unc0rr parents: 901 diff changeset	86	if noSuchRoom then
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	87	(noChangeClients, noChangeRooms, answerNoRoom)
902 3cc10f0aae37 Finish conversion unc0rr parents: 901 diff changeset	88	else if roomPassword /= password (roomByName roomName rooms) then
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	89	(noChangeClients, noChangeRooms, answerWrongPassword)
895 6aee2f335726 - Remove old hwserv code unc0rr parents: 894 diff changeset	90	else
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	91	(modifyClient client{room = roomName}, noChangeRooms, answerJoined $ nick client)
895 6aee2f335726 - Remove old hwserv code unc0rr parents: 894 diff changeset	92	where
902 3cc10f0aae37 Finish conversion unc0rr parents: 901 diff changeset	93	noSuchRoom = null $ filter (\room -> roomName == name room) rooms
895 6aee2f335726 - Remove old hwserv code unc0rr parents: 894 diff changeset	94
1082 596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	95	handleCmd_noRoom client clients rooms ["JOIN", roomName] =
596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	96	handleCmd_noRoom client clients rooms ["JOIN", roomName, ""]
894 2ca76a7f3121 - Fixed some bugs unc0rr parents: 893 diff changeset	97
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	98	handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
895 6aee2f335726 - Remove old hwserv code unc0rr parents: 894 diff changeset	99
897 35d91fa3753b 'In room' state stub unc0rr parents: 896 diff changeset	100	-- 'inRoom' clients state command handlers
1082 596b1dcdc1df - Modify network protocol to use new delimiter unc0rr parents: 903 diff changeset	101	handleCmd_inRoom :: CmdHandler
897 35d91fa3753b 'In room' state stub unc0rr parents: 896 diff changeset	102
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	103	handleCmd_inRoom client _ _ ["CHAT_STRING", _, msg] = (noChangeClients, noChangeRooms, answerChatString (nick client) msg)
1083 3448dd03483f Further work on dedicated server unc0rr parents: 1082 diff changeset	104
1304 05cebf68ebd8 Start refactoring standalone server (prepare to change protocol) unc0rr parents: 1302 diff changeset	105	handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)

author	unc0rr
	Sun, 05 Oct 2008 23:22:14 +0000
changeset 1304	05cebf68ebd8
parent 1302	4290ba4a14ca
child 1305	453882eb4467
permissions	-rw-r--r--