1
{-# LANGUAGE OverloadedStrings #-}
3
import Control.Concurrent.STM
4
import Control.Concurrent.Chan
6
import qualified Data.IntSet as IntSet
4
import Control.Concurrent
5
import qualified Data.Set as Set
7
6
import qualified Data.Sequence as Seq
7
import qualified Data.List as L
8
import qualified Control.Exception as Exception
8
9
import System.Log.Logger
9
10
import Control.Monad
13
import Control.Monad.Reader
14
import Control.Monad.State.Strict
15
import qualified Data.ByteString.Char8 as B
16
import Control.DeepSeq
19
import Control.Exception
20
import OfficialServer.GameReplayStore
12
23
-----------------------------
17
AnswerThisClient [String]
19
| AnswerAllOthers [String]
20
| AnswerThisRoom [String]
21
| AnswerOthersInRoom [String]
22
| AnswerSameClan [String]
23
| AnswerLobby [String]
32
AnswerClients ![ClientChan] ![B.ByteString]
24
33
| SendServerMessage
26
| RoomAddThisClient Int -- roomID
27
| RoomRemoveThisClient String
35
| MoveToRoom RoomIndex
36
| MoveToLobby B.ByteString
37
| RemoveTeam B.ByteString
30
39
| UnreadyRoomClients
32
| ProtocolError String
35
| KickClient Int -- clID
36
| KickRoomClient Int -- clID
37
| BanClient String -- nick
38
| RemoveClientTeams Int -- clID
41
| ProtocolError B.ByteString
42
| Warning B.ByteString
43
| NoticeMessage Notice
44
| ByeClient B.ByteString
45
| KickClient ClientIndex
46
| KickRoomClient ClientIndex
47
| BanClient NominalDiffTime B.ByteString ClientIndex
48
| BanIP B.ByteString NominalDiffTime B.ByteString
51
| RemoveClientTeams ClientIndex
39
52
| ModifyClient (ClientInfo -> ClientInfo)
40
| ModifyClient2 Int (ClientInfo -> ClientInfo)
53
| ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
41
54
| ModifyRoom (RoomInfo -> RoomInfo)
42
55
| ModifyServerInfo (ServerInfo -> ServerInfo)
43
| AddRoom String String
56
| AddRoom B.ByteString B.ByteString
45
58
| ClearAccountsCache
46
59
| ProcessAccountInfo AccountInfo
48
60
| AddClient ClientInfo
61
| DeleteClient ClientIndex
52
type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action]
54
replaceID a (b, c, d, e) = (a, c, d, e)
56
processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms)
59
processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do
60
writeChan (sendChan $ clients ! clID) msg
61
return (clID, serverInfo, clients, rooms)
64
processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do
65
mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients)
66
return (clID, serverInfo, clients, rooms)
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)
75
processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do
76
mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients
77
return (clID, serverInfo, clients, rooms)
79
roomClients = IntSet.elems $ playersIDs room
82
client = clients ! clID
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)
89
roomClients = IntSet.elems $ playersIDs room
92
client = clients ! clID
95
processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do
96
mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients
97
return (clID, serverInfo, clients, rooms)
99
roomClients = IntSet.elems $ playersIDs room
103
processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do
104
mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec
105
return (clID, serverInfo, clients, rooms)
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
114
client = clients ! clID
117
processAction (clID, serverInfo, clients, rooms) SendServerMessage = do
118
writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo]
119
return (clID, serverInfo, clients, rooms)
121
client = clients ! clID
122
message si = if clientProto client < latestReleaseVersion si then
65
| AddNick2Bans B.ByteString B.ByteString UTCTime
66
| AddIP2Bans B.ByteString B.ByteString UTCTime
71
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
73
instance NFData Action where
74
rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
77
instance NFData B.ByteString
78
instance NFData (Chan a)
81
othersChans :: StateT ServerState IO [ClientChan]
85
liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
87
processAction :: Action -> StateT ServerState IO ()
90
processAction (AnswerClients chans msg) =
91
io $ mapM_ (`writeChan` (msg `deepseq` msg)) (chans `deepseq` chans)
94
processAction SendServerMessage = do
95
chan <- client's sendChan
96
protonum <- client's clientProto
97
si <- liftM serverInfo get
98
let message = if protonum < latestReleaseVersion si then
123
99
serverMessageForOldVersions si
127
processAction (clID, serverInfo, clients, rooms) SendServerVars = do
128
writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)
129
return (clID, serverInfo, clients, rooms)
102
processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
105
processAction SendServerVars = do
106
chan <- client's sendChan
107
si <- gets serverInfo
108
io $ writeChan chan ("SERVER_VARS" : vars si)
131
client = clients ! clID
133
"MOTD_NEW", serverMessage serverInfo,
134
"MOTD_OLD", serverMessageForOldVersions serverInfo,
135
"LATEST_PROTO", show $ latestReleaseVersion serverInfo
111
"MOTD_NEW", serverMessage si,
112
"MOTD_OLD", serverMessageForOldVersions si,
113
"LATEST_PROTO", showB $ latestReleaseVersion si
139
processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do
140
writeChan (sendChan $ clients ! clID) ["ERROR", msg]
141
return (clID, serverInfo, clients, rooms)
144
processAction (clID, serverInfo, clients, rooms) (Warning msg) = do
145
writeChan (sendChan $ clients ! clID) ["WARNING", msg]
146
return (clID, serverInfo, clients, rooms)
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"
155
return (clID, serverInfo, clients, rooms)
157
mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom
158
writeChan (sendChan $ clients ! clID) ["BYE", msg]
162
delete clID newClients,
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
170
client = clients ! clID
171
clientNick = nick client
173
if roomID client /= 0 then
174
if not $ Prelude.null msg then
175
[AnswerThisRoom ["LEFT", clientNick, msg]]
177
[AnswerThisRoom ["LEFT", clientNick]]
181
if logonPassed client then
182
if not $ Prelude.null msg then
183
[AnswerAll ["LOBBY:LEFT", clientNick, msg]]
185
[AnswerAll ["LOBBY:LEFT", clientNick]]
190
processAction (clID, serverInfo, clients, rooms) (ModifyClient func) =
191
return (clID, serverInfo, adjust func clID clients, rooms)
194
processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) =
195
return (clID, serverInfo, adjust func cl2ID clients, rooms)
198
processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) =
199
return (clID, serverInfo, clients, adjust func rID rooms)
201
rID = roomID $ clients ! clID
204
processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) =
205
return (clID, func serverInfo, clients, rooms)
208
processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) =
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
217
client = clients ! clID
218
joinMsg = if rID == 0 then
219
AnswerAllOthers ["LOBBY:JOINED", nick client]
221
AnswerThisRoom ["JOINED", nick client]
224
processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do
225
(_, _, newClients, newRooms) <-
226
if roomID client /= 0 then
227
if isMaster client then
228
if (gameinprogress room) && (playersIn room > 1) then
229
(changeMaster >>= (\state -> foldM processAction state
230
[AnswerOthersInRoom ["LEFT", nick client, msg],
231
AnswerOthersInRoom ["WARNING", "Admin left the room"],
232
RemoveClientTeams clID]))
234
processAction (clID, serverInfo, clients, rooms) RemoveRoom
238
(clID, serverInfo, clients, rooms)
239
[AnswerOthersInRoom ["LEFT", nick client, msg],
240
RemoveClientTeams clID]
242
return (clID, serverInfo, clients, rooms)
117
processAction (ProtocolError msg) = do
118
chan <- client's sendChan
119
processAction $ AnswerClients [chan] ["ERROR", msg]
122
processAction (Warning msg) = do
123
chan <- client's sendChan
124
processAction $ AnswerClients [chan] ["WARNING", msg]
126
processAction (NoticeMessage n) = do
127
chan <- client's sendChan
128
processAction $ AnswerClients [chan] ["NOTICE", showB . fromEnum $ n]
130
processAction (ByeClient msg) = do
131
(Just ci) <- gets clientIndex
134
chan <- client's sendChan
135
clNick <- client's nick
136
loggedIn <- client's logonPassed
138
when (ri /= lobbyId) $ do
139
processAction $ MoveToLobby ("quit: " `B.append` msg)
142
clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
144
infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
146
processAction $ AnswerClients [chan] ["BYE", msg]
147
when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
150
put $! s{removedClients = ci `Set.insert` removedClients s}
152
processAction (DeleteClient ci) = do
153
io $ debugM "Clients" $ "DeleteClient: " ++ show ci
155
rnc <- gets roomsClients
156
io $ removeClient rnc ci
159
put $! s{removedClients = ci `Set.delete` removedClients s}
247
adjust resetClientFlags clID newClients,
248
adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
252
client = clients ! clID
254
resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined}
255
removeClientFromRoom r = r{
256
playersIDs = otherPlayersSet,
257
playersIn = (playersIn r) - 1,
258
readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r
260
insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}
262
processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
266
adjust (\cl -> cl{isMaster = True}) newMasterId clients,
267
adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms
269
newRoomName = nick newMasterClient
270
otherPlayersSet = IntSet.delete clID (playersIDs room)
271
newMasterId = IntSet.findMin otherPlayersSet
272
newMasterClient = clients ! newMasterId
275
processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do
276
let newServerInfo = serverInfo {nextRoomID = newID}
161
sp <- gets (shutdownPending . serverInfo)
163
io $ when (sp && null cls) $ throwIO ShutdownException
165
processAction (ModifyClient f) = do
166
(Just ci) <- gets clientIndex
167
rnc <- gets roomsClients
168
io $ modifyClient rnc f ci
171
processAction (ModifyClient2 ci f) = do
172
rnc <- gets roomsClients
173
io $ modifyClient rnc f ci
177
processAction (ModifyRoom f) = do
178
rnc <- gets roomsClients
180
io $ modifyRoom rnc f ri
184
processAction (ModifyServerInfo f) = do
185
modify (\s -> s{serverInfo = f $ serverInfo s})
186
si <- gets serverInfo
187
io $ writeServerConfig si
190
processAction (MoveToRoom ri) = do
191
(Just ci) <- gets clientIndex
192
rnc <- gets roomsClients
195
modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci
196
modifyRoom rnc (\r -> r{playersIn = playersIn r + 1}) ri
197
moveClientToRoom rnc ri ci
199
chans <- liftM (map sendChan) $ roomClientsS ri
200
clNick <- client's nick
202
processAction $ AnswerClients chans ["JOINED", clNick]
205
processAction (MoveToLobby msg) = do
206
(Just ci) <- gets clientIndex
208
rnc <- gets roomsClients
209
(gameProgress, playersNum) <- io $ room'sM rnc (gameinprogress &&& playersIn) ri
210
ready <- client's isReady
211
master <- client's isMaster
212
-- client <- client's id
213
clNick <- client's nick
217
if gameProgress && playersNum > 1 then
218
mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci]
220
processAction RemoveRoom
222
mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
224
-- when not removing room
225
when (not master || (gameProgress && playersNum > 1)) . io $ do
226
modifyRoom rnc (\r -> r{
227
playersIn = playersIn r - 1,
228
readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
230
moveClientToLobby rnc ci
232
processAction ChangeMaster = do
233
(Just ci) <- gets clientIndex
235
rnc <- gets roomsClients
236
newMasterId <- liftM (head . filter (/= ci)) . io $ roomClientsIndicesM rnc ri
237
newMaster <- io $ client'sM rnc id newMasterId
238
let newRoomName = nick newMaster
239
mapM_ processAction [
240
ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}),
241
ModifyClient2 newMasterId (\c -> c{isMaster = True}),
242
AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
245
processAction (AddRoom roomName roomPassword) = do
246
Just clId <- gets clientIndex
247
rnc <- gets roomsClients
248
proto <- io $ client'sM rnc clientProto clId
281
253
password = roomPassword,
282
roomProto = (clientProto client)
285
processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName]
290
adjust (\cl -> cl{isMaster = True}) clID clients,
291
insert newID room rooms
292
) $ RoomAddThisClient newID
294
newID = (nextRoomID serverInfo) - 1
295
client = clients ! clID
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]
303
Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients,
304
delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms
309
client = clients ! clID
312
processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do
313
processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers)
316
Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients,
317
adjust (\r -> r{readyPlayers = 0}) rID rooms)
321
client = clients ! clID
322
roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs
323
roomPlayersIDs = IntSet.elems $ playersIDs room
326
processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do
327
newRooms <- if not $ gameinprogress room then
329
processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName]
331
adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms
334
processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg]
337
teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
338
leftTeams = teamName : leftTeams r,
339
roundMsgs = roundMsgs r Seq.|> rmTeamMsg
341
return (clID, serverInfo, clients, newRooms)
345
client = clients ! clID
346
rmTeamMsg = toEngineMsg $ 'F' : teamName
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)
353
client = clients ! clID
356
processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do
357
writeChan (dbQueries serverInfo) ClearCache
358
return (clID, serverInfo, clients, rooms)
360
client = clients ! clID
363
processAction (clID, serverInfo, clients, rooms) (Dump) = do
364
writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
365
return (clID, serverInfo, clients, rooms)
368
processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) =
257
rId <- io $ addRoom rnc rm
259
processAction $ MoveToRoom rId
261
chans <- liftM (map sendChan) $! roomClientsS lobbyId
263
mapM_ processAction [
264
AnswerClients chans ["ROOM", "ADD", roomName]
265
, ModifyClient (\cl -> cl{isMaster = True})
269
processAction RemoveRoom = do
270
Just clId <- gets clientIndex
271
rnc <- gets roomsClients
272
ri <- io $ clientRoomM rnc clId
273
roomName <- io $ room'sM rnc name ri
274
others <- othersChans
275
lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId
277
mapM_ processAction [
278
AnswerClients lobbyChans ["ROOM", "DEL", roomName],
279
AnswerClients others ["ROOMABANDONED", roomName]
282
io $ removeRoom rnc ri
285
processAction (UnreadyRoomClients) = do
286
rnc <- gets roomsClients
288
roomPlayers <- roomClientsS ri
289
roomClIDs <- io $ roomClientsIndicesM rnc ri
290
pr <- client's clientProto
291
processAction $ AnswerClients (map sendChan roomPlayers) $ notReadyMessage pr (map nick roomPlayers)
292
io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
293
processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
295
notReadyMessage p nicks = if p < 38 then "NOT_READY" : nicks else "CLIENT_FLAGS" : "-r" : nicks
298
processAction (RemoveTeam teamName) = do
299
rnc <- gets roomsClients
301
inGame <- io $ room'sM rnc gameinprogress ri
304
mapM_ processAction [
305
AnswerClients chans ["REMOVE_TEAM", teamName],
306
ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r})
309
mapM_ processAction [
310
AnswerClients chans ["EM", rmTeamMsg],
312
teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
313
leftTeams = teamName : leftTeams r,
314
roundMsgs = roundMsgs r Seq.|> rmTeamMsg
318
rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName
321
processAction (RemoveClientTeams clId) = do
322
rnc <- gets roomsClients
324
removeTeamActions <- io $ do
325
clNick <- client'sM rnc nick clId
326
rId <- clientRoomM rnc clId
327
roomTeams <- room'sM rnc teams rId
328
return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
330
mapM_ processAction removeTeamActions
334
processAction CheckRegistered = do
335
(Just ci) <- gets clientIndex
338
p <- client's clientProto
339
uid <- client's clUID
340
haveSameNick <- liftM (not . null . tail . filter (\c -> nick c == n)) allClientsS
343
mapM_ processAction [ByeClient "Nickname is already in use", removeNick]
345
mapM_ processAction [NoticeMessage NickAlreadyInUse, removeNick]
348
db <- gets (dbQueries . serverInfo)
349
io $ writeChan db $ CheckAccount ci (hashUnique uid) n h
352
removeNick = ModifyClient (\c -> c{nick = ""})
355
processAction ClearAccountsCache = do
356
dbq <- gets (dbQueries . serverInfo)
357
io $ writeChan dbq ClearCache
361
processAction (ProcessAccountInfo info) =
370
363
HasAccount passwd isAdmin -> do
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)
375
infoM "Clients" $ show clID ++ " is guest"
376
processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby
364
chan <- client's sendChan
365
mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]
367
processAction JoinLobby
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"]]
382
processAction (clID, serverInfo, clients, rooms) (MoveToLobby) =
383
foldM processAction (clID, serverInfo, clients, rooms) $
384
(RoomAddThisClient 0)
386
++ [SendServerMessage]
388
-- ++ (answerServerMessage client clients)
390
lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients
391
answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]
394
processAction (clID, serverInfo, clients, rooms) (KickClient kickID) =
395
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked")
398
processAction (clID, serverInfo, clients, rooms) (BanClient banNick) =
399
return (clID, serverInfo, clients, rooms)
402
processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do
403
writeChan (sendChan $ clients ! kickID) ["KICKED"]
404
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked")
407
processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) =
408
liftM2 replaceID (return clID) $
409
foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions
411
client = clients ! teamsClID
412
room = rooms ! (roomID client)
413
teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room
414
removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove
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/"]
422
let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo
424
if isJust $ host client `Prelude.lookup` newLogins then
425
processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast"
427
return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms)
430
processAction (clID, serverInfo, clients, rooms) PingAll = do
431
(_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients
434
Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients,
435
newRooms) $ AnswerAll ["PING"]
437
kickTimeouted (clID, serverInfo, clients, rooms) client =
438
if pingsQueue client > 0 then
439
processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout"
441
return (clID, serverInfo, clients, rooms)
444
processAction (clID, serverInfo, clients, rooms) (StatsAction) = do
445
writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)
446
return (clID, serverInfo, clients, rooms)
369
mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
370
chan <- client's sendChan
371
processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
374
processAction JoinLobby = do
375
chan <- client's sendChan
376
clientNick <- client's nick
377
(lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (nick &&& sendChan) . Prelude.filter logonPassed) $! allClientsS
378
mapM_ processAction $
379
AnswerClients clientsChans ["LOBBY:JOINED", clientNick]
380
: AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)
381
: [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
384
processAction (KickClient kickId) = do
385
modify (\s -> s{clientIndex = Just kickId})
386
clHost <- client's host
387
currentTime <- io getCurrentTime
388
mapM_ processAction [
389
AddIP2Bans clHost "60 seconds cooldown after kick" (addUTCTime 60 currentTime),
394
processAction (BanClient seconds reason banId) = do
395
modify (\s -> s{clientIndex = Just banId})
396
clHost <- client's host
397
currentTime <- io getCurrentTime
398
let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
399
mapM_ processAction [
400
AddIP2Bans clHost msg (addUTCTime seconds currentTime)
404
processAction (BanIP ip seconds reason) = do
405
currentTime <- io getCurrentTime
406
let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
408
AddIP2Bans ip msg (addUTCTime seconds currentTime)
410
processAction BanList = do
411
ch <- client's sendChan
412
bans <- gets (bans . serverInfo)
414
AnswerClients [ch] ["BANLIST", B.pack $ show bans]
418
processAction (KickRoomClient kickId) = do
419
modify (\s -> s{clientIndex = Just kickId})
420
ch <- client's sendChan
421
mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "kicked"]
424
processAction (AddClient cl) = do
425
rnc <- gets roomsClients
426
si <- gets serverInfo
428
ci <- addClient rnc cl
429
_ <- Exception.mask (forkIO . clientRecvLoop (clientSocket cl) (coreChan si) (sendChan cl) ci)
431
infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
435
modify (\s -> s{clientIndex = Just newClId})
438
AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion]
440
, AddIP2Bans (host cl) "Reconnected too fast" (addUTCTime 10 $ connectTime cl)
444
processAction (AddNick2Bans n reason expiring) = do
445
processAction $ ModifyServerInfo (\s -> s{bans = BanByNick n reason expiring : bans s})
447
processAction (AddIP2Bans ip reason expiring) = do
448
(Just ci) <- gets clientIndex
449
rc <- gets removedClients
450
when (not $ ci `Set.member` rc)
451
$ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s})
453
processAction CheckBanned = do
454
clTime <- client's connectTime
455
clNick <- client's nick
456
clHost <- client's host
457
si <- gets serverInfo
458
let validBans = filter (checkNotExpired clTime) $ bans si
459
let ban = L.find (checkBan clHost clNick) $ validBans
460
mapM_ processAction $
461
ModifyServerInfo (\s -> s{bans = validBans})
462
: [ByeClient (getBanReason $ fromJust ban) | isJust ban]
464
checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0
465
checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0
466
checkBan ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip
467
checkBan _ n (BanByNick bn _ _) = bn == n
468
getBanReason (BanByIP _ msg _) = msg
469
getBanReason (BanByNick _ msg _) = msg
471
processAction PingAll = do
472
rnc <- gets roomsClients
473
io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
474
cis <- io $ allClientsM rnc
475
chans <- io $ mapM (client'sM rnc sendChan) cis
476
io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
477
processAction $ AnswerClients chans ["PING"]
479
kickTimeouted rnc ci = do
480
pq <- io $ client'sM rnc pingsQueue ci
482
withStateT (\as -> as{clientIndex = Just ci}) $
483
processAction (ByeClient "Ping timeout")
486
processAction StatsAction = do
487
si <- gets serverInfo
488
when (not $ shutdownPending si) $ do
489
rnc <- gets roomsClients
490
(roomsNum, clientsNum) <- io $ withRoomsAndClients rnc st
491
io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
493
st irnc = (length $ allRooms irnc, length $ allClients irnc)
495
processAction RestartServer = do
496
sp <- gets (shutdownPending . serverInfo)
498
sock <- gets (fromJust . serverSocket . serverInfo)
499
args <- gets (runArgs . serverInfo)
501
noticeM "Core" "Closing listening socket"
503
noticeM "Core" "Spawning new server"
504
_ <- createProcess (proc "./hedgewars-server" args)
506
processAction $ ModifyServerInfo (\s -> s{shutdownPending = True})
508
processAction SaveReplay = do
510
rnc <- gets roomsClients
512
r <- room'sM rnc id ri
added
removed
gameServer/Actions.hs
