gameServer/HWProtoNEState.hs
author unc0rr
Fri, 04 Sep 2009 07:04:27 +0000
changeset 2348 b39d826e1ccd
parent 2155 d897222d3339
child 2349 ba7a0813c532
permissions -rw-r--r--
Drop support for ghc 6.8, use 6.10 instead
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import Utils
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
handleCmd_NotEntered :: CmdHandler
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
handleCmd_NotEntered clID clients _ ["NICK", newNick] =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
	if not . null $ nick client then
2150
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 1879
diff changeset
    16
		[ProtocolError "Nickname already chosen"]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
	else if haveSameNick then
2150
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 1879
diff changeset
    18
		[AnswerThisClient ["WARNING", "Nickname collision"]]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
		++ [ByeClient ""]
2150
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 1879
diff changeset
    20
	else if illegalName newNick then
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 1879
diff changeset
    21
		[ByeClient "Illegal nickname"]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
	else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
		[ModifyClient (\c -> c{nick = newNick}),
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
		AnswerThisClient ["NICK", newNick]]
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1834
diff changeset
    25
		++ checkPassword
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
		client = clients IntMap.! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
		haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1834
diff changeset
    29
		checkPassword = if clientProto client /= 0 then [CheckRegistered] else []
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
handleCmd_NotEntered clID clients _ ["PROTO", protoNum] =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
	if clientProto client > 0 then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
		[ProtocolError "Protocol already known"]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
	else if parsedProto == 0 then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
		[ProtocolError "Bad number"]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
	else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
		[ModifyClient (\c -> c{clientProto = parsedProto}),
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
		AnswerThisClient ["PROTO", show parsedProto]]
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1834
diff changeset
    40
		++ checkPassword
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
		client = clients IntMap.! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
		parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1834
diff changeset
    44
		checkPassword = if (not . null) (nick client) then [CheckRegistered] else []
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1834
diff changeset
    45
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1847
diff changeset
    46
1844
81abed9d4c11 Ask user password and send it to server
unc0rr
parents: 1841
diff changeset
    47
handleCmd_NotEntered clID clients _ ["PASSWORD", passwd] =
81abed9d4c11 Ask user password and send it to server
unc0rr
parents: 1841
diff changeset
    48
	if passwd == webPassword client then
81abed9d4c11 Ask user password and send it to server
unc0rr
parents: 1841
diff changeset
    49
		[ModifyClient (\cl -> cl{logonPassed = True}),
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1844
diff changeset
    50
		MoveToLobby] ++ adminNotice
1844
81abed9d4c11 Ask user password and send it to server
unc0rr
parents: 1841
diff changeset
    51
	else
81abed9d4c11 Ask user password and send it to server
unc0rr
parents: 1841
diff changeset
    52
		[ByeClient "Authentication failed"]
81abed9d4c11 Ask user password and send it to server
unc0rr
parents: 1841
diff changeset
    53
	where
81abed9d4c11 Ask user password and send it to server
unc0rr
parents: 1841
diff changeset
    54
		client = clients IntMap.! clID
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1844
diff changeset
    55
		adminNotice = if isAdministrator client then [AnswerThisClient ["ADMIN_ACCESS"]] else []
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2150
diff changeset
    58
--handleCmd_NotEntered _ _ _ ["DUMP"] =
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2150
diff changeset
    59
--	[Dump]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    61
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
handleCmd_NotEntered clID _ _ _ = [ProtocolError "Incorrect command (state: not entered)"]