netserver/HWProto.hs
author unc0rr
Fri, 07 Nov 2008 15:58:36 +0000
changeset 1478 8bfb417d165e
parent 1473 60e1fad78d58
child 1483 89e24edb6020
permissions -rw-r--r--
Add simple DoS protection
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1473
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1470
diff changeset
     1
module HWProto
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1470
diff changeset
     2
(
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1470
diff changeset
     3
	handleCmd
60e1fad78d58 Cleanup code a bit, some reformatting
unc0rr
parents: 1470
diff changeset
     4
) where
890
1d8c4a5ec622 - Improve server core
unc0rr
parents:
diff changeset
     5
1d8c4a5ec622 - Improve server core
unc0rr
parents:
diff changeset
     6
import IO
896
93df8ac94382 Handle password parameter on JOIN
unc0rr
parents: 895
diff changeset
     7
import Data.List
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
     8
import Data.Word
890
1d8c4a5ec622 - Improve server core
unc0rr
parents:
diff changeset
     9
import Miscutils
1320
bffc7262e25e Optimize list lookups a bit
unc0rr
parents: 1317
diff changeset
    10
import Maybe
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    11
import qualified Data.Map as Map
1384
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
    12
import Opts
890
1d8c4a5ec622 - Improve server core
unc0rr
parents:
diff changeset
    13
1331
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    14
teamToNet team = ["ADD_TEAM", teamname team, teamgrave team, teamfort team, show $ difficulty team] ++ hhsInfo
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    15
	where
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    16
		hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    17
1452
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
    18
answerServerMessage clients = [(clientOnly, "SERVER_MESSAGE" : [mainbody ++ clientsIn])]
1384
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
    19
	where
1452
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
    20
		mainbody = serverMessage globalOptions ++ if isDedicated globalOptions then "<p align=center>Dedicated server</p>" else "<p align=center>Private server</p>"
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
    21
		clientsIn = "<p align=left>" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "</p>"
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
    22
		clientslist = if not $ null nicks then foldr1 (\a b -> a  ++ ", " ++ b) nicks else ""
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
    23
		nicks = filter (not . null) $ map nick clients
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
    24
		
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    25
answerBadCmd = [(clientOnly, ["ERROR", "Bad command, state or incorrect parameter"])]
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    26
answerNotMaster = [(clientOnly, ["ERROR", "You cannot configure room parameters"])]
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
    27
answerBadParam = [(clientOnly, ["ERROR", "Bad parameter"])]
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1473
diff changeset
    28
answerQuit msg = [(clientOnly, ["BYE", msg])]
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1473
diff changeset
    29
answerAbandoned = [(othersInRoom, ["BYE", "Room abandoned"])]
1309
1a38a967bd48 Fix a bug with 'ghosts' on server
unc0rr
parents: 1308
diff changeset
    30
