hedgewars-draft: gameServer/HWProtoNEState.hs@b235e520ea21 (annotated)

8372 3c193ec03e09 Logon procedure for checkers, introduce invisible clients unc0rr parents: 8371 diff changeset	1	{-# LANGUAGE OverloadedStrings, CPP #-}
1804 4e78ad846fb6 New game server: unc0rr parents: diff changeset	2	module HWProtoNEState where
4e78ad846fb6 New game server: unc0rr parents: diff changeset	3
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	4	import Control.Monad.Reader
10076 b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	5	import qualified Data.ByteString.Lazy as BL
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	6	import qualified Data.ByteString.Char8 as B
10076 b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	7	import Data.Digest.Pure.SHA
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
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	12	import RoomsAndClients
1804 4e78ad846fb6 New game server: unc0rr parents: diff changeset	13
4989 4771fed9272e - Write server config into .ini file on change unc0rr parents: 4975 diff changeset	14	handleCmd_NotEntered :: CmdHandler
1804 4e78ad846fb6 New game server: unc0rr parents: diff changeset	15
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	16	handleCmd_NotEntered ["NICK", newNick] = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	17	(ci, irnc) <- ask
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	18	let cl = irnc `client` ci
8401 87410ae372f6 Server messages localization using Qt's l10n subsystem: unc0rr parents: 8372 diff changeset	19	if not . B.null $ nick cl then return [ProtocolError $ loc "Nickname already chosen"]
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	20	else
8401 87410ae372f6 Server messages localization using Qt's l10n subsystem: unc0rr parents: 8372 diff changeset	21	if illegalName newNick then return [ByeClient $ loc "Illegal nickname"]
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	22	else
4991 90d1fb9fc2e1 Fix check for duplicated nickname unc0rr parents: 4989 diff changeset	23	return $
90d1fb9fc2e1 Fix check for duplicated nickname unc0rr parents: 4989 diff changeset	24	ModifyClient (\c -> c{nick = newNick}) :
90d1fb9fc2e1 Fix check for duplicated nickname unc0rr parents: 4989 diff changeset	25	AnswerClients [sendChan cl] ["NICK", newNick] :
90d1fb9fc2e1 Fix check for duplicated nickname unc0rr parents: 4989 diff changeset	26	[CheckRegistered \| clientProto cl /= 0]
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	27
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	28	handleCmd_NotEntered ["PROTO", protoNum] = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	29	(ci, irnc) <- ask
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	30	let cl = irnc `client` ci
8401 87410ae372f6 Server messages localization using Qt's l10n subsystem: unc0rr parents: 8372 diff changeset	31	if clientProto cl > 0 then return [ProtocolError $ loc "Protocol already known"]
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	32	else
8401 87410ae372f6 Server messages localization using Qt's l10n subsystem: unc0rr parents: 8372 diff changeset	33	if parsedProto == 0 then return [ProtocolError $ loc "Bad number"]
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	34	else
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	35	return $
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	36	ModifyClient (\c -> c{clientProto = parsedProto}) :
5030 42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc. EJ <eivind.jahren@gmail.com> parents: 4991 diff changeset	37	AnswerClients [sendChan cl] ["PROTO", showB parsedProto] :
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	38	[CheckRegistered \| not . B.null $ nick cl]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	39	where
5090 2922455e606e Use readInt_ unc0rr parents: 5030 diff changeset	40	parsedProto = readInt_ protoNum
1841 fba7210b438b Retrieve client password from web database and ask for it unc0rr parents: 1834 diff changeset	41
3536 7d99655130ff Partially reimplement joining rooms unc0rr parents: 3500 diff changeset	42
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	43	handleCmd_NotEntered ["PASSWORD", passwd] = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	44	(ci, irnc) <- ask
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	45	let cl = irnc `client` ci
1879 bb114339eb4e Implement kick from room unc0rr parents: 1847 diff changeset	46
10076 b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	47	if clientProto cl < 48 && passwd == webPassword cl then
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	48	return $ JoinLobby : [AnswerClients [sendChan cl] ["ADMIN_ACCESS"] \| isAdministrator cl]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	49	else
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	50	return [ByeClient "Authentication failed"]
1879 bb114339eb4e Implement kick from room unc0rr parents: 1847 diff changeset	51
1804 4e78ad846fb6 New game server: unc0rr parents: diff changeset	52
10076 b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	53	handleCmd_NotEntered ["PASSWORD", passwd, clientSalt] = do
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	54	(ci, irnc) <- ask
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	55	let cl = irnc `client` ci
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	56
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	57	let clientHash = h [clientSalt, serverSalt cl, webPassword cl, showB $ clientProto cl, "!hedgewars"]
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	58	let serverHash = h [serverSalt cl, clientSalt, webPassword cl, showB $ clientProto cl, "!hedgewars"]
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	59
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	60	if passwd == clientHash then
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	61	return $
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	62	AnswerClients [sendChan cl] ["SERVER_AUTH", serverHash]
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	63	: JoinLobby
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	64	: [AnswerClients [sendChan cl] ["ADMIN_ACCESS"] \| isAdministrator cl]
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	65	else
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	66	return [ByeClient "Authentication failed"]
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	67	where
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	68	h = B.pack . showDigest . sha1 . BL.fromChunks
b235e520ea21 Mutual authentication: server side unc0rr parents: 8401 diff changeset	69
8372 3c193ec03e09 Logon procedure for checkers, introduce invisible clients unc0rr parents: 8371 diff changeset	70	#if defined(OFFICIAL_SERVER)
8371 0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	71	handleCmd_NotEntered ["CHECKER", protoNum, newNick, password] = do
0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	72	(ci, irnc) <- ask
0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	73	let cl = irnc `client` ci
0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	74
8401 87410ae372f6 Server messages localization using Qt's l10n subsystem: unc0rr parents: 8372 diff changeset	75	if parsedProto == 0 then return [ProtocolError $ loc "Bad number"]
8371 0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	76	else
0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	77	return $ [
0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	78	ModifyClient (\c -> c{clientProto = parsedProto, nick = newNick, webPassword = password, isChecker = True})
0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	79	, CheckRegistered]
0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	80	where
0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	81	parsedProto = readInt_ protoNum
8372 3c193ec03e09 Logon procedure for checkers, introduce invisible clients unc0rr parents: 8371 diff changeset	82	#endif
8371 0551b5c3de9a - Start work on checker unc0rr parents: 5090 diff changeset	83
4295 1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly nemo parents: 4242 diff changeset	84	handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"]

author	unc0rr
	Sun, 26 Jan 2014 02:17:04 +0400
changeset 10076	b235e520ea21
parent 8401	87410ae372f6
child 10077	ca67740f19b2
permissions	-rw-r--r--