netserver/HWProto.hs
author unc0rr
Thu, 09 Oct 2008 13:43:47 +0000
changeset 1327 9d43a6e6b9ca
parent 1325 c8994d47f41d
child 1328 c41344e3c236
permissions -rw-r--r--
Can choose hedgehogs number now
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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
1320
bffc7262e25e Optimize list lookups a bit
unc0rr
parents: 1317
diff changeset
     7
import Maybe
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
     8
import qualified Data.Map as Map
890
1d8c4a5ec622 - Improve server core
unc0rr
parents:
diff changeset
     9
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    10
answerBadCmd = [(clientOnly, ["ERROR", "Bad command, state or incorrect parameter"])]
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    11
answerNotMaster = [(clientOnly, ["ERROR", "You cannot configure room parameters"])]
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
    12
answerBadParam = [(clientOnly, ["ERROR", "Bad parameter"])]
1309
1a38a967bd48 Fix a bug with 'ghosts' on server
unc0rr
parents: 1308
diff changeset
    13
answerQuit = [(clientOnly, ["off"])]
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
    14
answerAbandoned = [(othersInRoom, ["BYE"])]
1309
1a38a967bd48 Fix a bug with 'ghosts' on server
unc0rr
parents: 1308
diff changeset
    15
answerQuitInform nick = [(othersInRoom, ["LEFT", nick])]
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    16
answerNickChosen = [(clientOnly, ["ERROR", "The nick already chosen"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    17
answerNickChooseAnother = [(clientOnly, ["WARNING", "Choose another nick"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    18
answerNick nick = [(clientOnly, ["NICK", nick])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    19
answerProtocolKnown = [(clientOnly, ["ERROR", "Protocol number already known"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    20
answerBadInput = [(clientOnly, ["ERROR", "Bad input"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    21
answerProto protoNum = [(clientOnly, ["PROTO", show protoNum])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    22
answerRoomsList list = [(clientOnly, ["ROOMS"] ++ list)]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    23
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
    24
answerJoined nick = [(sameRoom, ["JOINED", nick])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    25
answerNoRoom = [(clientOnly, ["WARNING", "There's no room with that name"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    26
answerWrongPassword = [(clientOnly, ["WARNING", "Wrong password"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    27
answerChatString nick msg = [(othersInRoom, ["CHAT_STRING", nick, msg])]
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    28
answerConfigParam paramName paramStrs = [(othersInRoom, "CONFIG_PARAM" : paramName : paramStrs)]
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    29
answerFullConfig room = map toAnswer (Map.toList $ params room)
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    30
	where
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
    31
		toAnswer (paramName, paramStrs) =
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    32
			(clientOnly, "CONFIG_PARAM" : paramName : paramStrs)
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
    33
answerCantAdd = [(clientOnly, ["WARNING", "Too many teams or hedgehogs"])]
1325
c8994d47f41d Adding teams now works
unc0rr
parents: 1323
diff changeset
    34
answerTeamAccepted team = [(clientOnly, ["TEAM_ACCEPTED", teamname team])]
c8994d47f41d Adding teams now works
unc0rr
parents: 1323
diff changeset
    35
answerAddTeam team = [(othersInRoom, ["ADD_TEAM", teamname team, teamgrave team, teamfort team, show $ difficulty team] ++ hhsInfo)]
c8994d47f41d Adding teams now works
unc0rr
parents: 1323
diff changeset
    36
	where
c8994d47f41d Adding teams now works
unc0rr
parents: 1323
diff changeset
    37
		hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
    38
answerHHNum teamName hhNumber = [(othersInRoom, ["HH_NUM", teamName, show hhNumber])]
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
    39
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    40
-- Main state-independent cmd handler
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    41
handleCmd :: CmdHandler
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    42
handleCmd client _ rooms ("QUIT":xs) =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    43
	if null (room client) then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    44
		(noChangeClients, noChangeRooms, answerQuit)
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    45
	else if isMaster client then
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
    46
		(noChangeClients, removeRoom (room client), answerQuit ++ answerAbandoned) -- core disconnects clients on ROOMABANDONED answer
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    47
	else
1309
1a38a967bd48 Fix a bug with 'ghosts' on server
unc0rr
parents: 1308
diff changeset
    48
		(noChangeClients, noChangeRooms, answerQuit ++ (answerQuitInform $ nick client))
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
    49
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
    50
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    51
-- check state and call state-dependent commmand handlers
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    52
handleCmd client clients rooms cmd =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    53
	if null (nick client) || protocol client == 0 then
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    54
		handleCmd_noInfo client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    55
	else if null (room client) then
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    56
		handleCmd_noRoom client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    57
	else
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    58
		handleCmd_inRoom client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    59
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
    60
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    61
-- 'no info' state - need to get protocol number and nickname
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    62
handleCmd_noInfo :: CmdHandler
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    63
handleCmd_noInfo client clients _ ["NICK", newNick] =
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    64
	if not . null $ nick client then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    65
		(noChangeClients, noChangeRooms, answerNickChosen)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    66
	else if haveSameNick then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    67
		(noChangeClients, noChangeRooms, answerNickChooseAnother)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    68
	else
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    69
		(modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    70
	where
1320
bffc7262e25e Optimize list lookups a bit
unc0rr
parents: 1317
diff changeset
    71
		haveSameNick = isJust $ find (\cl -> newNick == nick cl) clients
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    72
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    73
handleCmd_noInfo client _ _ ["PROTO", protoNum] =
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    74
	if protocol client > 0 then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    75
		(noChangeClients, noChangeRooms, answerProtocolKnown)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    76
	else if parsedProto == 0 then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    77
		(noChangeClients, noChangeRooms, answerBadInput)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    78
	else
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    79
		(modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    80
	where
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    81
		parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    82
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    83
handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    84
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
    85
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    86
-- 'noRoom' clients state command handlers
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    87
handleCmd_noRoom :: CmdHandler
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    88
handleCmd_noRoom client _ rooms ["LIST"] =
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    89
		(noChangeClients, noChangeRooms, answerRoomsList $ map name rooms)
903
d4e5d8cbe449 Implement LIST command
unc0rr
parents: 902
diff changeset
    90
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    91
handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] =
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
    92
	if haveSameRoom then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    93
		(noChangeClients, noChangeRooms, answerRoomExists)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
    94
	else
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    95
		(modifyClient client{room = newRoom, isMaster = True}, addRoom (RoomInfo newRoom roomPassword (protocol client) [] Map.empty), answerJoined $ nick client)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
    96
	where
1320
bffc7262e25e Optimize list lookups a bit
unc0rr
parents: 1317
diff changeset
    97
		haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
    98
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    99
handleCmd_noRoom client clients rooms ["CREATE", newRoom] =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   100
	handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""]
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   101
	
1308
d5dcd6cfa5e2 Fix another server failure (when second client in room disconnects)
unc0rr
parents: 1307
diff changeset
   102
handleCmd_noRoom client clients rooms ["JOIN", roomName, roomPassword] =
902
3cc10f0aae37 Finish conversion
unc0rr
parents: 901
diff changeset
   103
	if noSuchRoom then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   104
		(noChangeClients, noChangeRooms, answerNoRoom)
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   105
	else if roomPassword /= password clRoom then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   106
		(noChangeClients, noChangeRooms, answerWrongPassword)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   107
	else
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   108
		(modifyClient client{room = roomName}, noChangeRooms, (answerJoined $ nick client) ++ answerNicks ++ answerFullConfig clRoom)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   109
	where
1320
bffc7262e25e Optimize list lookups a bit
unc0rr
parents: 1317
diff changeset
   110
		noSuchRoom = isNothing $ find (\room -> roomName == name room) rooms
1308
d5dcd6cfa5e2 Fix another server failure (when second client in room disconnects)
unc0rr
parents: 1307
diff changeset
   111
		answerNicks = [(clientOnly, ["JOINED"] ++ (map nick $ filter (\ci -> room ci == roomName) clients))]
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   112
		clRoom = roomByName roomName rooms
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   113
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   114
handleCmd_noRoom client clients rooms ["JOIN", roomName] =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   115
	handleCmd_noRoom client clients rooms ["JOIN", roomName, ""]
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   116
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   117
handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   118
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
   119
897
35d91fa3753b 'In room' state stub
unc0rr
parents: 896
diff changeset
   120
-- 'inRoom' clients state command handlers
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   121
handleCmd_inRoom :: CmdHandler
1322
c624b04699fb Fix protocol implementation to conform documentation
unc0rr
parents: 1321
diff changeset
   122
handleCmd_inRoom client _ _ ["CHAT_STRING", msg] =
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
   123
	(noChangeClients, noChangeRooms, answerChatString (nick client) msg)
897
35d91fa3753b 'In room' state stub
unc0rr
parents: 896
diff changeset
   124
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   125
handleCmd_inRoom client _ rooms ("CONFIG_PARAM" : paramName : paramStrs) =
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
   126
	if isMaster client then
1322
c624b04699fb Fix protocol implementation to conform documentation
unc0rr
parents: 1321
diff changeset
   127
		(noChangeClients, modifyRoom clRoom{params = Map.insert paramName paramStrs (params clRoom)}, answerConfigParam paramName paramStrs)
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
   128
	else
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
   129
		(noChangeClients, noChangeRooms, answerNotMaster)
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   130
	where
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   131
		clRoom = roomByName (room client) rooms
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   132
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   133
handleCmd_inRoom client _ rooms ("ADD_TEAM" : name : color : grave : fort : difStr : hhsInfo)
1323
d166f9069c2b Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents: 1322
diff changeset
   134
	| length hhsInfo == 16 =
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   135
	if length (teams clRoom) == 6 || canAddNumber <= 0 then
1323
d166f9069c2b Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents: 1322
diff changeset
   136
		(noChangeClients, noChangeRooms, answerCantAdd)
d166f9069c2b Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents: 1322
diff changeset
   137
	else
1325
c8994d47f41d Adding teams now works
unc0rr
parents: 1323
diff changeset
   138
		(noChangeClients, modifyRoom clRoom{teams = newTeam : teams clRoom}, answerTeamAccepted newTeam ++ answerAddTeam newTeam)
1323
d166f9069c2b Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents: 1322
diff changeset
   139
	where
d166f9069c2b Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents: 1322
diff changeset
   140
		clRoom = roomByName (room client) rooms
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   141
		newTeam = (TeamInfo name color grave fort difficulty newTeamHHNum (hhsList hhsInfo))
1323
d166f9069c2b Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents: 1322
diff changeset
   142
		difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int)
1325
c8994d47f41d Adding teams now works
unc0rr
parents: 1323
diff changeset
   143
		hhsList [] = []
1323
d166f9069c2b Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents: 1322
diff changeset
   144
		hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   145
		canAddNumber = 18 - (sum . map hhnum $ teams clRoom)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   146
		newTeamHHNum = min 4 canAddNumber
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   147
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   148
handleCmd_inRoom client _ rooms ["HH_NUM", teamName, numberStr] =
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   149
	if not $ isMaster client then
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   150
		(noChangeClients, noChangeRooms, answerNotMaster)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   151
	else
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   152
		if hhNumber < 1 || hhNumber > 8 || hhNumber > canAddNumber|| noSuchTeam then
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   153
			(noChangeClients, noChangeRooms, answerBadParam)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   154
		else
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   155
			(noChangeClients, modifyRoom $ modifyTeam clRoom team{hhnum = hhNumber}, answerHHNum teamName hhNumber)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   156
	where
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   157
		hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   158
		noSuchTeam = isNothing findTeam
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   159
		team = fromJust findTeam
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   160
		findTeam = find (\t -> teamName == teamname t) $ teams clRoom
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   161
		clRoom = roomByName (room client) rooms
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   162
		canAddNumber = 18 - (sum . map hhnum $ teams clRoom)
1323
d166f9069c2b Build neccessary structures in memory on ADDTEAM message, but don't send answer yet (need to review team id concept)
unc0rr
parents: 1322
diff changeset
   163
1083
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
   164
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   165
handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)