netserver/HWProto.hs
author unc0rr
Sun, 12 Apr 2009 12:50:43 +0000
changeset 1964 dc9ea05c9d2f
parent 1784 dfe9bafb4590
permissions -rw-r--r--
- Another way of defining official server - Rope has walking bug fixed, and works similar for the last rope too
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
1751
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
     9
import Data.Sequence(Seq, (|>), (><), fromList, empty)
1646
19b3784ac9d2 Optimize net server perfomance by substituting List by Data.Sequence for storing spectators data
unc0rr
parents: 1632
diff changeset
    10
import Data.Foldable(toList)
890
1d8c4a5ec622 - Improve server core
unc0rr
parents:
diff changeset
    11
import Miscutils
1320
bffc7262e25e Optimize list lookups a bit
unc0rr
parents: 1317
diff changeset
    12
import Maybe
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
    13
import qualified Data.Map as Map
1384
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
    14
import Opts
890
1d8c4a5ec622 - Improve server core
unc0rr
parents:
diff changeset
    15
1662
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
    16
teamToNet protocol team =
1673
06bff12f8a74 - Correctly use plural form in translations
unc0rr
parents: 1662
diff changeset
    17
	if protocol <= 21 then
1662
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
    18
		["ADD_TEAM", teamname team, teamgrave team, teamfort team, show $ difficulty team] ++ hhsInfo
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
    19
	else
1681
42a7b01943b3 Add Robot voicepack
unc0rr
parents: 1676
diff changeset
    20
		["ADD_TEAM", teamname team, teamgrave team, teamfort team, teamvoicepack team, teamowner team, show $ difficulty team] ++ hhsInfo
1331
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    21
	where
ae291cfd617a Send teams info to newly connected client (has a bug with team sequence, need to discover)
unc0rr
parents: 1330
diff changeset
    22
		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
    23
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    24
makeAnswer :: HandlesSelector -> [String] -> [Answer]
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    25
makeAnswer func msg = [\_ -> (func, msg)]
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    26
answerClientOnly, answerOthersRoom, answerSameRoom :: [String] -> [Answer]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    27
answerClientOnly  = makeAnswer clientOnly
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    28
answerOthersRoom  = makeAnswer othersInRoom
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    29
answerSameRoom    = makeAnswer sameRoom
1591
1db9b654f880 Notify lobby when a room is created or deleted
unc0rr
parents: 1584
diff changeset
    30
answerSameProtoLobby = makeAnswer sameProtoLobbyClients
1618
2b9cadc232ab Fix server bugs:
unc0rr
parents: 1616
diff changeset
    31
answerOtherLobby  = makeAnswer otherLobbyClients
1567
95d7aab0df3f Fix lobby selector
unc0rr
parents: 1566
diff changeset
    32
