author | koda |
Fri, 13 Aug 2010 02:44:44 +0200 | |
changeset 3738 | f10626e18b8a |
parent 3673 | 45778b16b224 |
child 3741 | 73246d25dfe1 |
permissions | -rw-r--r-- |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
1 |
{-# LANGUAGE OverloadedStrings #-} |
1804 | 2 |
module Actions where |
3 |
||
3425 | 4 |
import Control.Concurrent |
1804 | 5 |
import Control.Concurrent.Chan |
6 |
import qualified Data.IntSet as IntSet |
|
3566 | 7 |
import qualified Data.Set as Set |
1813 | 8 |
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
|
9 |
import System.Log.Logger |
3671
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3658
diff
changeset
|
10 |
import Control.Monad |
1926
cb46fbdcaa41
Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents:
1925
diff
changeset
|
11 |
import Data.Time |
3671
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3658
diff
changeset
|
12 |
import Data.Maybe |
3435 | 13 |
import Control.Monad.Reader |
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
14 |
import Control.Monad.State |
3502 | 15 |
import qualified Data.ByteString.Char8 as B |
1804 | 16 |
----------------------------- |
17 |
import CoreTypes |
|
1813 | 18 |
import Utils |
3425 | 19 |
import ClientIO |
3458 | 20 |
import ServerState |
1804 | 21 |
|
22 |
data Action = |
|
3566 | 23 |
AnswerClients ![ClientChan] ![B.ByteString] |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
24 |
| SendServerMessage |
3283 | 25 |
| SendServerVars |
3502 | 26 |
| MoveToRoom RoomIndex |
3531 | 27 |
| MoveToLobby B.ByteString |
3502 | 28 |
| RemoveTeam B.ByteString |
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 |
3502 | 31 |
| JoinLobby |
32 |
| ProtocolError B.ByteString |
|
33 |
| Warning B.ByteString |
|
34 |
| ByeClient B.ByteString |
|
35 |
| KickClient ClientIndex |
|
36 |
| KickRoomClient ClientIndex |
|
37 |
| BanClient B.ByteString -- nick |
|
38 |
| RemoveClientTeams ClientIndex |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
39 |
| ModifyClient (ClientInfo -> ClientInfo) |
3458 | 40 |
| ModifyClient2 ClientIndex (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) |
3502 | 43 |
| AddRoom B.ByteString B.ByteString |
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 |
3566 | 49 |
| DeleteClient ClientIndex |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
50 |
| PingAll |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
51 |
| StatsAction |
1804 | 52 |
|
3502 | 53 |
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] |
1804 | 54 |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
55 |
|
3458 | 56 |
processAction :: Action -> StateT ServerState IO () |
1804 | 57 |
|
58 |
||
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
59 |
processAction (AnswerClients chans msg) = do |
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
60 |
liftIO (putStr $ "AnswerClients... " ++ (show $ length chans) ++ " (" ++ (show msg) ++")") |
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
61 |
liftIO $ map (flip seq ()) chans `seq` mapM_ (flip writeChan msg) chans |
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
62 |
liftIO (putStrLn "done") |
1804 | 63 |
|
64 |
||
3501 | 65 |
processAction SendServerMessage = do |
66 |
chan <- client's sendChan |
|
67 |
protonum <- client's clientProto |
|
68 |
si <- liftM serverInfo get |
|
69 |
let message = if protonum < latestReleaseVersion si then |
|
3283 | 70 |
serverMessageForOldVersions si |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
71 |
else |
3283 | 72 |
serverMessage si |
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
73 |
processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message] |
3501 | 74 |
{- |
3283 | 75 |
|
3425 | 76 |
processAction (clID, serverInfo, rnc) SendServerVars = do |
3283 | 77 |
writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars) |
3425 | 78 |
return (clID, serverInfo, rnc) |
3283 | 79 |
where |
80 |
client = clients ! clID |
|
81 |
vars = [ |
|
3425 | 82 |
"MOTD_NEW", serverMessage serverInfo, |
83 |
"MOTD_OLD", serverMessageForOldVersions serverInfo, |
|
3283 | 84 |
"LATEST_PROTO", show $ latestReleaseVersion serverInfo |
85 |
] |
|
1923 | 86 |
|
87 |
||
3501 | 88 |
-} |
89 |
||
90 |
processAction (ProtocolError msg) = do |
|
91 |
chan <- client's sendChan |
|
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
92 |
processAction $ AnswerClients [chan] ["ERROR", msg] |
1804 | 93 |
|
94 |
||
3501 | 95 |
processAction (Warning msg) = do |
96 |
chan <- client's sendChan |
|
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
97 |
processAction $ AnswerClients [chan] ["WARNING", msg] |
1804 | 98 |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
99 |
processAction (ByeClient msg) = do |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
100 |
(Just ci) <- gets clientIndex |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
101 |
rnc <- gets roomsClients |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
102 |
ri <- clientRoomA |
3436
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
103 |
when (ri /= lobbyId) $ do |
3531 | 104 |
processAction $ MoveToLobby ("quit: " `B.append` msg) |
3436
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
105 |
return () |
1929 | 106 |
|
3501 | 107 |
chan <- client's sendChan |
3566 | 108 |
ready <- client's isReady |
3458 | 109 |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
110 |
liftIO $ do |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
111 |
infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg)) |
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
112 |
|
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
113 |
--mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
114 |
modifyRoom rnc (\r -> r{ |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
115 |
--playersIDs = IntSet.delete ci (playersIDs r) |
3566 | 116 |
playersIn = (playersIn r) - 1, |
117 |
readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
118 |
}) ri |
3566 | 119 |
|
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
120 |
processAction $ AnswerClients [chan] ["BYE", msg] |
3566 | 121 |
modify (\s -> s{removedClients = ci `Set.insert` removedClients s}) |
122 |
||
123 |
processAction (DeleteClient ci) = do |
|
3671
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3658
diff
changeset
|
124 |
rnc <- gets roomsClients |
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3658
diff
changeset
|
125 |
liftIO $ removeClient rnc ci |
3566 | 126 |
modify (\s -> s{removedClients = ci `Set.delete` removedClients s}) |
127 |
||
3436
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
128 |
{- |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
129 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
130 |
client = clients ! clID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
131 |
clientNick = nick client |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
132 |
answerInformRoom = |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
133 |
if roomID client /= 0 then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
134 |
if not $ Prelude.null msg then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
135 |
[AnswerThisRoom ["LEFT", clientNick, msg]] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
136 |
else |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
137 |
[AnswerThisRoom ["LEFT", clientNick]] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
138 |
else |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
139 |
[] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
140 |
answerOthersQuit = |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
141 |
if logonPassed client then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
142 |
if not $ Prelude.null msg then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
143 |
[AnswerAll ["LOBBY:LEFT", clientNick, msg]] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
144 |
else |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
145 |
[AnswerAll ["LOBBY:LEFT", clientNick]] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
146 |
else |
3436
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
147 |
[] |
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
148 |
-} |
1804 | 149 |
|
3458 | 150 |
processAction (ModifyClient f) = do |
151 |
(Just ci) <- gets clientIndex |
|
152 |
rnc <- gets roomsClients |
|
153 |
liftIO $ modifyClient rnc f ci |
|
154 |
return () |
|
3568 | 155 |
|
156 |
processAction (ModifyClient2 ci f) = do |
|
157 |
rnc <- gets roomsClients |
|
158 |
liftIO $ modifyClient rnc f ci |
|
159 |
return () |
|
160 |
||
1804 | 161 |
|
3458 | 162 |
processAction (ModifyRoom f) = do |
163 |
rnc <- gets roomsClients |
|
164 |
ri <- clientRoomA |
|
165 |
liftIO $ modifyRoom rnc f ri |
|
166 |
return () |
|
2403 | 167 |
|
3458 | 168 |
{- |
1804 | 169 |
|
3425 | 170 |
processAction (clID, serverInfo, rnc) (ModifyServerInfo func) = |
171 |
return (clID, func serverInfo, rnc) |
|
1925 | 172 |
|
3502 | 173 |
-} |
1925 | 174 |
|
3531 | 175 |
processAction (MoveToRoom ri) = do |
3502 | 176 |
(Just ci) <- gets clientIndex |
177 |
rnc <- gets roomsClients |
|
178 |
liftIO $ do |
|
179 |
modifyClient rnc (\cl -> cl{teamsInGame = 0}) ci |
|
3531 | 180 |
modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri |
181 |
||
182 |
liftIO $ moveClientToRoom rnc ri ci |
|
183 |
||
184 |
chans <- liftM (map sendChan) $ roomClientsS ri |
|
3502 | 185 |
clNick <- client's nick |
3645 | 186 |
|
3502 | 187 |
processAction $ AnswerClients chans ["JOINED", clNick] |
1804 | 188 |
|
3531 | 189 |
processAction (MoveToLobby msg) = do |
190 |
(Just ci) <- gets clientIndex |
|
191 |
--ri <- clientRoomA |
|
192 |
rnc <- gets roomsClients |
|
193 |
||
194 |
liftIO $ moveClientToLobby rnc ci |
|
195 |
||
3502 | 196 |
{- |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
197 |
(_, _, newClients, newRooms) <- |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
198 |
if isMaster client then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
199 |
if (gameinprogress room) && (playersIn room > 1) then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
200 |
(changeMaster >>= (\state -> foldM processAction state |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
201 |
[AnswerOthersInRoom ["LEFT", nick client, msg], |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
202 |
AnswerOthersInRoom ["WARNING", "Admin left the room"], |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
203 |
RemoveClientTeams clID])) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
204 |
else -- not in game |
3425 | 205 |
processAction (clID, serverInfo, rnc) RemoveRoom |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
206 |
else -- not master |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
207 |
foldM |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
208 |
processAction |
3425 | 209 |
(clID, serverInfo, rnc) |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
210 |
[AnswerOthersInRoom ["LEFT", nick client, msg], |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
211 |
RemoveClientTeams clID] |
3531 | 212 |
|
3425 | 213 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
214 |
return ( |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
215 |
clID, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
216 |
serverInfo, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
217 |
adjust resetClientFlags clID newClients, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
218 |
adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
219 |
) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
220 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
221 |
rID = roomID client |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
222 |
client = clients ! clID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
223 |
room = rooms ! rID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
224 |
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
|
225 |
removeClientFromRoom r = r{ |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
226 |
playersIDs = otherPlayersSet, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
227 |
playersIn = (playersIn r) - 1, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
228 |
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
|
229 |
} |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
230 |
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
|
231 |
changeMaster = do |
3425 | 232 |
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
|
233 |
return ( |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
234 |
clID, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
235 |
serverInfo, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
236 |
adjust (\cl -> cl{isMaster = True}) newMasterId clients, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
237 |
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
|
238 |
) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
239 |
newRoomName = nick newMasterClient |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
240 |
otherPlayersSet = IntSet.delete clID (playersIDs room) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
241 |
newMasterId = IntSet.findMin otherPlayersSet |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
242 |
newMasterClient = clients ! newMasterId |
3502 | 243 |
-} |
1804 | 244 |
|
3502 | 245 |
processAction (AddRoom roomName roomPassword) = do |
3566 | 246 |
Just clId <- gets clientIndex |
247 |
rnc <- gets roomsClients |
|
3502 | 248 |
proto <- liftIO $ client'sM rnc clientProto clId |
3645 | 249 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
250 |
let room = newRoom{ |
3502 | 251 |
masterID = clId, |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
252 |
name = roomName, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
253 |
password = roomPassword, |
3502 | 254 |
roomProto = proto |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
255 |
} |
3645 | 256 |
|
257 |
rId <- liftIO $ addRoom rnc room |
|
258 |
||
259 |
processAction $ MoveToRoom rId |
|
260 |
||
3502 | 261 |
chans <- liftM (map sendChan) $ roomClientsS lobbyId |
1804 | 262 |
|
3502 | 263 |
mapM_ processAction [ |
264 |
AnswerClients chans ["ROOM", "ADD", roomName] |
|
265 |
, ModifyClient (\cl -> cl{isMaster = True}) |
|
3645 | 266 |
] |
1804 | 267 |
|
3502 | 268 |
{- |
3425 | 269 |
processAction (clID, serverInfo, rnc) (RemoveRoom) = do |
270 |
processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "DEL", name room] |
|
271 |
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
|
272 |
return (clID, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
273 |
serverInfo, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
274 |
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
|
275 |
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
|
276 |
) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
277 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
278 |
room = rooms ! rID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
279 |
rID = roomID client |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
280 |
client = clients ! clID |
1804 | 281 |
|
3656 | 282 |
-} |
283 |
processAction (UnreadyRoomClients) = do |
|
284 |
rnc <- gets roomsClients |
|
285 |
ri <- clientRoomA |
|
286 |
roomPlayers <- roomClientsS ri |
|
287 |
roomClIDs <- liftIO $ roomClientsIndicesM rnc ri |
|
288 |
processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers) |
|
289 |
liftIO $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs |
|
290 |
processAction $ ModifyRoom (\r -> r{readyPlayers = 0}) |
|
1813 | 291 |
|
1811 | 292 |
|
3645 | 293 |
processAction (RemoveTeam teamName) = do |
294 |
rnc <- gets roomsClients |
|
295 |
cl <- client's id |
|
296 |
ri <- clientRoomA |
|
297 |
inGame <- liftIO $ room'sM rnc gameinprogress ri |
|
298 |
chans <- liftM (map sendChan . filter (/= cl)) $ roomClientsS ri |
|
299 |
if inGame then |
|
300 |
mapM_ processAction [ |
|
301 |
AnswerClients chans ["REMOVE_TEAM", teamName], |
|
302 |
ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) |
|
303 |
] |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
304 |
else |
3645 | 305 |
mapM_ processAction [ |
306 |
AnswerClients chans ["EM", rmTeamMsg], |
|
307 |
ModifyRoom (\r -> r{ |
|
308 |
teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, |
|
309 |
leftTeams = teamName : leftTeams r, |
|
310 |
roundMsgs = roundMsgs r Seq.|> rmTeamMsg |
|
311 |
}) |
|
312 |
] |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
313 |
where |
3645 | 314 |
rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName |
1813 | 315 |
|
3458 | 316 |
processAction CheckRegistered = do |
317 |
(Just ci) <- gets clientIndex |
|
3501 | 318 |
n <- client's nick |
319 |
h <- client's host |
|
3458 | 320 |
db <- gets (dbQueries . serverInfo) |
321 |
liftIO $ writeChan db $ CheckAccount ci n h |
|
322 |
return () |
|
1834 | 323 |
|
3458 | 324 |
{- |
3425 | 325 |
processAction (clID, serverInfo, rnc) (ClearAccountsCache) = do |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
326 |
writeChan (dbQueries serverInfo) ClearCache |
3425 | 327 |
return (clID, serverInfo, rnc) |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
328 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
329 |
client = clients ! clID |
2155
d897222d3339
Implement ability for server admin to clear accounts cache
unc0rr
parents:
2126
diff
changeset
|
330 |
|
d897222d3339
Implement ability for server admin to clear accounts cache
unc0rr
parents:
2126
diff
changeset
|
331 |
|
3425 | 332 |
processAction (clID, serverInfo, rnc) (Dump) = do |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
333 |
writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] |
3425 | 334 |
return (clID, serverInfo, rnc) |
3501 | 335 |
-} |
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
336 |
|
3501 | 337 |
processAction (ProcessAccountInfo info) = |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
338 |
case info of |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
339 |
HasAccount passwd isAdmin -> do |
3501 | 340 |
chan <- client's sendChan |
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
341 |
processAction $ AnswerClients [chan] ["ASKPASSWORD"] |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
342 |
Guest -> do |
3502 | 343 |
processAction JoinLobby |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
344 |
Admin -> do |
3502 | 345 |
mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] |
3501 | 346 |
chan <- client's sendChan |
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
347 |
processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] |
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
348 |
|
3502 | 349 |
|
350 |
processAction JoinLobby = do |
|
3501 | 351 |
chan <- client's sendChan |
3502 | 352 |
clientNick <- client's nick |
3566 | 353 |
(lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) $! allClientsS |
3501 | 354 |
mapM_ processAction $ |
3502 | 355 |
(AnswerClients clientsChans ["LOBBY:JOINED", clientNick]) |
3566 | 356 |
: [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)] |
3502 | 357 |
++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage] |
2118
0ebcc98ebc1a
Send server message after nicks info (more chance for it to be seen)
unc0rr
parents:
2116
diff
changeset
|
358 |
|
3501 | 359 |
{- |
3502 | 360 |
processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) = |
361 |
processAction ( |
|
362 |
clID, |
|
363 |
serverInfo, |
|
364 |
adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients, |
|
365 |
adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $ |
|
366 |
adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms |
|
367 |
) joinMsg |
|
368 |
where |
|
369 |
client = clients ! clID |
|
370 |
joinMsg = if rID == 0 then |
|
371 |
AnswerAllOthers ["LOBBY:JOINED", nick client] |
|
372 |
else |
|
373 |
AnswerThisRoom ["JOINED", nick client] |
|
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
374 |
|
3425 | 375 |
processAction (clID, serverInfo, rnc) (KickClient kickID) = |
376 |
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked") |
|
1879 | 377 |
|
1926
cb46fbdcaa41
Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents:
1925
diff
changeset
|
378 |
|
3425 | 379 |
processAction (clID, serverInfo, rnc) (BanClient banNick) = |
380 |
return (clID, serverInfo, rnc) |
|
1921 | 381 |
|
1879 | 382 |
|
3425 | 383 |
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
|
384 |
writeChan (sendChan $ clients ! kickID) ["KICKED"] |
3425 | 385 |
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked") |
1879 | 386 |
|
387 |
||
3425 | 388 |
processAction (clID, serverInfo, rnc) (RemoveClientTeams teamsClID) = |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
389 |
liftM2 replaceID (return clID) $ |
3425 | 390 |
foldM processAction (teamsClID, serverInfo, rnc) removeTeamsActions |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
391 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
392 |
client = clients ! teamsClID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
393 |
room = rooms ! (roomID client) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
394 |
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
|
395 |
removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove |
3435 | 396 |
-} |
1926
cb46fbdcaa41
Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents:
1925
diff
changeset
|
397 |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
398 |
processAction (AddClient client) = do |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
399 |
rnc <- gets roomsClients |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
400 |
si <- gets serverInfo |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
401 |
liftIO $ do |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
402 |
ci <- addClient rnc client |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
403 |
forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
404 |
forkIO $ clientSendLoop (clientSocket client) (coreChan si) (sendChan client) ci |
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
405 |
|
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
406 |
infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client)) |
3425 | 407 |
|
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
408 |
processAction $ AnswerClients [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
|
409 |
{- 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
|
410 |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
411 |
if False && (isJust $ host client `Prelude.lookup` newLogins) then |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
412 |
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
|
413 |
else |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
414 |
return (ci, serverInfo) |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
415 |
-} |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
416 |
|
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3436
diff
changeset
|
417 |
|
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
418 |
|
3654 | 419 |
processAction PingAll = do |
420 |
rnc <- gets roomsClients |
|
3658
113cb9345be1
Make server stay alive when some clients get kicked
unc0rr
parents:
3656
diff
changeset
|
421 |
liftIO (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) |
3654 | 422 |
cis <- liftIO $ allClientsM rnc |
423 |
chans <- liftIO $ mapM (client'sM rnc sendChan) cis |
|
424 |
liftIO $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis |
|
425 |
processAction $ AnswerClients chans ["PING"] |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2662
diff
changeset
|
426 |
where |
3654 | 427 |
kickTimeouted rnc ci = do |
428 |
pq <- liftIO $ client'sM rnc pingsQueue ci |
|
429 |
when (pq > 0) $ |
|
430 |
withStateT (\as -> as{clientIndex = Just ci}) $ |
|
431 |
processAction (ByeClient "Ping timeout") |
|
2172 | 432 |
|
433 |
||
3653 | 434 |
processAction (StatsAction) = do |
435 |
rnc <- gets roomsClients |
|
436 |
si <- gets serverInfo |
|
437 |
(roomsNum, clientsNum) <- liftIO $ withRoomsAndClients rnc stats |
|
438 |
liftIO $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1) |
|
439 |
where |
|
440 |
stats irnc = (length $ allRooms irnc, length $ allClients irnc) |
|
3425 | 441 |