author | unc0rr |
Sun, 05 Apr 2009 07:51:18 +0000 | |
changeset 1942 | 4e092226956d |
parent 1784 | dfe9bafb4590 |
permissions | -rw-r--r-- |
1473 | 1 |
module HWProto |
2 |
( |
|
3 |
handleCmd |
|
4 |
) where |
|
890 | 5 |
|
6 |
import IO |
|
896 | 7 |
import Data.List |
894 | 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 | 11 |
import Miscutils |
1320 | 12 |
import Maybe |
1317 | 13 |
import qualified Data.Map as Map |
1384 | 14 |
import Opts |
890 | 15 |
|
1662 | 16 |
teamToNet protocol team = |
1673 | 17 |
if protocol <= 21 then |
1662 | 18 |
["ADD_TEAM", teamname team, teamgrave team, teamfort team, show $ difficulty team] ++ hhsInfo |
19 |
else |
|
1681 | 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 | 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 | 30 |
answerSameProtoLobby = makeAnswer sameProtoLobbyClients |
1618 | 31 |
answerOtherLobby = makeAnswer otherLobbyClients |
1567 | 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 | 56 |
answerInfo client = answerClientOnly ["INFO", nick client, host client, proto2ver $ protocol client, roomInfo] |
57 |
where |
|
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 | 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 | 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 | 81 |
if not $ null nick then |
82 |
if not $ null msg then |
|
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 | 85 |
answerAll ["LOBBY:LEFT", nick] |
86 |
else |
|
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 | 94 |
answerRoomAdded name = answerSameProtoLobby ["ROOM", "ADD", name] |
95 |
answerRoomDeleted name = answerSameProtoLobby ["ROOM", "DEL", name] |
|
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 | 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 | 109 |
answerServerMessage client clients = [\serverInfo -> (clientOnly, "SERVER_MESSAGE" : |
1614 | 110 |
[(mainbody serverInfo) ++ updateInfo ++ clientsIn ++ (lastHour serverInfo)])] |
1384 | 111 |
where |
1492 | 112 |
mainbody serverInfo = serverMessage serverInfo ++ |
113 |
if isDedicated serverInfo then |
|
114 |
"<p align=center>Dedicated server</p>" |
|
115 |
else |
|
116 |
"<p align=center>Private server</p>" |
|
1614 | 117 |
|
1725 | 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 | 119 |
clientsIn = if protocol client < 20 then "<p align=left>" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "</p>" else [] |
1452 | 120 |
clientslist = if not $ null nicks then foldr1 (\a b -> a ++ ", " ++ b) nicks else "" |
1493 | 121 |
lastHour serverInfo = |
122 |
if isDedicated serverInfo then |
|
123 |
"<p align=left>" ++ (show $ length $ lastHourUsers serverInfo) ++ " user logins in last hour</p>" |
|
124 |
else |
|
125 |
"" |
|
1452 | 126 |
nicks = filter (not . null) $ map nick clients |
1492 | 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 | 130 |
-- Main state-independent cmd handler |
131 |
handleCmd :: CmdHandler |
|
1478 | 132 |
handleCmd client _ rooms ("QUIT" : xs) = |
1082 | 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 | 135 |
else if isMaster client then |
1620 | 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 | 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 | 167 |
newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom |
1478 | 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 | 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 | 178 |
|
1469 | 179 |
handleCmd _ _ _ ["ASKME"] = -- core requsted |
180 |
(noChangeClients, noChangeRooms, answerConnected) |
|
181 |
||
1462 | 182 |
handleCmd _ _ _ ["PONG"] = |
183 |
(noChangeClients, noChangeRooms, []) |
|
184 |
||
1483 | 185 |
handleCmd _ _ _ ["ERROR", msg] = |
186 |
(noChangeClients, noChangeRooms, answerErrorMsg msg) |
|
187 |
||
1577 | 188 |
handleCmd _ clients _ ["INFO", asknick] = |
189 |
if noSuchClient then |
|
190 |
(noChangeClients, noChangeRooms, []) |
|
191 |
else |
|
192 |
(noChangeClients, noChangeRooms, answerInfo client) |
|
193 |
where |
|
194 |
maybeClient = find (\cl -> asknick == nick cl) clients |
|
195 |
noSuchClient = isNothing maybeClient |
|
196 |
client = fromJust maybeClient |
|
197 |
||
198 |
||
1082 | 199 |
-- check state and call state-dependent commmand handlers |
200 |
handleCmd client clients rooms cmd = |
|
201 |
if null (nick client) || protocol client == 0 then |
|
202 |
handleCmd_noInfo client clients rooms cmd |
|
203 |
else if null (room client) then |
|
204 |
handleCmd_noRoom client clients rooms cmd |
|
205 |
else |
|
206 |
handleCmd_inRoom client clients rooms cmd |
|
207 |
||
1307 | 208 |
|
1082 | 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 | 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 | 214 |
answerLobbyNicks ++ |
1618 | 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 | 217 |
where |
218 |
lobbyNicks = filter (\n -> (not (null n)) && n /= nick client) $ map nick $ clients |
|
219 |
answerLobbyNicks = if not $ null lobbyNicks then |
|
220 |
answerClientOnly $ ["LOBBY:JOINED"] ++ lobbyNicks |
|
221 |
else |
|
222 |
[] |
|
1566
6b63c75fdc68
Start work on lobby: add/remove nick from the list on join/quit
unc0rr
parents:
1561
diff
changeset
|
223 |
|
1082 | 224 |
handleCmd_noInfo :: CmdHandler |
225 |
handleCmd_noInfo client clients _ ["NICK", newNick] = |
|
894 | 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 | 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 | 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 | 232 |
where |
1320 | 233 |
haveSameNick = isJust $ find (\cl -> newNick == nick cl) clients |
894 | 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 | 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 | 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 | 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 | 242 |
where |
243 |
parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16) |
|
244 |
||
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
245 |
handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |
894 | 246 |
|
1307 | 247 |
|
894 | 248 |
-- 'noRoom' clients state command handlers |
1082 | 249 |
handleCmd_noRoom :: CmdHandler |
1452 | 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 | 252 |
where |
1402 | 253 |
roomInfo room = [ |
254 |
name room, |
|
255 |
(show $ playersIn room) ++ "(" ++ (show $ length $ teams room) ++ ")", |
|
256 |
show $ gameinprogress room |
|
257 |
] |
|
1412 | 258 |
sameProtoRooms = filter (\r -> (roomProto r == protocol client) && (not $ isRestrictedJoins r)) rooms |
903 | 259 |
|
1082 | 260 |
handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] = |
1492 | 261 |
if haveSameRoom then |
262 |
(noChangeClients, noChangeRooms, answerRoomExists) |
|
895 | 263 |
else |
1591 | 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 | 265 |
where |
1320 | 266 |
haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms |
895 | 267 |
|
1082 | 268 |
handleCmd_noRoom client clients rooms ["CREATE", newRoom] = |
269 |
handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""] |
|
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 | 272 |
if noSuchRoom then |
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
273 |
(noChangeClients, noChangeRooms, answerNoRoom) |
1321 | 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 | 276 |
else if isRestrictedJoins clRoom then |
277 |
(noChangeClients, noChangeRooms, answerRestricted) |
|
895 | 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 | 280 |
where |
1401 | 281 |
noSuchRoom = isNothing $ find (\room -> roomName == name room && roomProto room == protocol client) rooms |
1675 | 282 |
answerNicks = if not $ null sameRoomClients then |
283 |
answerClientOnly $ ["JOINED"] ++ (map nick $ sameRoomClients) |
|
284 |
else |
|
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 | 287 |
sameRoomClients = filter (\ci -> room ci == roomName) clients |
1321 | 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 | 298 |
|
1082 | 299 |
handleCmd_noRoom client clients rooms ["JOIN", roomName] = |
300 |
handleCmd_noRoom client clients rooms ["JOIN", roomName, ""] |
|
894 | 301 |
|
1568 | 302 |
handleCmd_noRoom client _ _ ["CHAT_STRING", msg] = |
303 |
(noChangeClients, noChangeRooms, answerChatString (nick client) msg) |
|
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 | 315 |
|
1307 | 316 |
|
897 | 317 |
-- 'inRoom' clients state command handlers |
1082 | 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 | 320 |
(noChangeClients, noChangeRooms, answerChatString (nick client) msg) |
897 | 321 |
|
1327 | 322 |
handleCmd_inRoom client _ rooms ("CONFIG_PARAM" : paramName : paramStrs) = |
1317 | 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 | 325 |
else |
326 |
(noChangeClients, noChangeRooms, answerNotMaster) |
|
1321 | 327 |
where |
328 |
clRoom = roomByName (room client) rooms |
|
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 | 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 | 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 | 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 | 397 |
newTeam = (TeamInfo (nick client) name color grave fort voicepack difficulty newTeamHHNum (hhsList hhsInfo)) |
1328 | 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 | 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 | 402 |
canAddNumber = 48 - (sum . map hhnum $ teams clRoom) |
1327 | 403 |
newTeamHHNum = min 4 canAddNumber |
404 |
||
1662 | 405 |
handleCmd_inRoom client clients rooms ("ADD_TEAM" : name : color : grave : fort : difStr : hhsInfo) = |
406 |
handleCmd_inRoom client clients rooms ("ADD_TEAM" : name : color : grave : fort : "Default" : difStr : hhsInfo) |
|
407 |
||
408 |
||
1327 | 409 |
handleCmd_inRoom client _ rooms ["HH_NUM", teamName, numberStr] = |
410 |
if not $ isMaster client then |
|
411 |
(noChangeClients, noChangeRooms, answerNotMaster) |
|
412 |
else |
|
1329 | 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 | 415 |
else |
416 |
(noChangeClients, modifyRoom $ modifyTeam clRoom team{hhnum = hhNumber}, answerHHNum teamName hhNumber) |
|
417 |
where |
|
418 |
hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int) |
|
419 |
noSuchTeam = isNothing findTeam |
|
420 |
team = fromJust findTeam |
|
421 |
findTeam = find (\t -> teamName == teamname t) $ teams clRoom |
|
422 |
clRoom = roomByName (room client) rooms |
|
1784 | 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 | 425 |
handleCmd_inRoom client _ rooms ["TEAM_COLOR", teamName, newColor] = |
426 |
if not $ isMaster client then |
|
427 |
(noChangeClients, noChangeRooms, answerNotMaster) |
|
428 |
else |
|
1442 | 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 | 431 |
else |
432 |
(noChangeClients, modifyRoom $ modifyTeam clRoom team{teamcolor = newColor}, answerTeamColor teamName newColor) |
|
1330 | 433 |
where |
434 |
noSuchTeam = isNothing findTeam |
|
435 |
team = fromJust findTeam |
|
436 |
findTeam = find (\t -> teamName == teamname t) $ teams clRoom |
|
437 |
clRoom = roomByName (room client) rooms |
|
438 |
||
1328 | 439 |
handleCmd_inRoom client _ rooms ["REMOVE_TEAM", teamName] = |
1329 | 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 | 442 |
else |
1329 | 443 |
if not $ nick client == teamowner team then |
444 |
(noChangeClients, noChangeRooms, answerNotOwner) |
|
1328 | 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 | 456 |
where |
457 |
noSuchTeam = isNothing findTeam |
|
458 |
team = fromJust findTeam |
|
459 |
findTeam = find (\t -> teamName == teamname t) $ teams clRoom |
|
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 | 462 |
|
1403 | 463 |
handleCmd_inRoom client _ rooms ["TOGGLE_READY"] = |
464 |
if isReady client then |
|
1411 | 465 |
(modifyClient client{isReady = False}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerNotReady $ nick client) |
1338 | 466 |
else |
1411 | 467 |
(modifyClient client{isReady = True}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerIsReady $ nick client) |
1350 | 468 |
where |
469 |
clRoom = roomByName (room client) rooms |
|
1404 | 470 |
newReadyPlayers = (readyPlayers clRoom) + if isReady client then -1 else 1 |
1338 | 471 |
|
1411 | 472 |
handleCmd_inRoom client _ rooms ["START_GAME"] = |
473 |
if isMaster client && (playersIn clRoom == readyPlayers clRoom) && (not $ gameinprogress clRoom) then |
|
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 | 476 |
else |
477 |
(noChangeClients, noChangeRooms, answerTooFewClans) |
|
478 |
else |
|
479 |
(noChangeClients, noChangeRooms, []) |
|
480 |
where |
|
481 |
clRoom = roomByName (room client) rooms |
|
482 |
enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams clRoom |
|
483 |
||
484 |
handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_JOINS"] = |
|
485 |
if isMaster client then |
|
486 |
(noChangeClients, modifyRoom clRoom{isRestrictedJoins = newStatus}, []) |
|
487 |
else |
|
488 |
(noChangeClients, noChangeRooms, answerNotMaster) |
|
489 |
where |
|
490 |
clRoom = roomByName (room client) rooms |
|
491 |
newStatus = not $ isRestrictedJoins clRoom |
|
492 |
||
493 |
handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_TEAMS"] = |
|
494 |
if isMaster client then |
|
495 |
(noChangeClients, modifyRoom clRoom{isRestrictedTeams = newStatus}, []) |
|
496 |
else |
|
497 |
(noChangeClients, noChangeRooms, answerNotMaster) |
|
498 |
where |
|
499 |
clRoom = roomByName (room client) rooms |
|
500 |
newStatus = not $ isRestrictedTeams clRoom |
|
501 |
||
1408 | 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 | 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 | 521 |
|
1391 | 522 |
handleCmd_inRoom client clients rooms ["KICK", kickNick] = |
523 |
if isMaster client then |
|
524 |
if noSuchClient || (kickClient == client) then |
|
525 |
(noChangeClients, noChangeRooms, []) |
|
526 |
else |
|
527 |
(modifyClient kickClient{forceQuit = True}, noChangeRooms, []) |
|
528 |
else |
|
529 |
(noChangeClients, noChangeRooms, []) |
|
530 |
where |
|
531 |
clRoom = roomByName (room client) rooms |
|
532 |
noSuchClient = isNothing findClient |
|
533 |
kickClient = fromJust findClient |
|
534 |
findClient = find (\t -> ((room t) == (room client)) && ((nick t) == kickNick)) $ clients |
|
535 |
||
1304
05cebf68ebd8
Start refactoring standalone server (prepare to change protocol)
unc0rr
parents:
1302
diff
changeset
|
536 |
handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd) |