answerAll         = makeAnswer allClients
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    33
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    34
answerBadCmd            = answerClientOnly ["ERROR", "Bad command, state or incorrect parameter"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    35
answerNotMaster         = answerClientOnly ["ERROR", "You cannot configure room parameters"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    36
answerBadParam          = answerClientOnly ["ERROR", "Bad parameter"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    37
answerErrorMsg msg      = answerClientOnly ["ERROR", msg]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    38
answerQuit msg          = answerClientOnly ["BYE", msg]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    39
answerNickChosen        = answerClientOnly ["ERROR", "The nick already chosen"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    40
answerNickChooseAnother = answerClientOnly ["WARNING", "Choose another nick"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    41
answerNick nick         = answerClientOnly ["NICK", nick]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    42
answerProtocolKnown     = answerClientOnly ["ERROR", "Protocol number already known"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    43
answerBadInput          = answerClientOnly ["ERROR", "Bad input"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    44
answerProto protoNum    = answerClientOnly ["PROTO", show protoNum]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    45
answerRoomsList list    = answerClientOnly $ "ROOMS" : list
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    46
answerRoomExists        = answerClientOnly ["WARNING", "There's already a room with that name"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    47
answerNoRoom            = answerClientOnly ["WARNING", "There's no room with that name"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    48
answerWrongPassword     = answerClientOnly ["WARNING", "Wrong password"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    49
answerCantAdd reason    = answerClientOnly ["WARNING", "Cannot add team: " ++ reason]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    50
answerTeamAccepted team = answerClientOnly ["TEAM_ACCEPTED", teamname team]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    51
answerTooFewClans       = answerClientOnly ["ERROR", "Too few clans in game"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    52
answerRestricted        = answerClientOnly ["WARNING", "Room joining restricted"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    53
answerConnected         = answerClientOnly ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    54
answerNotOwner          = answerClientOnly ["ERROR", "You do not own this team"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    55
answerCannotCreateRoom  = answerClientOnly ["WARNING", "Cannot create more rooms"]
1582
262245ba6ea6 Show client's room in info
unc0rr
parents: 1581
diff changeset
    56
answerInfo client       = answerClientOnly ["INFO", nick client, host client, proto2ver $ protocol client, roomInfo]
262245ba6ea6 Show client's room in info
unc0rr
parents: 1581
diff changeset
    57
	where
262245ba6ea6 Show client's room in info
unc0rr
parents: 1581
diff changeset
    58
	roomInfo = if not $ null $ room client then "room " ++ (room client) else "lobby"
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    59
1592
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
    60
answerAbandoned protocol  =
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
    61
	if protocol < 20 then
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
    62
		answerOthersRoom ["BYE", "Room abandoned"]
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
    63
	else
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
    64
		answerOthersRoom ["ROOMABANDONED"]
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
    65
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    66
answerChatString nick msg = answerOthersRoom ["CHAT_STRING", nick, msg]
1662
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
    67
answerAddTeam protocol team = answerOthersRoom $ teamToNet protocol team
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    68
answerRemoveTeam teamName = answerOthersRoom ["REMOVE_TEAM", teamName]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    69
answerMap mapName         = answerOthersRoom ["MAP", mapName]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    70
answerHHNum teamName hhNumber = answerOthersRoom ["HH_NUM", teamName, show hhNumber]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    71
answerTeamColor teamName newColor = answerOthersRoom ["TEAM_COLOR", teamName, newColor]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    72
answerConfigParam paramName paramStrs = answerOthersRoom $ "CONFIG_PARAM" : paramName : paramStrs
1512
43742041c211 - Don't send 'Bad param' msg, as the only reason of it is just some lag
unc0rr
parents: 1493
diff changeset
    73
answerQuitInform nick msg =
43742041c211 - Don't send 'Bad param' msg, as the only reason of it is just some lag
unc0rr
parents: 1493
diff changeset
    74
	if not $ null msg then
43742041c211 - Don't send 'Bad param' msg, as the only reason of it is just some lag
unc0rr
parents: 1493
diff changeset
    75
		answerOthersRoom ["LEFT", nick, msg]
43742041c211 - Don't send 'Bad param' msg, as the only reason of it is just some lag
unc0rr
parents: 1493
diff changeset
    76
		else
43742041c211 - Don't send 'Bad param' msg, as the only reason of it is just some lag
unc0rr
parents: 1493
diff changeset
    77
		answerOthersRoom ["LEFT", nick]
1592
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
    78
1598
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1596
diff changeset
    79
answerPartInform nick = answerOthersRoom ["LEFT", nick, "bye room"]
1566
6b63c75fdc68 Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents: 1561
diff changeset
    80
answerQuitLobby nick msg =
1581
2dfa315b4bb2 Don't send LEFT message for clients without nick
unc0rr
parents: 1578
diff changeset
    81
	if not $ null nick then
2dfa315b4bb2 Don't send LEFT message for clients without nick
unc0rr
parents: 1578
diff changeset
    82
		if not $ null msg then
2dfa315b4bb2 Don't send LEFT message for clients without nick
unc0rr
parents: 1578
diff changeset
    83
			answerAll ["LOBBY:LEFT", nick, msg]
1566
6b63c75fdc68 Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents: 1561
diff changeset
    84
		else
1581
2dfa315b4bb2 Don't send LEFT message for clients without nick
unc0rr
parents: 1578
diff changeset
    85
			answerAll ["LOBBY:LEFT", nick]
2dfa315b4bb2 Don't send LEFT message for clients without nick
unc0rr
parents: 1578
diff changeset
    86
	else
2dfa315b4bb2 Don't send LEFT message for clients without nick
unc0rr
parents: 1578
diff changeset
    87
		[]
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    88
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    89
answerJoined nick   = answerSameRoom ["JOINED", nick]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    90
answerRunGame       = answerSameRoom ["RUN_GAME"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    91
answerIsReady nick  = answerSameRoom ["READY", nick]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    92
answerNotReady nick = answerSameRoom ["NOT_READY", nick]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    93
1591
1db9b654f880 Notify lobby when a room is created or deleted
unc0rr
parents: 1584
diff changeset
    94
answerRoomAdded name    = answerSameProtoLobby ["ROOM", "ADD", name]
1db9b654f880 Notify lobby when a room is created or deleted
unc0rr
parents: 1584
diff changeset
    95
answerRoomDeleted name  = answerSameProtoLobby ["ROOM", "DEL", name]
1db9b654f880 Notify lobby when a room is created or deleted
unc0rr
parents: 1584
diff changeset
    96
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    97
answerFullConfig room = concatMap toAnswer (Map.toList $ params room) ++ (answerClientOnly ["MAP", gamemap room])
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    98
	where
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
    99
		toAnswer (paramName, paramStrs) =
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   100
			answerClientOnly $ "CONFIG_PARAM" : paramName : paramStrs
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   101
1748
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   102
answerAllTeams protocol teams = concatMap toAnswer teams
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   103
	where
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   104
		toAnswer team =
1662
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
   105
			(answerClientOnly $ teamToNet protocol team) ++
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   106
			(answerClientOnly ["TEAM_COLOR", teamname team, teamcolor team]) ++
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   107
			(answerClientOnly ["HH_NUM", teamname team, show $ hhnum team])
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   108
1569
4456a0dfc647 - Update some copyrights
unc0rr
parents: 1568
diff changeset
   109
answerServerMessage client clients = [\serverInfo -> (clientOnly, "SERVER_MESSAGE" :
1614
cf8704215703 - Fix trainings again
unc0rr
parents: 1609
diff changeset
   110
		[(mainbody serverInfo) ++ updateInfo ++ clientsIn ++ (lastHour serverInfo)])]
1384
329d3308e2e3 Support for private servers in frontend
unc0rr
parents: 1383
diff changeset
   111
	where
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   112
		mainbody serverInfo = serverMessage serverInfo ++
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   113
			if isDedicated serverInfo then
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   114
				"<p align=center>Dedicated server</p>"
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   115
				else
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   116
				"<p align=center>Private server</p>"
1614
cf8704215703 - Fix trainings again
unc0rr
parents: 1609
diff changeset
   117
				
1725
38a074db049c Message for 098 users about 099 release
unc0rr
parents: 1681
diff changeset
   118
		updateInfo = if protocol client < 23 then "<font color=yellow><h3>Hedgewars 0.9.9 is out!!! Please, update. Support for previous versions will be dropped soon</h3><p align=center><a href=http://hedgewars.org/download.html>Download page here</a></p><h4>New features are:</h4><ul><li>Voice packs</li><li>Precise aim</li><li>RC Plane weapon</li><li>...</li></ul></font>" else ""
1569
4456a0dfc647 - Update some copyrights
unc0rr
parents: 1568
diff changeset
   119
		clientsIn = if protocol client < 20 then "<p align=left>" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "</p>" else []
1452
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
   120
		clientslist = if not $ null nicks then foldr1 (\a b -> a  ++ ", " ++ b) nicks else ""
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   121
		lastHour serverInfo =
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   122
			if isDedicated serverInfo then
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   123
				"<p align=left>" ++ (show $ length $ lastHourUsers serverInfo) ++ " user logins in last hour</p>"
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   124
				else
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   125
				""
1452
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
   126
		nicks = filter (not . null) $ map nick clients
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   127
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   128
answerPing = makeAnswer allClients ["PING"]
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   129
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   130
-- Main state-independent cmd handler
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   131
handleCmd :: CmdHandler
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1473
diff changeset
   132
handleCmd client _ rooms ("QUIT" : xs) =
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   133
	if null (room client) then
1566
6b63c75fdc68 Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents: 1561
diff changeset
   134
		(noChangeClients, noChangeRooms, answerQuit msg ++ (answerQuitLobby (nick client) msg) )
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   135
	else if isMaster client then
1620
5f4cd6708eb5 Proper room removing when master quits
unc0rr
parents: 1619
diff changeset
   136
		(modifyRoomClients clRoom (\cl -> cl{isReady = False, partRoom = True}), removeRoom (room client), (answerQuit msg) ++ (answerQuitLobby (nick client) msg) ++ (answerAbandoned $ protocol client) ++ (answerRoomDeleted $ room client)) -- core disconnects clients on ROOMABANDONED answer
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   137
	else
1751
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   138
		if not $ gameinprogress clRoom then
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   139
			(noChangeClients,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   140
			modifyRoom clRoom{
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   141
				teams = othersTeams,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   142
				playersIn = (playersIn clRoom) - 1,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   143
				readyPlayers = newReadyPlayers
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   144
				},
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   145
			(answerQuit msg) ++
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   146
			(answerQuitInform (nick client) msg) ++
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   147
			(answerQuitLobby (nick client) msg) ++
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   148
			answerRemoveClientTeams)
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   149
		else
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   150
			(noChangeClients,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   151
			modifyRoom clRoom{
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   152
				teams = othersTeams,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   153
				leftTeams = (map teamname clientTeams) ++ (leftTeams clRoom),
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   154
				roundMsgs = (roundMsgs clRoom) >< (fromList rmTeamsMsgs),
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   155
				playersIn = (playersIn clRoom) - 1,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   156
				readyPlayers = newReadyPlayers
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   157
				},
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   158
			(answerQuit msg) ++
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   159
			(answerQuitInform (nick client) msg) ++
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   160
			(answerQuitLobby (nick client) msg) ++
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   161
			answerRemoveClientTeams ++
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   162
			answerEngineTeamsRemoveMsg)
1334
b58afaadf7ae Send team removal message to others in room when client disconnects
unc0rr
parents: 1333
diff changeset
   163
	where
b58afaadf7ae Send team removal message to others in room when client disconnects
unc0rr
parents: 1333
diff changeset
   164
		clRoom = roomByName (room client) rooms
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   165
		answerRemoveClientTeams = concatMap (\tn -> answerOthersRoom ["REMOVE_TEAM", teamname tn]) clientTeams
1335
c795cbc752c1 Small optimization (use partition instead of two filters with opposite predicates)
unc0rr
parents: 1334
diff changeset
   166
		(clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
   167
		newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1473
diff changeset
   168
		msg = if not $ null xs then head xs else ""
1751
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   169
		rmTeamsMsgs = map (\team -> toEngineMsg $ 'F' : teamname team) clientTeams
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   170
		answerEngineTeamsRemoveMsg =
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   171
			if not $ null rmTeamsMsgs then
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   172
				answerOthersRoom $ "GAMEMSG" : rmTeamsMsgs
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   173
			else
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   174
				[]
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   175
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1452
diff changeset
   176
handleCmd _ _ _ ["PING"] = -- core requsted
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1452
diff changeset
   177
	(noChangeClients, noChangeRooms, answerPing)
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
   178
1469
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1462
diff changeset
   179
handleCmd _ _ _ ["ASKME"] = -- core requsted
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1462
diff changeset
   180
	(noChangeClients, noChangeRooms, answerConnected)
5218aa76939e Handle exceptions on accept
unc0rr
parents: 1462
diff changeset
   181
1462
d3323637da1f Client sends PONG to server's PING
unc0rr
parents: 1461
diff changeset
   182
handleCmd _ _ _ ["PONG"] =
d3323637da1f Client sends PONG to server's PING
unc0rr
parents: 1461
diff changeset
   183
	(noChangeClients, noChangeRooms, [])
d3323637da1f Client sends PONG to server's PING
unc0rr
parents: 1461
diff changeset
   184
1483
89e24edb6020 Make code flow more clear
unc0rr
parents: 1478
diff changeset
   185
handleCmd _ _ _ ["ERROR", msg] =
89e24edb6020 Make code flow more clear
unc0rr
parents: 1478
diff changeset
   186
	(noChangeClients, noChangeRooms, answerErrorMsg msg)
89e24edb6020 Make code flow more clear
unc0rr
parents: 1478
diff changeset
   187
1577
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   188
handleCmd _ clients _ ["INFO", asknick] =
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   189
	if noSuchClient then
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   190
		(noChangeClients, noChangeRooms, [])
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   191
	else
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   192
		(noChangeClients, noChangeRooms, answerInfo client)
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   193
	where
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   194
		maybeClient = find (\cl -> asknick == nick cl) clients
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   195
		noSuchClient = isNothing maybeClient
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   196
		client = fromJust maybeClient
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   197
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1571
diff changeset
   198
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   199
-- check state and call state-dependent commmand handlers
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   200
handleCmd client clients rooms cmd =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   201
	if null (nick client) || protocol client == 0 then
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   202
		handleCmd_noInfo client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   203
	else if null (room client) then
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   204
		handleCmd_noRoom client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   205
	else
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   206
		handleCmd_inRoom client clients rooms cmd
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   207
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
   208
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   209
-- 'no info' state - need to get protocol number and nickname
1566
6b63c75fdc68 Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents: 1561
diff changeset
   210
onLoginFinished client clients =
1571
574063b456c0 Show joins of ppl with 097 too
unc0rr
parents: 1569
diff changeset
   211
	if (null $ nick client) || (protocol client == 0) then
1566
6b63c75fdc68 Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents: 1561
diff changeset
   212
		[]
6b63c75fdc68 Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents: 1561
diff changeset
   213
	else
1676
6f6f14a3e0ea Same for lobby
unc0rr
parents: 1675
diff changeset
   214
		answerLobbyNicks ++
1618
2b9cadc232ab Fix server bugs:
unc0rr
parents: 1616
diff changeset
   215
		(answerAll ["LOBBY:JOINED", nick client]) ++
1584
90f6a5abad17 Save much space for chat widget on lobby page by removing server message widget (now this messages goes to chat)
unc0rr
parents: 1582
diff changeset
   216
		(answerServerMessage client clients)
1676
6f6f14a3e0ea Same for lobby
unc0rr
parents: 1675
diff changeset
   217
	where
6f6f14a3e0ea Same for lobby
unc0rr
parents: 1675
diff changeset
   218
		lobbyNicks = filter (\n -> (not (null n)) && n /= nick client) $ map nick $ clients
6f6f14a3e0ea Same for lobby
unc0rr
parents: 1675
diff changeset
   219
		answerLobbyNicks = if not $ null lobbyNicks then
6f6f14a3e0ea Same for lobby
unc0rr
parents: 1675
diff changeset
   220
					answerClientOnly $ ["LOBBY:JOINED"] ++ lobbyNicks
6f6f14a3e0ea Same for lobby
unc0rr
parents: 1675
diff changeset
   221
				else
6f6f14a3e0ea Same for lobby
unc0rr
parents: 1675
diff changeset
   222
					[]
1566
6b63c75fdc68 Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents: 1561
diff changeset
   223
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   224
handleCmd_noInfo :: CmdHandler
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   225
handleCmd_noInfo client clients _ ["NICK", newNick] =
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   226
	if not . null $ nick client then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   227
		(noChangeClients, noChangeRooms, answerNickChosen)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   228
	else if haveSameNick then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   229
		(noChangeClients, noChangeRooms, answerNickChooseAnother)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   230
	else
1566
6b63c75fdc68 Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents: 1561
diff changeset
   231
		(modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick ++ (onLoginFinished client{nick = newNick} clients))
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   232
	where
1320
bffc7262e25e Optimize list lookups a bit
unc0rr
parents: 1317
diff changeset
   233
		haveSameNick = isJust $ find (\cl -> newNick == nick cl) clients
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   234
1566
6b63c75fdc68 Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents: 1561
diff changeset
   235
handleCmd_noInfo client clients _ ["PROTO", protoNum] =
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   236
	if protocol client > 0 then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   237
		(noChangeClients, noChangeRooms, answerProtocolKnown)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   238
	else if parsedProto == 0 then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   239
		(noChangeClients, noChangeRooms, answerBadInput)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   240
	else
1566
6b63c75fdc68 Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents: 1561
diff changeset
   241
		(modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto ++ (onLoginFinished client{protocol = parsedProto} clients))
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   242
	where
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   243
		parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   244
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   245
handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   246
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
   247
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   248
-- 'noRoom' clients state command handlers
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   249
handleCmd_noRoom :: CmdHandler
1452
8505cbfd9a21 Show clients list in server message
unc0rr
parents: 1442
diff changeset
   250
handleCmd_noRoom client clients rooms ["LIST"] =
1584
90f6a5abad17 Save much space for chat widget on lobby page by removing server message widget (now this messages goes to chat)
unc0rr
parents: 1582
diff changeset
   251
		(noChangeClients, noChangeRooms, (answerRoomsList $ concatMap roomInfo $ sameProtoRooms))
1396
abb28dcb6d0d - Send additional info on rooms
unc0rr
parents: 1391
diff changeset
   252
		where
1402
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1401
diff changeset
   253
			roomInfo room = [
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1401
diff changeset
   254
					name room,
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1401
diff changeset
   255
					(show $ playersIn room) ++ "(" ++ (show $ length $ teams room) ++ ")",
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1401
diff changeset
   256
					show $ gameinprogress room
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1401
diff changeset
   257
					]
1412
20746999bc4a Don't list rooms with restricted joining
unc0rr
parents: 1411
diff changeset
   258
			sameProtoRooms = filter (\r -> (roomProto r == protocol client) && (not $ isRestrictedJoins r)) rooms
903
d4e5d8cbe449 Implement LIST command
unc0rr
parents: 902
diff changeset
   259
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   260
handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] =
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   261
	if haveSameRoom then
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   262
		(noChangeClients, noChangeRooms, answerRoomExists)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   263
	else
1591
1db9b654f880 Notify lobby when a room is created or deleted
unc0rr
parents: 1584
diff changeset
   264
		(modifyClient client{room = newRoom, isMaster = True}, addRoom createRoom{name = newRoom, password = roomPassword, roomProto = (protocol client)}, (answerJoined $ nick client) ++ (answerNotReady $ nick client) ++ (answerRoomAdded newRoom))
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   265
	where
1320
bffc7262e25e Optimize list lookups a bit
unc0rr
parents: 1317
diff changeset
   266
		haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   267
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   268
handleCmd_noRoom client clients rooms ["CREATE", newRoom] =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   269
	handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""]
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   270
	
1308
d5dcd6cfa5e2 Fix another server failure (when second client in room disconnects)
unc0rr
parents: 1307
diff changeset
   271
handleCmd_noRoom client clients rooms ["JOIN", roomName, roomPassword] =
902
3cc10f0aae37 Finish conversion
unc0rr
parents: 901
diff changeset
   272
	if noSuchRoom then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   273
		(noChangeClients, noChangeRooms, answerNoRoom)
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   274
	else if roomPassword /= password clRoom then
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   275
		(noChangeClients, noChangeRooms, answerWrongPassword)
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   276
	else if isRestrictedJoins clRoom then
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   277
		(noChangeClients, noChangeRooms, answerRestricted)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   278
	else
1748
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   279
		(modifyClient client{room = roomName}, modifyRoom clRoom{playersIn = 1 + playersIn clRoom}, (answerJoined $ nick client) ++ answerNicks ++ answerReady ++ (answerNotReady $ nick client) ++ answerFullConfig clRoom ++ answerTeams ++ watchRound)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   280
	where
1401
2087672a2114 Improve handling client's protocol number
unc0rr
parents: 1396
diff changeset
   281
		noSuchRoom = isNothing $ find (\room -> roomName == name room && roomProto room == protocol client) rooms
1675
d5e131005516 Don't send empty JOINED message
unc0rr
parents: 1673
diff changeset
   282
		answerNicks = if not $ null sameRoomClients then
d5e131005516 Don't send empty JOINED message
unc0rr
parents: 1673
diff changeset
   283
					answerClientOnly $ ["JOINED"] ++ (map nick $ sameRoomClients)
d5e131005516 Don't send empty JOINED message
unc0rr
parents: 1673
diff changeset
   284
				else
d5e131005516 Don't send empty JOINED message
unc0rr
parents: 1673
diff changeset
   285
					[]
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   286
		answerReady = concatMap (\c -> answerClientOnly [if isReady c then "READY" else "NOT_READY", nick c]) sameRoomClients
1406
08b9c28419f1 Send readiness information on join
unc0rr
parents: 1404
diff changeset
   287
		sameRoomClients = filter (\ci -> room ci == roomName) clients
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   288
		clRoom = roomByName roomName rooms
1558
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1512
diff changeset
   289
		watchRound = if (roomProto clRoom < 20) || (not $ gameinprogress clRoom) then
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1512
diff changeset
   290
					[]
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1512
diff changeset
   291
				else
1560
e140bc57ff68 Quick replay round to spectators until current move
unc0rr
parents: 1559
diff changeset
   292
					(answerClientOnly  ["RUN_GAME"]) ++
1742
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1725
diff changeset
   293
					answerClientOnly ("GAMEMSG" : toEngineMsg "e$spectate 1" : (toList $ roundMsgs clRoom))
1748
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   294
		answerTeams = if gameinprogress clRoom then
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   295
				answerAllTeams (protocol client) (teamsAtStart clRoom)
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   296
			else
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   297
				answerAllTeams (protocol client) (teams clRoom)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   298
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   299
handleCmd_noRoom client clients rooms ["JOIN", roomName] =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   300
	handleCmd_noRoom client clients rooms ["JOIN", roomName, ""]
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
   301
1568
15a446307993 Lobby chat should work now
unc0rr
parents: 1567
diff changeset
   302
handleCmd_noRoom client _ _ ["CHAT_STRING", msg] =
15a446307993 Lobby chat should work now
unc0rr
parents: 1567
diff changeset
   303
	(noChangeClients, noChangeRooms, answerChatString (nick client) msg)
15a446307993 Lobby chat should work now
unc0rr
parents: 1567
diff changeset
   304
1757
3aa7d21baca1 Add an ability for global messages when server started with password option set
unc0rr
parents: 1751
diff changeset
   305
handleCmd_noRoom client _ _ ["GLOBALMSG", password, msg] =
3aa7d21baca1 Add an ability for global messages when server started with password option set
unc0rr
parents: 1751
diff changeset
   306
	(noChangeClients, noChangeRooms, [answer])
3aa7d21baca1 Add an ability for global messages when server started with password option set
unc0rr
parents: 1751
diff changeset
   307
	where
3aa7d21baca1 Add an ability for global messages when server started with password option set
unc0rr
parents: 1751
diff changeset
   308
		answer = \serverInfo ->
3aa7d21baca1 Add an ability for global messages when server started with password option set
unc0rr
parents: 1751
diff changeset
   309
			if (not $ null password) && (adminPassword serverInfo == password) then
3aa7d21baca1 Add an ability for global messages when server started with password option set
unc0rr
parents: 1751
diff changeset
   310
				(allClients, ["CHAT_STRING", nick client, msg])
3aa7d21baca1 Add an ability for global messages when server started with password option set
unc0rr
parents: 1751
diff changeset
   311
			else
3aa7d21baca1 Add an ability for global messages when server started with password option set
unc0rr
parents: 1751
diff changeset
   312
				(clientOnly, ["ERROR", "Wrong password"])
3aa7d21baca1 Add an ability for global messages when server started with password option set
unc0rr
parents: 1751
diff changeset
   313
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   314
handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
895
6aee2f335726 - Remove old hwserv code
unc0rr
parents: 894
diff changeset
   315
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1305
diff changeset
   316
897
35d91fa3753b 'In room' state stub
unc0rr
parents: 896
diff changeset
   317
-- 'inRoom' clients state command handlers
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 903
diff changeset
   318
handleCmd_inRoom :: CmdHandler
1322
c624b04699fb Fix protocol implementation to conform documentation
unc0rr
parents: 1321
diff changeset
   319
handleCmd_inRoom client _ _ ["CHAT_STRING", msg] =
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
   320
	(noChangeClients, noChangeRooms, answerChatString (nick client) msg)
897
35d91fa3753b 'In room' state stub
unc0rr
parents: 896
diff changeset
   321
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   322
handleCmd_inRoom client _ rooms ("CONFIG_PARAM" : paramName : paramStrs) =
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
   323
	if isMaster client then
1322
c624b04699fb Fix protocol implementation to conform documentation
unc0rr
parents: 1321
diff changeset
   324
		(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
   325
	else
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1309
diff changeset
   326
		(noChangeClients, noChangeRooms, answerNotMaster)
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   327
	where
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   328
		clRoom = roomByName (room client) rooms
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1320
diff changeset
   329
1592
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
   330
handleCmd_inRoom client _ rooms ["PART"] =
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
   331
	if isMaster client then
1618
2b9cadc232ab Fix server bugs:
unc0rr
parents: 1616
diff changeset
   332
		(modifyRoomClients clRoom (\cl -> cl{isReady = False, isMaster = False, partRoom = True}), removeRoom (room client), (answerAbandoned $ protocol client) ++ (answerRoomDeleted $ room client))
1592
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
   333
	else
1751
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   334
			if not $ gameinprogress clRoom then
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   335
				(modifyClient client{
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   336
					isReady = False,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   337
					partRoom = True
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   338
					},
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   339
				 modifyRoom clRoom{
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   340
				 	teams = othersTeams,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   341
				 	playersIn = (playersIn clRoom) - 1,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   342
				 	readyPlayers = newReadyPlayers
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   343
				 	},
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   344
				 (answerPartInform (nick client)) ++ answerRemoveClientTeams)
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   345
			else
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   346
				(modifyClient client{
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   347
					isReady = False,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   348
					partRoom = True
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   349
					},
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   350
				modifyRoom clRoom{
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   351
					teams = othersTeams,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   352
					leftTeams = (map teamname clientTeams) ++ (leftTeams clRoom),
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   353
					roundMsgs = (roundMsgs clRoom) >< (fromList rmTeamsMsgs),
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   354
				 	playersIn = (playersIn clRoom) - 1,
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   355
				 	readyPlayers = newReadyPlayers
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   356
					},
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   357
				answerEngineTeamsRemoveMsg ++
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   358
				(answerPartInform (nick client)) ++
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   359
				answerRemoveClientTeams)
1592
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
   360
	where
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
   361
		clRoom = roomByName (room client) rooms
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
   362
		answerRemoveClientTeams = concatMap (\tn -> answerOthersRoom ["REMOVE_TEAM", teamname tn]) clientTeams
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
   363
		(clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
   364
		newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom
1751
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   365
		rmTeamsMsgs = map (\team -> toEngineMsg $ 'F' : teamname team) clientTeams
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   366
		answerEngineTeamsRemoveMsg =
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   367
			if not $ null rmTeamsMsgs then
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   368
				answerOthersRoom $ "GAMEMSG" : rmTeamsMsgs
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   369
			else
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   370
				[]
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   371
1592
5ee77ee470a6 Start converting network protocol to no-disconnecting religion
unc0rr
parents: 1591
diff changeset
   372
1333
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   373
handleCmd_inRoom client _ rooms ["MAP", mapName] =
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   374
	if isMaster client then
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   375
		(noChangeClients, modifyRoom clRoom{gamemap = mapName}, answerMap mapName)
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   376
	else
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   377
		(noChangeClients, noChangeRooms, answerNotMaster)
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   378
	where
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   379
		clRoom = roomByName (room client) rooms
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1332
diff changeset
   380
1662
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
   381
handleCmd_inRoom client _ rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : 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
   382
	| length hhsInfo == 16 =
1470
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   383
	if length (teams clRoom) == 6 then
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   384
		(noChangeClients, noChangeRooms, answerCantAdd "too many teams")
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   385
	else if canAddNumber <= 0 then
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   386
		(noChangeClients, noChangeRooms, answerCantAdd "too many hedgehogs")
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   387
	else if isJust findTeam then
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   388
		(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
   389
	else if gameinprogress clRoom then
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   390
		(noChangeClients, noChangeRooms, answerCantAdd "round in progress")
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   391
	else if isRestrictedTeams clRoom then
ebaca3b66d92 Give more specific explanation when deny to add team
unc0rr
parents: 1469
diff changeset
   392
		(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
   393
	else
1662
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
   394
		(noChangeClients, modifyRoom clRoom{teams = teams clRoom ++ [newTeam]}, answerTeamAccepted newTeam ++ answerAddTeam (protocol client) 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
   395
	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
   396
		clRoom = roomByName (room client) rooms
1662
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
   397
		newTeam = (TeamInfo (nick client) name color grave fort voicepack difficulty newTeamHHNum (hhsList hhsInfo))
1328
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   398
		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
   399
		difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int)
1325
c8994d47f41d Adding teams now works
unc0rr
parents: 1323
diff changeset
   400
		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
   401
		hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
1784
dfe9bafb4590 Apply nemo's patch polished by me:
unc0rr
parents: 1757
diff changeset
   402
		canAddNumber = 48 - (sum . map hhnum $ teams clRoom)
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   403
		newTeamHHNum = min 4 canAddNumber
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   404
1662
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
   405
handleCmd_inRoom client clients rooms ("ADD_TEAM" : name : color : grave : fort : difStr : hhsInfo) =
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
   406
	handleCmd_inRoom client clients rooms ("ADD_TEAM" : name : color : grave : fort : "Default" : difStr : hhsInfo)
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
   407
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
   408
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   409
handleCmd_inRoom client _ rooms ["HH_NUM", teamName, numberStr] =
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   410
	if not $ isMaster client then
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   411
		(noChangeClients, noChangeRooms, answerNotMaster)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   412
	else
1329
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
   413
		if hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) then
1512
43742041c211 - Don't send 'Bad param' msg, as the only reason of it is just some lag
unc0rr
parents: 1493
diff changeset
   414
			(noChangeClients, noChangeRooms, [])
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   415
		else
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   416
			(noChangeClients, modifyRoom $ modifyTeam clRoom team{hhnum = hhNumber}, answerHHNum teamName hhNumber)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   417
	where
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   418
		hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   419
		noSuchTeam = isNothing findTeam
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   420
		team = fromJust findTeam
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   421
		findTeam = find (\t -> teamName == teamname t) $ teams clRoom
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1325
diff changeset
   422
		clRoom = roomByName (room client) rooms
1784
dfe9bafb4590 Apply nemo's patch polished by me:
unc0rr
parents: 1757
diff changeset
   423
		canAddNumber = 48 - (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
   424
1330
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   425
handleCmd_inRoom client _ rooms ["TEAM_COLOR", teamName, newColor] =
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   426
	if not $ isMaster client then
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   427
		(noChangeClients, noChangeRooms, answerNotMaster)
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   428
	else
1442
ef9785d0b392 Fix a bug (check parameters)
unc0rr
parents: 1412
diff changeset
   429
		if noSuchTeam then
1512
43742041c211 - Don't send 'Bad param' msg, as the only reason of it is just some lag
unc0rr
parents: 1493
diff changeset
   430
			(noChangeClients, noChangeRooms, [])
1442
ef9785d0b392 Fix a bug (check parameters)
unc0rr
parents: 1412
diff changeset
   431
		else
ef9785d0b392 Fix a bug (check parameters)
unc0rr
parents: 1412
diff changeset
   432
			(noChangeClients, modifyRoom $ modifyTeam clRoom team{teamcolor = newColor}, answerTeamColor teamName newColor)
1330
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   433
	where
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   434
		noSuchTeam = isNothing findTeam
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   435
		team = fromJust findTeam
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   436
		findTeam = find (\t -> teamName == teamname t) $ teams clRoom
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   437
		clRoom = roomByName (room client) rooms
12c13ffb426f - Allow team color changing
unc0rr
parents: 1329
diff changeset
   438
1328
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   439
handleCmd_inRoom client _ rooms ["REMOVE_TEAM", teamName] =
1329
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
   440
	if noSuchTeam then
1512
43742041c211 - Don't send 'Bad param' msg, as the only reason of it is just some lag
unc0rr
parents: 1493
diff changeset
   441
		(noChangeClients, noChangeRooms, [])
1328
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   442
	else
1329
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
   443
		if not $ nick client == teamowner team then
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1328
diff changeset
   444
			(noChangeClients, noChangeRooms, answerNotOwner)
1328
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   445
		else
1742
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1725
diff changeset
   446
			if not $ gameinprogress clRoom then
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1725
diff changeset
   447
				(noChangeClients, modifyRoom clRoom{teams = filter (\t -> teamName /= teamname t) $ teams clRoom}, answerRemoveTeam teamName)
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1725
diff changeset
   448
			else
1748
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   449
				(noChangeClients,
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   450
				modifyRoom clRoom{
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   451
					teams = filter (\t -> teamName /= teamname t) $ teams clRoom,
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   452
					leftTeams = teamName : leftTeams clRoom,
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   453
					roundMsgs = roundMsgs clRoom |> rmTeamMsg
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   454
					},
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   455
				answerOthersRoom ["GAMEMSG", rmTeamMsg])
1328
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   456
	where
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   457
		noSuchTeam = isNothing findTeam
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   458
		team = fromJust findTeam
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   459
		findTeam = find (\t -> teamName == teamname t) $ teams clRoom
c41344e3c236 Add support for removing team
unc0rr
parents: 1327
diff changeset
   460
		clRoom = roomByName (room client) rooms
1742
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1725
diff changeset
   461
		rmTeamMsg = toEngineMsg $ 'F' : teamName
1083
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
   462
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
   463
handleCmd_inRoom client _ rooms ["TOGGLE_READY"] =
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
   464
	if isReady client then
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   465
		(modifyClient client{isReady = False}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerNotReady $ nick client)
1338
758c39a3dcfe Stub to run network game
unc0rr
parents: 1336
diff changeset
   466
	else
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   467
		(modifyClient client{isReady = True}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerIsReady $ nick client)
1350
99a921e292f4 - Reverse the order of client list
unc0rr
parents: 1345
diff changeset
   468
	where
99a921e292f4 - Reverse the order of client list
unc0rr
parents: 1345
diff changeset
   469
		clRoom = roomByName (room client) rooms
1404
2b6b6809c2e4 - Fix a bug in READY message handling
unc0rr
parents: 1403
diff changeset
   470
		newReadyPlayers = (readyPlayers clRoom) + if isReady client then -1 else 1
1338
758c39a3dcfe Stub to run network game
unc0rr
parents: 1336
diff changeset
   471
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   472
handleCmd_inRoom client _ rooms ["START_GAME"] =
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   473
	if isMaster client && (playersIn clRoom == readyPlayers clRoom) && (not $ gameinprogress clRoom) then
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   474
		if enoughClans then
1748
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   475
			(noChangeClients, modifyRoom clRoom{gameinprogress = True, roundMsgs = empty, leftTeams = [], teamsAtStart = teams clRoom}, answerRunGame)
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   476
		else
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   477
			(noChangeClients, noChangeRooms, answerTooFewClans)
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   478
	else
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   479
		(noChangeClients, noChangeRooms, [])
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   480
	where
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   481
		clRoom = roomByName (room client) rooms
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   482
		enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams clRoom
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   483
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   484
handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_JOINS"] =
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   485
	if isMaster client then
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   486
		(noChangeClients, modifyRoom clRoom{isRestrictedJoins = newStatus}, [])
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   487
	else
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   488
		(noChangeClients, noChangeRooms, answerNotMaster)
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   489
	where
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   490
		clRoom = roomByName (room client) rooms
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   491
		newStatus = not $ isRestrictedJoins clRoom
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   492
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   493
handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_TEAMS"] =
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   494
	if isMaster client then
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   495
		(noChangeClients, modifyRoom clRoom{isRestrictedTeams = newStatus}, [])
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   496
	else
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   497
		(noChangeClients, noChangeRooms, answerNotMaster)
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   498
	where
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   499
		clRoom = roomByName (room client) rooms
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   500
		newStatus = not $ isRestrictedTeams clRoom
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
   501
1408
fab171a17968 Unset ready status after round
unc0rr
parents: 1407
diff changeset
   502
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
   503
	if isMaster client then
1748
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   504
		(modifyRoomClients clRoom (\cl -> cl{isReady = False}), modifyRoom clRoom{gameinprogress = False, readyPlayers = 0, roundMsgs = empty, leftTeams = [], teamsAtStart = []}, answerAllNotReady ++ answerRemovedTeams)
1345
73119de7d3be Server erases teams list after round finish, so everything should be okay now
unc0rr
parents: 1344
diff changeset
   505
	else
1344
4004e597f1bf Clients send roundfinished message to server when the round is over
unc0rr
parents: 1338
diff changeset
   506
		(noChangeClients, noChangeRooms, [])
1345
73119de7d3be Server erases teams list after round finish, so everything should be okay now
unc0rr
parents: 1344
diff changeset
   507
	where
73119de7d3be Server erases teams list after round finish, so everything should be okay now
unc0rr
parents: 1344
diff changeset
   508
		clRoom = roomByName (room client) rooms
1408
fab171a17968 Unset ready status after round
unc0rr
parents: 1407
diff changeset
   509
		sameRoomClients = filter (\ci -> room ci == name clRoom) clients
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1483
diff changeset
   510
		answerAllNotReady = concatMap (\cl -> answerSameRoom ["NOT_READY", nick cl]) sameRoomClients
1751
b67a124afe53 Finally support removing teams + spectating (spectating still doesn't work okay, as engine doesn't support removing teams properly)
unc0rr
parents: 1748
diff changeset
   511
		answerRemovedTeams = concatMap (\t -> answerSameRoom ["REMOVE_TEAM", t]) $ leftTeams clRoom
1344
4004e597f1bf Clients send roundfinished message to server when the round is over
unc0rr
parents: 1338
diff changeset
   512
1558
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1512
diff changeset
   513
handleCmd_inRoom client _ rooms ["GAMEMSG", msg] =
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1512
diff changeset
   514
	(noChangeClients, addMsg, answerOthersRoom ["GAMEMSG", msg])
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1512
diff changeset
   515
	where
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1512
diff changeset
   516
		addMsg = if roomProto clRoom < 20 then
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1512
diff changeset
   517
					noChangeRooms
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1512
diff changeset
   518
				else
1646
19b3784ac9d2 Optimize net server perfomance by substituting List by Data.Sequence for storing spectators data
unc0rr
parents: 1632
diff changeset
   519
					modifyRoom clRoom{roundMsgs = roundMsgs clRoom |> msg}
1558
3370b7ffeb5c - Send previous moves info to newly connected client when it joins a room with already started game
unc0rr
parents: 1512
diff changeset
   520
		clRoom = roomByName (room client) rooms
1338
758c39a3dcfe Stub to run network game
unc0rr
parents: 1336
diff changeset
   521
1391
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   522
handleCmd_inRoom client clients rooms ["KICK", kickNick] =
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   523
	if isMaster client then
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   524
		if noSuchClient || (kickClient == client) then
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   525
			(noChangeClients, noChangeRooms, [])
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   526
		else
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   527
			(modifyClient kickClient{forceQuit = True}, noChangeRooms, [])
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   528
	else
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   529
		(noChangeClients, noChangeRooms, [])
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   530
	where
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   531
		clRoom = roomByName (room client) rooms
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   532
		noSuchClient = isNothing findClient
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   533
		kickClient = fromJust findClient
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   534
		findClient = find (\t -> ((room t) == (room client)) && ((nick t) == kickNick)) $ clients
735f6d43780b Implement kick
unc0rr
parents: 1385
diff changeset
   535
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1302
diff changeset
   536
handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)