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