gameServer/HWProtoCore.hs
author unc0rr
Fri, 01 May 2009 09:01:44 +0000
changeset 2021 a591afb43768
parent 1929 7e6cc8da1c58
child 2126 cb249fa8e3da
permissions -rw-r--r--
Some changes in try to fix issue when you enter room with painted map, but frontend shows generated one (most probably bug is triggered by template filters) Untested.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
module HWProtoCore 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
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
     4
import Data.Foldable
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
     5
import Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import Utils
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import HWProtoNEState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import HWProtoLobbyState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import HWProtoInRoomState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    14
handleCmd, handleCmd_loggedin :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
handleCmd clID _ _ ["PING"] = [AnswerThisClient ["PONG"]]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
1814
e5391d901cff - Remove client teams on exit
unc0rr
parents: 1811
diff changeset
    18
handleCmd clID clients rooms ("QUIT" : xs) =
1929
7e6cc8da1c58 - Fix bug with kicking players
unc0rr
parents: 1928
diff changeset
    19
	[ByeClient msg]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
		msg = if not $ null xs then head xs else ""
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    23
1928
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1879
diff changeset
    24
handleCmd clID clients _ ["PONG"] =
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1879
diff changeset
    25
	if pingsQueue client == 0 then
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1879
diff changeset
    26
		[ProtocolError "Protocol violation"]
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1879
diff changeset
    27
	else
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1879
diff changeset
    28
		[ModifyClient (\cl -> cl{pingsQueue = pingsQueue cl - 1})]
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1879
diff changeset
    29
	where
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1879
diff changeset
    30
		client = clients IntMap.! clID
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1879
diff changeset
    31
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1879
diff changeset
    32
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
handleCmd clID clients rooms cmd =
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1814
diff changeset
    34
	if not $ logonPassed client then
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
		handleCmd_NotEntered clID clients rooms cmd
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    36
	else
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    37
		handleCmd_loggedin clID clients rooms cmd
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    38
	where
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    39
		client = clients IntMap.! clID
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    40
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    41
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    42
handleCmd_loggedin clID clients rooms ["INFO", asknick] =
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    43
	if noSuchClient then
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    44
		[]
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    45
	else
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    46
		[AnswerThisClient
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    47
			["INFO",
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    48
			nick client,
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    49
			"[" ++ host client ++ "]",
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    50
			protoNumber2ver $ clientProto client,
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    51
			roomInfo]]
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    52
	where
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    53
		maybeClient = find (\cl -> asknick == nick cl) clients
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    54
		noSuchClient = isNothing maybeClient
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    55
		client = fromJust maybeClient
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    56
		room = rooms IntMap.! roomID client
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    57
		roomInfo = if roomID client /= 0 then "room " ++ (name room) else "lobby"
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    58
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    59
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    60
handleCmd_loggedin clID clients rooms cmd =
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    61
	if roomID client == 0 then
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
		handleCmd_lobby clID clients rooms cmd
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    63
	else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    64
		handleCmd_inRoom clID clients rooms cmd
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
		client = clients IntMap.! clID