answerQuitInform nick = [(othersInRoom, ["LEFT", nick])]
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    31
answerNickChosen = [(clientOnly, ["ERROR", "The nick already chosen"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    32
answerNickChooseAnother = [(clientOnly, ["WARNING", "Choose another nick"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    33
answerNick nick = [(clientOnly, ["NICK", nick])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    34
answerProtocolKnown = [(clientOnly, ["ERROR", "Protocol number already known"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    35
answerBadInput = [(clientOnly, ["ERROR", "Bad input"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    36
answerProto protoNum = [(clientOnly, ["PROTO", show protoNum])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    37
answerRoomsList list = [(clientOnly, ["ROOMS"] ++ list)]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    38
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
    39
answerJoined nick = [(sameRoom, ["JOINED", nick])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    40
answerNoRoom = [(clientOnly, ["WARNING", "There's no room with that name"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    41
answerWrongPassword = [(clientOnly, ["WARNING", "Wrong password"])]
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
    42
answerChatString nick msg = [(othersInRoom, ["CHAT_STRING", nick, msg])]
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    43
answerConfigParam paramName paramStrs = [(othersInRoom, "CONFIG_PARAM" : paramName : paramStrs)]
1333
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
    44
answerFullConfig room = map toAnswer (Map.toList $ params room) ++ [(clientOnly, ["MAP", gamemap room])]
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    45
	where
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
    46
		toAnswer (paramName, paramStrs) =
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    47
			(clientOnly, "CONFIG_PARAM" : paramName : paramStrs)
1470
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
    48
answerCantAdd reason = [(clientOnly, ["WARNING", "Cannot add team: " ++ reason])]
1325
c8994d47f41d Adding teams now works
unc0rr
parents: 1323
diff changeset
    49
answerTeamAccepted team = [(clientOnly, ["TEAM_ACCEPTED", teamname team])]
1331
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    50
answerAddTeam team = [(othersInRoom, teamToNet team)]
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
    51
answerHHNum teamName hhNumber = [(othersInRoom, ["HH_NUM", teamName, show hhNumber])]
1328
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
    52
answerRemoveTeam teamName = [(othersInRoom, ["REMOVE_TEAM", teamName])]
1329
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
    53
answerNotOwner = [(clientOnly, ["ERROR", "You do not own this team"])]
1330
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
    54
answerTeamColor teamName newColor = [(othersInRoom, ["TEAM_COLOR", teamName, newColor])]
1331
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    55
answerAllTeams room = concatMap toAnswer (teams room)
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    56
	where
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    57
		toAnswer team =
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    58
			[(clientOnly, teamToNet team),
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    59
			(clientOnly, ["TEAM_COLOR", teamname team, teamcolor team]),
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    60
			(clientOnly, ["HH_NUM", teamname team, show $ hhnum team])]
1333
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
    61
answerMap mapName = [(othersInRoom, ["MAP", mapName])]
1338
758c39a3dcfe Stub to run network game
unc0rr
parents: 1336
diff changeset
    62
answerRunGame = [(sameRoom, ["RUN_GAME"])]
1384
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
    63
answerCannotCreateRoom = [(clientOnly, ["WARNING", "Cannot create more rooms"])]
1406
08b9c28419f1 Send readiness information on join
unc0rr
parents: 1404
diff changeset
    64
answerIsReady nick = [(sameRoom, ["READY", nick])]
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
    65
answerNotReady nick = [(sameRoom, ["NOT_READY", nick])]
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
    66
answerTooFewClans = [(clientOnly, ["ERROR", "Too few clans in game"])]
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
    67
answerRestricted = [(clientOnly, ["WARNING", "Room joining restricted"])]
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1452
diff changeset
    68
answerPing = [(allClients, ["PING"])]
1469
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1462
diff changeset
    69
answerConnected = [(clientOnly, ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"])]
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
    70
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    71
-- Main state-independent cmd handler
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    72
handleCmd :: CmdHandler
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1473
diff changeset
    73
handleCmd client _ rooms ("QUIT" : xs) =
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    74
	if null (room client) then
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1473
diff changeset
    75
		(noChangeClients, noChangeRooms, answerQuit msg)
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    76
	else if isMaster client then
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1473
diff changeset
    77
		(noChangeClients, removeRoom (room client), (answerQuit msg) ++ answerAbandoned) -- core disconnects clients on ROOMABANDONED answer
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    78
	else
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1473
diff changeset
    79
		(noChangeClients, modifyRoom clRoom{teams = othersTeams, playersIn = (playersIn clRoom) - 1, readyPlayers = newReadyPlayers}, (answerQuit msg) ++ (answerQuitInform $ nick client) ++ answerRemoveClientTeams)
1334
b58afaadf7ae Send team removal message to others in room when client disconnects
unc0rr
parents: 1333
diff changeset
    80
	where
b58afaadf7ae Send team removal message to others in room when client disconnects
unc0rr
parents: 1333
diff changeset
    81
		clRoom = roomByName (room client) rooms
1335
c795cbc752c1 Small optimization (use partition instead of two filters with opposite predicates)
unc0rr
parents: 1334
diff changeset
    82
		answerRemoveClientTeams = map (\tn -> (othersInRoom, ["REMOVE_TEAM", teamname tn])) clientTeams
c795cbc752c1 Small optimization (use partition instead of two filters with opposite predicates)
unc0rr
parents: 1334
diff changeset
    83
		(clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
    84
		newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1473
diff changeset
    85
		msg = if not $ null xs then head xs else ""
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
    86
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1452
diff changeset
    87
handleCmd _ _ _ ["PING"] = -- core requsted
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1452
diff changeset
    88
	(noChangeClients, noChangeRooms, answerPing)
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
    89
1469
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1462
diff changeset
    90
handleCmd _ _ _ ["ASKME"] = -- core requsted
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1462
diff changeset
    91
	(noChangeClients, noChangeRooms, answerConnected)
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1462
diff changeset
    92
1462
d3323637da1f Client sends PONG to server's PING
unc0rr
parents: 1461
diff changeset
    93
handleCmd _ _ _ ["PONG"] =
d3323637da1f Client sends PONG to server's PING
unc0rr
parents: 1461
diff changeset
    94
	(noChangeClients, noChangeRooms, [])
d3323637da1f Client sends PONG to server's PING
unc0rr
parents: 1461
diff changeset
    95
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    96
-- check state and call state-dependent commmand handlers
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    97
handleCmd client clients rooms cmd =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    98
	if null (nick client) || protocol client == 0 then
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
    99
		handleCmd_noInfo client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   100
	else if null (room client) then
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   101
		handleCmd_noRoom client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   102
	else
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   103
		handleCmd_inRoom client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   104
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
   105
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   106
-- 'no info' state - need to get protocol number and nickname
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   107
handleCmd_noInfo :: CmdHandler
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   108
handleCmd_noInfo client clients _ ["NICK", newNick] =
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   109
	if not . null $ nick client then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   110
		(noChangeClients, noChangeRooms, answerNickChosen)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   111
	else if haveSameNick then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   112
		(noChangeClients, noChangeRooms, answerNickChooseAnother)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   113
	else
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   114
		(modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   115
	where
1320
bffc7262e25e Optimize list lookups a bit
unc0rr
parents: 1317
diff changeset
   116
		haveSameNick = isJust $ find (\cl -> newNick == nick cl) clients
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   117
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   118
handleCmd_noInfo client _ _ ["PROTO", protoNum] =
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   119
	if protocol client > 0 then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   120
		(noChangeClients, noChangeRooms, answerProtocolKnown)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   121
	else if parsedProto == 0 then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   122
		(noChangeClients, noChangeRooms, answerBadInput)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   123
	else
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   124
		(modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   125
	where
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   126
		parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   127
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   128
handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   129
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
   130
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   131
-- 'noRoom' clients state command handlers
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   132
handleCmd_noRoom :: CmdHandler
1452
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
   133
handleCmd_noRoom client clients rooms ["LIST"] =
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
   134
		(noChangeClients, noChangeRooms, answerServerMessage clients ++ (answerRoomsList $ concatMap roomInfo $ sameProtoRooms))
1396
abb28dcb6d0d - Send additional info on rooms
unc0rr
parents: 1391
diff changeset
   135
		where
1402
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1401
diff changeset
   136
			roomInfo room = [
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1401
diff changeset
   137
					name room,
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1401
diff changeset
   138
					(show $ playersIn room) ++ "(" ++ (show $ length $ teams room) ++ ")",
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1401
diff changeset
   139
					show $ gameinprogress room
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1401
diff changeset
   140
					]
1412
20746999bc4a Don't list rooms with restricted joining
unc0rr
parents: 1411
diff changeset
   141
			sameProtoRooms = filter (\r -> (roomProto r == protocol client) && (not $ isRestrictedJoins r)) rooms
903
d4e5d8cbe449 Implement LIST command
unc0rr
parents: 902
diff changeset
   142
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   143
handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] =
1384
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
   144
	if (not $ isDedicated globalOptions) && (not $ null rooms) then
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
   145
		(noChangeClients, noChangeRooms, answerCannotCreateRoom)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   146
	else
1384
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
   147
		if haveSameRoom then
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
   148
			(noChangeClients, noChangeRooms, answerRoomExists)
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
   149
		else
1407
b44fbb630fb6 Send readiness info to room creator too
unc0rr
parents: 1406
diff changeset
   150
			(modifyClient client{room = newRoom, isMaster = True}, addRoom createRoom{name = newRoom, password = roomPassword, roomProto = (protocol client)}, (answerJoined $ nick client) ++ (answerNotReady $ nick client))
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   151
	where
1320
bffc7262e25e Optimize list lookups a bit
unc0rr
parents: 1317
diff changeset
   152
		haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   153
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   154
handleCmd_noRoom client clients rooms ["CREATE", newRoom] =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   155
	handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""]
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   156
	
1308
d5dcd6cfa5e2 Fix another server failure (when second client in room disconnects)
unc0rr
parents: 1307
diff changeset
   157
handleCmd_noRoom client clients rooms ["JOIN", roomName, roomPassword] =
902
3cc10f0aae37 Finish conversion
unc0rr
parents: 901
diff changeset
   158
	if noSuchRoom then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   159
		(noChangeClients, noChangeRooms, answerNoRoom)
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   160
	else if roomPassword /= password clRoom then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   161
		(noChangeClients, noChangeRooms, answerWrongPassword)
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   162
	else if isRestrictedJoins clRoom then
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   163
		(noChangeClients, noChangeRooms, answerRestricted)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   164
	else
1406
08b9c28419f1 Send readiness information on join
unc0rr
parents: 1404
diff changeset
   165
		(modifyClient client{room = roomName}, modifyRoom clRoom{playersIn = 1 + playersIn clRoom}, answerNicks ++ answerReady ++ (answerJoined $ nick client) ++ (answerNotReady $ nick client) ++ answerFullConfig clRoom ++ answerAllTeams clRoom)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   166
	where
1401
2087672a2114 Improve handling client's protocol number
unc0rr
parents: 1396
diff changeset
   167
		noSuchRoom = isNothing $ find (\room -> roomName == name room && roomProto room == protocol client) rooms
1406
08b9c28419f1 Send readiness information on join
unc0rr
parents: 1404
diff changeset
   168
		answerNicks = [(clientOnly, ["JOINED"] ++ (map nick $ sameRoomClients))]
08b9c28419f1 Send readiness information on join
unc0rr
parents: 1404
diff changeset
   169
		answerReady = map (\c -> (clientOnly, [if isReady c then "READY" else "NOT_READY", nick c])) sameRoomClients
08b9c28419f1 Send readiness information on join
unc0rr
parents: 1404
diff changeset
   170
		sameRoomClients = filter (\ci -> room ci == roomName) clients
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   171
		clRoom = roomByName roomName rooms
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   172
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   173
handleCmd_noRoom client clients rooms ["JOIN", roomName] =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   174
	handleCmd_noRoom client clients rooms ["JOIN", roomName, ""]
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   175
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   176
handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   177
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
   178
897
35d91fa3753b 'In room' state stub
unc0rr
parents: 896
diff changeset
   179
-- 'inRoom' clients state command handlers
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   180
handleCmd_inRoom :: CmdHandler
1322
c624b04699fb Fix protocol implementation to conform documentation
unc0rr
parents: 1321
diff changeset
   181
handleCmd_inRoom client _ _ ["CHAT_STRING", msg] =
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
   182
	(noChangeClients, noChangeRooms, answerChatString (nick client) msg)
897
35d91fa3753b 'In room' state stub
unc0rr
parents: 896
diff changeset
   183
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   184
handleCmd_inRoom client _ rooms ("CONFIG_PARAM" : paramName : paramStrs) =
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
   185
	if isMaster client then
1322
c624b04699fb Fix protocol implementation to conform documentation
unc0rr
parents: 1321
diff changeset
   186
		(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
   187
	else
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
   188
		(noChangeClients, noChangeRooms, answerNotMaster)
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   189
	where
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   190
		clRoom = roomByName (room client) rooms
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   191
1333
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   192
handleCmd_inRoom client _ rooms ["MAP", mapName] =
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   193
	if isMaster client then
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   194
		(noChangeClients, modifyRoom clRoom{gamemap = mapName}, answerMap mapName)
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   195
	else
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   196
		(noChangeClients, noChangeRooms, answerNotMaster)
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   197
	where
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   198
		clRoom = roomByName (room client) rooms
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   199
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   200
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
   201
	| length hhsInfo == 16 =
1470
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   202
	if length (teams clRoom) == 6 then
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   203
		(noChangeClients, noChangeRooms, answerCantAdd "too many teams")
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   204
	else if canAddNumber <= 0 then
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   205
		(noChangeClients, noChangeRooms, answerCantAdd "too many hedgehogs")
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   206
	else if isJust findTeam then
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   207
		(noChangeClients, noChangeRooms, answerCantAdd "already has a team with same name")
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   208
	else if gameinprogress clRoom then
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   209
		(noChangeClients, noChangeRooms, answerCantAdd "round in progress")
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   210
	else if isRestrictedTeams clRoom then
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   211
		(noChangeClients, noChangeRooms, answerCantAdd "restricted")
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
   212
	else
1336
4e88eccbe7f6 Fix team colors mismatch on some conditions (just synchronize them when team is added)
unc0rr
parents: 1335
diff changeset
   213
		(noChangeClients, modifyRoom clRoom{teams = teams clRoom ++ [newTeam]}, answerTeamAccepted newTeam ++ answerAddTeam newTeam ++ answerTeamColor name color)
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
   214
	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
   215
		clRoom = roomByName (room client) rooms
1329
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
   216
		newTeam = (TeamInfo (nick client) name color grave fort difficulty newTeamHHNum (hhsList hhsInfo))
1328
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   217
		findTeam = find (\t -> name == teamname t) $ 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
   218
		difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int)
1325
c8994d47f41d Adding teams now works
unc0rr
parents: 1323
diff changeset
   219
		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
   220
		hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   221
		canAddNumber = 18 - (sum . map hhnum $ teams clRoom)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   222
		newTeamHHNum = min 4 canAddNumber
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   223
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   224
handleCmd_inRoom client _ rooms ["HH_NUM", teamName, numberStr] =
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   225
	if not $ isMaster client then
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   226
		(noChangeClients, noChangeRooms, answerNotMaster)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   227
	else
1329
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
   228
		if hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) then
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   229
			(noChangeClients, noChangeRooms, answerBadParam)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   230
		else
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   231
			(noChangeClients, modifyRoom $ modifyTeam clRoom team{hhnum = hhNumber}, answerHHNum teamName hhNumber)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   232
	where
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   233
		hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   234
		noSuchTeam = isNothing findTeam
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   235
		team = fromJust findTeam
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   236
		findTeam = find (\t -> teamName == teamname t) $ teams clRoom
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   237
		clRoom = roomByName (room client) rooms
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   238
		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
   239
1330
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   240
handleCmd_inRoom client _ rooms ["TEAM_COLOR", teamName, newColor] =
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   241
	if not $ isMaster client then
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   242
		(noChangeClients, noChangeRooms, answerNotMaster)
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   243
	else
1442
ef9785d0b392 Fix a bug (check parameters)
unc0rr
parents: 1412
diff changeset
   244
		if noSuchTeam then
ef9785d0b392 Fix a bug (check parameters)
unc0rr
parents: 1412
diff changeset
   245
			(noChangeClients, noChangeRooms, answerBadParam)
ef9785d0b392 Fix a bug (check parameters)
unc0rr
parents: 1412
diff changeset
   246
		else
ef9785d0b392 Fix a bug (check parameters)
unc0rr
parents: 1412
diff changeset
   247
			(noChangeClients, modifyRoom $ modifyTeam clRoom team{teamcolor = newColor}, answerTeamColor teamName newColor)
1330
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   248
	where
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   249
		noSuchTeam = isNothing findTeam
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   250
		team = fromJust findTeam
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   251
		findTeam = find (\t -> teamName == teamname t) $ teams clRoom
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   252
		clRoom = roomByName (room client) rooms
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   253
1328
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   254
handleCmd_inRoom client _ rooms ["REMOVE_TEAM", teamName] =
1329
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
   255
	if noSuchTeam then
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
   256
		(noChangeClients, noChangeRooms, answerBadParam)
1328
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   257
	else
1329
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
   258
		if not $ nick client == teamowner team then
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
   259
			(noChangeClients, noChangeRooms, answerNotOwner)
1328
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   260
		else
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   261
			(noChangeClients, modifyRoom clRoom{teams = filter (\t -> teamName /= teamname t) $ teams clRoom}, answerRemoveTeam teamName)
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   262
	where
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   263
		noSuchTeam = isNothing findTeam
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   264
		team = fromJust findTeam
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   265
		findTeam = find (\t -> teamName == teamname t) $ teams clRoom
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   266
		clRoom = roomByName (room client) rooms
1083
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
   267
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
   268
handleCmd_inRoom client _ rooms ["TOGGLE_READY"] =
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
   269
	if isReady client then
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   270
		(modifyClient client{isReady = False}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerNotReady $ nick client)
1338
758c39a3dcfe Stub to run network game
unc0rr
parents: 1336
diff changeset
   271
	else
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   272
		(modifyClient client{isReady = True}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerIsReady $ nick client)
1350
99a921e292f4 - Reverse the order of client list
unc0rr
parents: 1345
diff changeset
   273
	where
99a921e292f4 - Reverse the order of client list
unc0rr
parents: 1345
diff changeset
   274
		clRoom = roomByName (room client) rooms
1404
2b6b6809c2e4 - Fix a bug in READY message handling
unc0rr
parents: 1403
diff changeset
   275
		newReadyPlayers = (readyPlayers clRoom) + if isReady client then -1 else 1
1338
758c39a3dcfe Stub to run network game
unc0rr
parents: 1336
diff changeset
   276
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   277
handleCmd_inRoom client _ rooms ["START_GAME"] =
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   278
	if isMaster client && (playersIn clRoom == readyPlayers clRoom) && (not $ gameinprogress clRoom) then
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   279
		if enoughClans then
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   280
			(noChangeClients, modifyRoom clRoom{gameinprogress = True}, answerRunGame)
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   281
		else
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   282
			(noChangeClients, noChangeRooms, answerTooFewClans)
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   283
	else
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   284
		(noChangeClients, noChangeRooms, [])
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   285
	where
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   286
		clRoom = roomByName (room client) rooms
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   287
		enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams clRoom
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   288
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   289
handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_JOINS"] =
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   290
	if isMaster client then
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   291
		(noChangeClients, modifyRoom clRoom{isRestrictedJoins = newStatus}, [])
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   292
	else
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   293
		(noChangeClients, noChangeRooms, answerNotMaster)
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   294
	where
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   295
		clRoom = roomByName (room client) rooms
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   296
		newStatus = not $ isRestrictedJoins clRoom
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   297
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   298
handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_TEAMS"] =
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   299
	if isMaster client then
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   300
		(noChangeClients, modifyRoom clRoom{isRestrictedTeams = newStatus}, [])
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   301
	else
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   302
		(noChangeClients, noChangeRooms, answerNotMaster)
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   303
	where
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   304
		clRoom = roomByName (room client) rooms
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   305
		newStatus = not $ isRestrictedTeams clRoom
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   306
1408
fab171a17968 Unset ready status after round
unc0rr
parents: 1407
diff changeset
   307
handleCmd_inRoom client clients rooms ["ROUNDFINISHED"] =
1345
73119de7d3be Server erases teams list after round finish, so everything should be okay now
unc0rr
parents: 1344
diff changeset
   308
	if isMaster client then
1408
fab171a17968 Unset ready status after round
unc0rr
parents: 1407
diff changeset
   309
		(modifyRoomClients clRoom (\cl -> cl{isReady = False}), modifyRoom clRoom{gameinprogress = False, readyPlayers = 0}, answerAllNotReady)
1345
73119de7d3be Server erases teams list after round finish, so everything should be okay now
unc0rr
parents: 1344
diff changeset
   310
	else
1344
4004e597f1bf Clients send roundfinished message to server when the round is over
unc0rr
parents: 1338
diff changeset
   311
		(noChangeClients, noChangeRooms, [])
1345
73119de7d3be Server erases teams list after round finish, so everything should be okay now
unc0rr
parents: 1344
diff changeset
   312
	where
73119de7d3be Server erases teams list after round finish, so everything should be okay now
unc0rr
parents: 1344
diff changeset
   313
		clRoom = roomByName (room client) rooms
1408
fab171a17968 Unset ready status after round
unc0rr
parents: 1407
diff changeset
   314
		sameRoomClients = filter (\ci -> room ci == name clRoom) clients
fab171a17968 Unset ready status after round
unc0rr
parents: 1407
diff changeset
   315
		answerAllNotReady = map (\cl -> (sameRoom, ["NOT_READY", nick cl])) sameRoomClients
1344
4004e597f1bf Clients send roundfinished message to server when the round is over
unc0rr
parents: 1338
diff changeset
   316
1338
758c39a3dcfe Stub to run network game
unc0rr
parents: 1336
diff changeset
   317
handleCmd_inRoom client _ _ ["GAMEMSG", msg] =
758c39a3dcfe Stub to run network game
unc0rr
parents: 1336
diff changeset
   318
	(noChangeClients, noChangeRooms, [(othersInRoom, ["GAMEMSG", msg])])
758c39a3dcfe Stub to run network game
unc0rr
parents: 1336
diff changeset
   319
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   320
handleCmd_inRoom client clients rooms ["KICK", kickNick] =
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   321
	if isMaster client then
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   322
		if noSuchClient || (kickClient == client) then
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   323
			(noChangeClients, noChangeRooms, [])
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   324
		else
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   325
			(modifyClient kickClient{forceQuit = True}, noChangeRooms, [])
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   326
	else
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   327
		(noChangeClients, noChangeRooms, [])
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   328
	where
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   329
		clRoom = roomByName (room client) rooms
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   330
		noSuchClient = isNothing findClient
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   331
		kickClient = fromJust findClient
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   332
		findClient = find (\t -> ((room t) == (room client)) && ((nick t) == kickNick)) $ clients
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   333
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   334
handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)