author | koda |
Wed, 22 Dec 2010 03:05:28 +0100 | |
changeset 4603 | d362ab6c7f53 |
parent 4568 | f85243bf890e |
child 4762 | 59eb6319c950 |
permissions | -rw-r--r-- |
1804 | 1 |
module Actions where |
2 |
||
4568 | 3 |
import Control.Concurrent.STM |
1804 | 4 |
import Control.Concurrent.Chan |
4568 | 5 |
import Data.IntMap |
1804 | 6 |
import qualified Data.IntSet as IntSet |
1813 | 7 |
import qualified Data.Sequence as Seq |
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
8 |
import System.Log.Logger |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
9 |
import Control.Monad |
1926
cb46fbdcaa41
Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents:
1925
diff
changeset
|
10 |
import Data.Time |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
11 |
import Data.Maybe |
1804 | 12 |
----------------------------- |
13 |
import CoreTypes |
|
1813 | 14 |
import Utils |
1804 | 15 |
|
16 |
data Action = |
|
4568 | 17 |
AnswerThisClient [String] |
18 |
| AnswerAll [String] |
|
19 |
| AnswerAllOthers [String] |
|
20 |
| AnswerThisRoom [String] |
|
21 |
| AnswerOthersInRoom [String] |
|
22 |
| AnswerSameClan [String] |
|
23 |
| AnswerLobby [String] |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
24 |
| SendServerMessage |
3283 | 25 |
| SendServerVars |
4568 | 26 |
| RoomAddThisClient Int -- roomID |
27 |
| RoomRemoveThisClient String |
|
28 |
| RemoveTeam String |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
29 |
| RemoveRoom |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
30 |
| UnreadyRoomClients |
4568 | 31 |
| MoveToLobby |
32 |
| ProtocolError String |
|
33 |
| Warning String |
|
34 |
| ByeClient String |
|
35 |
| KickClient Int -- clID |
|
36 |
| KickRoomClient Int -- clID |
|
37 |
| BanClient String -- nick |
|
38 |
| RemoveClientTeams Int -- clID |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
39 |
| ModifyClient (ClientInfo -> ClientInfo) |
4568 | 40 |
| ModifyClient2 Int (ClientInfo -> ClientInfo) |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
41 |
| ModifyRoom (RoomInfo -> RoomInfo) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
42 |
| ModifyServerInfo (ServerInfo -> ServerInfo) |
4568 | 43 |
| AddRoom String String |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
44 |
| CheckRegistered |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
45 |
| ClearAccountsCache |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
46 |
| ProcessAccountInfo AccountInfo |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
47 |
| Dump |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
48 |
| AddClient ClientInfo |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
49 |
| PingAll |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
50 |
| StatsAction |
1804 | 51 |
|
4568 | 52 |
type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action] |
53 |
||
54 |
replaceID a (b, c, d, e) = (a, c, d, e) |
|
55 |
||
56 |
processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms) |
|
57 |
||
58 |
||
59 |
processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do |
|
60 |
writeChan (sendChan $ clients ! clID) msg |
|
61 |
return (clID, serverInfo, clients, rooms) |
|
1804 | 62 |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
63 |
|
4568 | 64 |
processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do |
65 |
mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients) |
|
66 |
return (clID, serverInfo, clients, rooms) |
|
67 |
||
68 |
||
69 |
processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do |
|
70 |
mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ |
|
71 |
Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients) |
|
72 |
return (clID, serverInfo, clients, rooms) |
|
73 |
||
74 |
||
75 |
processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do |
|
76 |
mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients |
|
77 |
return (clID, serverInfo, clients, rooms) |
|
78 |
where |
|
79 |
roomClients = IntSet.elems $ playersIDs room |
|
80 |
room = rooms ! rID |
|
81 |
rID = roomID client |
|
82 |
client = clients ! clID |
|
1804 | 83 |
|
84 |
||
4568 | 85 |
processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do |
86 |
mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ Prelude.filter (/= clID) roomClients |
|
87 |
return (clID, serverInfo, clients, rooms) |
|
88 |
where |
|
89 |
roomClients = IntSet.elems $ playersIDs room |
|
90 |
room = rooms ! rID |
|
91 |
rID = roomID client |
|
92 |
client = clients ! clID |
|
93 |
||
94 |
||
95 |
processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do |
|
96 |
mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients |
|
97 |
return (clID, serverInfo, clients, rooms) |
|
98 |
where |
|
99 |
roomClients = IntSet.elems $ playersIDs room |
|
100 |
room = rooms ! 0 |
|
1804 | 101 |
|
102 |
||
4568 | 103 |
processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do |
104 |
mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec |
|
105 |
return (clID, serverInfo, clients, rooms) |
|
106 |
where |
|
107 |
otherRoomClients = Prelude.map ((!) clients) $ IntSet.elems $ clID `IntSet.delete` (playersIDs room) |
|
108 |
sameClanOrSpec = if teamsInGame client > 0 then sameClanClients else spectators |
|
109 |
spectators = Prelude.filter (\cl -> teamsInGame cl == 0) otherRoomClients |
|
110 |
sameClanClients = Prelude.filter (\cl -> teamsInGame cl > 0 && clientClan cl == thisClan) otherRoomClients |
|
111 |
thisClan = clientClan client |
|
112 |
room = rooms ! rID |
|
113 |
rID = roomID client |
|
114 |
client = clients ! clID |
|
115 |
||
116 |
||
117 |
processAction (clID, serverInfo, clients, rooms) SendServerMessage = do |
|
118 |
writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo] |
|
119 |
return (clID, serverInfo, clients, rooms) |
|
120 |
where |
|
121 |
client = clients ! clID |
|
122 |
message si = if clientProto client < latestReleaseVersion si then |
|
3283 | 123 |
serverMessageForOldVersions si |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
124 |
else |
3283 | 125 |
serverMessage si |
126 |
||
4568 | 127 |
processAction (clID, serverInfo, clients, rooms) SendServerVars = do |
3283 | 128 |
writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars) |
4568 | 129 |
return (clID, serverInfo, clients, rooms) |
3283 | 130 |
where |
131 |
client = clients ! clID |
|
132 |
vars = [ |
|
4568 | 133 |
"MOTD_NEW", serverMessage serverInfo, |
134 |
"MOTD_OLD", serverMessageForOldVersions serverInfo, |
|
3283 | 135 |
"LATEST_PROTO", show $ latestReleaseVersion serverInfo |
136 |
] |
|
1923 | 137 |
|
138 |
||
4568 | 139 |
processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do |
140 |
writeChan (sendChan $ clients ! clID) ["ERROR", msg] |
|
141 |
return (clID, serverInfo, clients, rooms) |
|
3501 | 142 |
|
4568 | 143 |
|
144 |
processAction (clID, serverInfo, clients, rooms) (Warning msg) = do |
|
145 |
writeChan (sendChan $ clients ! clID) ["WARNING", msg] |
|
146 |
return (clID, serverInfo, clients, rooms) |
|
1804 | 147 |
|
148 |
||
4568 | 149 |
processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do |
150 |
infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg) |
|
151 |
(_, _, newClients, newRooms) <- |
|
152 |
if roomID client /= 0 then |
|
153 |
processAction (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit" |
|
154 |
else |
|
155 |
return (clID, serverInfo, clients, rooms) |
|
3458 | 156 |
|
4568 | 157 |
mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom |
158 |
writeChan (sendChan $ clients ! clID) ["BYE", msg] |
|
159 |
return ( |
|
160 |
0, |
|
161 |
serverInfo, |
|
162 |
delete clID newClients, |
|
163 |
adjust (\r -> r{ |
|
164 |
playersIDs = IntSet.delete clID (playersIDs r), |
|
165 |
playersIn = (playersIn r) - 1, |
|
166 |
readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r |
|
167 |
}) (roomID $ newClients ! clID) newRooms |
|
168 |
) |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
169 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
170 |
client = clients ! clID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
171 |
clientNick = nick client |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
172 |
answerInformRoom = |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
173 |
if roomID client /= 0 then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
174 |
if not $ Prelude.null msg then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
175 |
[AnswerThisRoom ["LEFT", clientNick, msg]] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
176 |
else |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
177 |
[AnswerThisRoom ["LEFT", clientNick]] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
178 |
else |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
179 |
[] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
180 |
answerOthersQuit = |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
181 |
if logonPassed client then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
182 |
if not $ Prelude.null msg then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
183 |
[AnswerAll ["LOBBY:LEFT", clientNick, msg]] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
184 |
else |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
185 |
[AnswerAll ["LOBBY:LEFT", clientNick]] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
186 |
else |
4568 | 187 |
[] |
188 |
||
189 |
||
190 |
processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = |
|
191 |
return (clID, serverInfo, adjust func clID clients, rooms) |
|
192 |
||
1804 | 193 |
|
4568 | 194 |
processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) = |
195 |
return (clID, serverInfo, adjust func cl2ID clients, rooms) |
|
196 |
||
3568 | 197 |
|
4568 | 198 |
processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = |
199 |
return (clID, serverInfo, clients, adjust func rID rooms) |
|
200 |
where |
|
201 |
rID = roomID $ clients ! clID |
|
3568 | 202 |
|
1804 | 203 |
|
4568 | 204 |
processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) = |
205 |
return (clID, func serverInfo, clients, rooms) |
|
2403 | 206 |
|
1925 | 207 |
|
4568 | 208 |
processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) = |
209 |
processAction ( |
|
210 |
clID, |
|
211 |
serverInfo, |
|
212 |
adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients, |
|
213 |
adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $ |
|
214 |
adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms |
|
215 |
) joinMsg |
|
216 |
where |
|
217 |
client = clients ! clID |
|
218 |
joinMsg = if rID == 0 then |
|
219 |
AnswerAllOthers ["LOBBY:JOINED", nick client] |
|
220 |
else |
|
221 |
AnswerThisRoom ["JOINED", nick client] |
|
3645 | 222 |
|
1804 | 223 |
|
4568 | 224 |
processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
225 |
(_, _, newClients, newRooms) <- |
4568 | 226 |
if roomID client /= 0 then |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
227 |
if isMaster client then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
228 |
if (gameinprogress room) && (playersIn room > 1) then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
229 |
(changeMaster >>= (\state -> foldM processAction state |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
230 |
[AnswerOthersInRoom ["LEFT", nick client, msg], |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
231 |
AnswerOthersInRoom ["WARNING", "Admin left the room"], |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
232 |
RemoveClientTeams clID])) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
233 |
else -- not in game |
4568 | 234 |
processAction (clID, serverInfo, clients, rooms) RemoveRoom |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
235 |
else -- not master |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
236 |
foldM |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
237 |
processAction |
4568 | 238 |
(clID, serverInfo, clients, rooms) |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
239 |
[AnswerOthersInRoom ["LEFT", nick client, msg], |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
240 |
RemoveClientTeams clID] |
4568 | 241 |
else -- in lobby |
242 |
return (clID, serverInfo, clients, rooms) |
|
243 |
||
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
244 |
return ( |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
245 |
clID, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
246 |
serverInfo, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
247 |
adjust resetClientFlags clID newClients, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
248 |
adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
249 |
) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
250 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
251 |
rID = roomID client |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
252 |
client = clients ! clID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
253 |
room = rooms ! rID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
254 |
resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
255 |
removeClientFromRoom r = r{ |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
256 |
playersIDs = otherPlayersSet, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
257 |
playersIn = (playersIn r) - 1, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
258 |
readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
259 |
} |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
260 |
insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)} |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
261 |
changeMaster = do |
4568 | 262 |
processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
263 |
return ( |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
264 |
clID, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
265 |
serverInfo, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
266 |
adjust (\cl -> cl{isMaster = True}) newMasterId clients, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
267 |
adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
268 |
) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
269 |
newRoomName = nick newMasterClient |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
270 |
otherPlayersSet = IntSet.delete clID (playersIDs room) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
271 |
newMasterId = IntSet.findMin otherPlayersSet |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
272 |
newMasterClient = clients ! newMasterId |
4568 | 273 |
|
1804 | 274 |
|
4568 | 275 |
processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do |
276 |
let newServerInfo = serverInfo {nextRoomID = newID} |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
277 |
let room = newRoom{ |
4568 | 278 |
roomUID = newID, |
279 |
masterID = clID, |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
280 |
name = roomName, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
281 |
password = roomPassword, |
4568 | 282 |
roomProto = (clientProto client) |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
283 |
} |
3645 | 284 |
|
4568 | 285 |
processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName] |
1804 | 286 |
|
4568 | 287 |
processAction ( |
288 |
clID, |
|
289 |
newServerInfo, |
|
290 |
adjust (\cl -> cl{isMaster = True}) clID clients, |
|
291 |
insert newID room rooms |
|
292 |
) $ RoomAddThisClient newID |
|
293 |
where |
|
294 |
newID = (nextRoomID serverInfo) - 1 |
|
295 |
client = clients ! clID |
|
1804 | 296 |
|
4568 | 297 |
|
298 |
processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do |
|
299 |
processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room] |
|
300 |
processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room] |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
301 |
return (clID, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
302 |
serverInfo, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
303 |
Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
304 |
delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
305 |
) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
306 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
307 |
room = rooms ! rID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
308 |
rID = roomID client |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
309 |
client = clients ! clID |
1804 | 310 |
|
4568 | 311 |
|
312 |
processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do |
|
313 |
processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers) |
|
314 |
return (clID, |
|
315 |
serverInfo, |
|
316 |
Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients, |
|
317 |
adjust (\r -> r{readyPlayers = 0}) rID rooms) |
|
318 |
where |
|
319 |
room = rooms ! rID |
|
320 |
rID = roomID client |
|
321 |
client = clients ! clID |
|
322 |
roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs |
|
323 |
roomPlayersIDs = IntSet.elems $ playersIDs room |
|
1813 | 324 |
|
1811 | 325 |
|
4568 | 326 |
processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do |
327 |
newRooms <- if not $ gameinprogress room then |
|
328 |
do |
|
329 |
processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName] |
|
330 |
return $ |
|
331 |
adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
332 |
else |
4568 | 333 |
do |
334 |
processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg] |
|
335 |
return $ |
|
336 |
adjust (\r -> r{ |
|
337 |
teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, |
|
338 |
leftTeams = teamName : leftTeams r, |
|
339 |
roundMsgs = roundMsgs r Seq.|> rmTeamMsg |
|
340 |
}) rID rooms |
|
341 |
return (clID, serverInfo, clients, newRooms) |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
342 |
where |
4568 | 343 |
room = rooms ! rID |
344 |
rID = roomID client |
|
345 |
client = clients ! clID |
|
346 |
rmTeamMsg = toEngineMsg $ 'F' : teamName |
|
1813 | 347 |
|
1834 | 348 |
|
4568 | 349 |
processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do |
350 |
writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client) |
|
351 |
return (clID, serverInfo, clients, rooms) |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
352 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
353 |
client = clients ! clID |
2155
d897222d3339
Implement ability for server admin to clear accounts cache
unc0rr
parents:
2126
diff
changeset
|
354 |
|
d897222d3339
Implement ability for server admin to clear accounts cache
unc0rr
parents:
2126
diff
changeset
|
355 |
|
4568 | 356 |
processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do |
357 |
writeChan (dbQueries serverInfo) ClearCache |
|
358 |
return (clID, serverInfo, clients, rooms) |
|
359 |
where |
|
360 |
client = clients ! clID |
|
361 |
||
362 |
||
363 |
processAction (clID, serverInfo, clients, rooms) (Dump) = do |
|
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
364 |
writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] |
4568 | 365 |
return (clID, serverInfo, clients, rooms) |
4242 | 366 |
|
4568 | 367 |
|
368 |
processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) = |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
369 |
case info of |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
370 |
HasAccount passwd isAdmin -> do |
4568 | 371 |
infoM "Clients" $ show clID ++ " has account" |
372 |
writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"] |
|
373 |
return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms) |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
374 |
Guest -> do |
4568 | 375 |
infoM "Clients" $ show clID ++ " is guest" |
376 |
processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
377 |
Admin -> do |
4568 | 378 |
infoM "Clients" $ show clID ++ " is admin" |
379 |
foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]] |
|
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
380 |
|
3502 | 381 |
|
4568 | 382 |
processAction (clID, serverInfo, clients, rooms) (MoveToLobby) = |
383 |
foldM processAction (clID, serverInfo, clients, rooms) $ |
|
384 |
(RoomAddThisClient 0) |
|
385 |
: answerLobbyNicks |
|
386 |
++ [SendServerMessage] |
|
2118
0ebcc98ebc1a
Send server message after nicks info (more chance for it to be seen)
unc0rr
parents:
2116
diff
changeset
|
387 |
|
4568 | 388 |
-- ++ (answerServerMessage client clients) |
3502 | 389 |
where |
4568 | 390 |
lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients |
391 |
answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks] |
|
1879 | 392 |
|
1926
cb46fbdcaa41
Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents:
1925
diff
changeset
|
393 |
|
4568 | 394 |
processAction (clID, serverInfo, clients, rooms) (KickClient kickID) = |
395 |
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked") |
|
396 |
||
397 |
||
398 |
processAction (clID, serverInfo, clients, rooms) (BanClient banNick) = |
|
399 |
return (clID, serverInfo, clients, rooms) |
|
1921 | 400 |
|
1879 | 401 |
|
4568 | 402 |
processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
403 |
writeChan (sendChan $ clients ! kickID) ["KICKED"] |
4568 | 404 |
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked") |
1879 | 405 |
|
406 |
||
4568 | 407 |
processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) = |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
408 |
liftM2 replaceID (return clID) $ |
4568 | 409 |
foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
410 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
411 |
client = clients ! teamsClID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
412 |
room = rooms ! (roomID client) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
413 |
teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
414 |
removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove |
4568 | 415 |
|
1926
cb46fbdcaa41
Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents:
1925
diff
changeset
|
416 |
|
4568 | 417 |
processAction (clID, serverInfo, clients, rooms) (AddClient client) = do |
418 |
let updatedClients = insert (clientUID client) client clients |
|
419 |
infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client)) |
|
420 |
writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
421 |
|
4568 | 422 |
let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo |
1926
cb46fbdcaa41
Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents:
1925
diff
changeset
|
423 |
|
4568 | 424 |
if isJust $ host client `Prelude.lookup` newLogins then |
425 |
processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast" |
|
426 |
else |
|
427 |
return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms) |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
428 |
|
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
429 |
|
4568 | 430 |
processAction (clID, serverInfo, clients, rooms) PingAll = do |
431 |
(_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients |
|
432 |
processAction (clID, |
|
433 |
serverInfo, |
|
434 |
Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients, |
|
435 |
newRooms) $ AnswerAll ["PING"] |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
436 |
where |
4568 | 437 |
kickTimeouted (clID, serverInfo, clients, rooms) client = |
438 |
if pingsQueue client > 0 then |
|
439 |
processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout" |
|
440 |
else |
|
441 |
return (clID, serverInfo, clients, rooms) |
|
2172 | 442 |
|
443 |
||
4568 | 444 |
processAction (clID, serverInfo, clients, rooms) (StatsAction) = do |
445 |
writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1) |
|
446 |
return (clID, serverInfo, clients, rooms) |