author | unc0rr |
Tue, 10 Mar 2009 21:57:33 +0000 | |
changeset 1883 | 7c7476f56114 |
parent 1879 | bb114339eb4e |
child 1921 | 2a09f7f786a0 |
permissions | -rw-r--r-- |
1804 | 1 |
module Actions where |
2 |
||
3 |
import Control.Concurrent.STM |
|
4 |
import Control.Concurrent.Chan |
|
5 |
import Data.IntMap |
|
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 |
10 |
----------------------------- |
|
11 |
import CoreTypes |
|
1813 | 12 |
import Utils |
1804 | 13 |
|
14 |
data Action = |
|
15 |
AnswerThisClient [String] |
|
16 |
| AnswerAll [String] |
|
17 |
| AnswerAllOthers [String] |
|
18 |
| AnswerThisRoom [String] |
|
19 |
| AnswerOthersInRoom [String] |
|
20 |
| AnswerLobby [String] |
|
21 |
| RoomAddThisClient Int -- roomID |
|
22 |
| RoomRemoveThisClient |
|
1813 | 23 |
| RemoveTeam String |
1804 | 24 |
| RemoveRoom |
1811 | 25 |
| UnreadyRoomClients |
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
26 |
| MoveToLobby |
1804 | 27 |
| ProtocolError String |
28 |
| Warning String |
|
29 |
| ByeClient String |
|
1862 | 30 |
| KickClient Int -- clID |
1879 | 31 |
| KickRoomClient Int -- clID |
32 |
| RemoveClientTeams Int -- clID |
|
1866 | 33 |
| BanClient String -- nick |
1804 | 34 |
| ModifyClient (ClientInfo -> ClientInfo) |
35 |
| ModifyRoom (RoomInfo -> RoomInfo) |
|
36 |
| AddRoom String String |
|
1834 | 37 |
| CheckRegistered |
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
38 |
| ProcessAccountInfo AccountInfo |
1804 | 39 |
| Dump |
40 |
||
41 |
type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action] |
|
42 |
||
1862 | 43 |
replaceID a (b, c, d, e) = (a, c, d, e) |
1804 | 44 |
|
45 |
processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms) |
|
46 |
||
47 |
||
48 |
processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do |
|
49 |
writeChan (sendChan $ clients ! clID) msg |
|
50 |
return (clID, serverInfo, clients, rooms) |
|
51 |
||
52 |
||
53 |
processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do |
|
54 |
mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) (keys clients) |
|
55 |
return (clID, serverInfo, clients, rooms) |
|
56 |
||
57 |
||
58 |
processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do |
|
1879 | 59 |
mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) $ |
60 |
Prelude.filter (\id' -> (id' /= clID) && (logonPassed $ clients ! id')) (keys clients) |
|
1804 | 61 |
return (clID, serverInfo, clients, rooms) |
62 |
||
63 |
||
64 |
processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do |
|
65 |
mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) roomClients |
|
66 |
return (clID, serverInfo, clients, rooms) |
|
67 |
where |
|
68 |
roomClients = IntSet.elems $ playersIDs room |
|
69 |
room = rooms ! rID |
|
70 |
rID = roomID client |
|
71 |
client = clients ! clID |
|
72 |
||
73 |
||
74 |
processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do |
|
75 |
mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) $ Prelude.filter (/= clID) roomClients |
|
76 |
return (clID, serverInfo, clients, rooms) |
|
77 |
where |
|
78 |
roomClients = IntSet.elems $ playersIDs room |
|
79 |
room = rooms ! rID |
|
80 |
rID = roomID client |
|
81 |
client = clients ! clID |
|
82 |
||
83 |
||
84 |
processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do |
|
85 |
mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) roomClients |
|
86 |
return (clID, serverInfo, clients, rooms) |
|
87 |
where |
|
88 |
roomClients = IntSet.elems $ playersIDs room |
|
89 |
room = rooms ! 0 |
|
90 |
||
91 |
||
92 |
processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do |
|
93 |
writeChan (sendChan $ clients ! clID) ["ERROR", msg] |
|
94 |
return (clID, serverInfo, clients, rooms) |
|
95 |
||
96 |
||
97 |
processAction (clID, serverInfo, clients, rooms) (Warning msg) = do |
|
98 |
writeChan (sendChan $ clients ! clID) ["WARNING", msg] |
|
99 |
return (clID, serverInfo, clients, rooms) |
|
100 |
||
101 |
||
102 |
processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do |
|
103 |
mapM_ (processAction (clID, serverInfo, clients, rooms)) $ answerOthersQuit ++ answerInformRoom |
|
104 |
writeChan (sendChan $ clients ! clID) ["BYE"] |
|
105 |
return ( |
|
106 |
0, |
|
107 |
serverInfo, |
|
108 |
delete clID clients, |
|
1823 | 109 |
adjust (\r -> r{ |
110 |
playersIDs = IntSet.delete clID (playersIDs r), |
|
111 |
playersIn = (playersIn r) - 1, |
|
112 |
readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r |
|
113 |
}) rID rooms |
|
1804 | 114 |
) |
115 |
where |
|
116 |
client = clients ! clID |
|
117 |
rID = roomID client |
|
118 |
clientNick = nick client |
|
119 |
answerInformRoom = |
|
120 |
if roomID client /= 0 then |
|
121 |
if not $ Prelude.null msg then |
|
122 |
[AnswerThisRoom ["LEFT", clientNick, msg]] |
|
123 |
else |
|
124 |
[AnswerThisRoom ["LEFT", clientNick]] |
|
125 |
else |
|
126 |
[] |
|
127 |
answerOthersQuit = |
|
1846 | 128 |
if logonPassed client then |
1804 | 129 |
if not $ Prelude.null msg then |
130 |
[AnswerAll ["LOBBY:LEFT", clientNick, msg]] |
|
131 |
else |
|
132 |
[AnswerAll ["LOBBY:LEFT", clientNick]] |
|
133 |
else |
|
134 |
[] |
|
135 |
||
136 |
||
137 |
processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = do |
|
138 |
return (clID, serverInfo, adjust func clID clients, rooms) |
|
139 |
||
140 |
||
141 |
processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = do |
|
142 |
return (clID, serverInfo, clients, adjust func rID rooms) |
|
143 |
where |
|
144 |
rID = roomID $ clients ! clID |
|
145 |
||
146 |
||
147 |
processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) = do |
|
148 |
processAction ( |
|
149 |
clID, |
|
150 |
serverInfo, |
|
151 |
adjust (\cl -> cl{roomID = rID}) clID clients, |
|
152 |
adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $ |
|
153 |
adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms |
|
154 |
) joinMsg |
|
155 |
where |
|
156 |
client = clients ! clID |
|
157 |
joinMsg = if rID == 0 then |
|
158 |
AnswerAllOthers ["LOBBY:JOINED", nick client] |
|
159 |
else |
|
160 |
AnswerThisRoom ["JOINED", nick client] |
|
161 |
||
162 |
||
163 |
processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient) = do |
|
164 |
when (rID /= 0) $ (processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["LEFT", nick client, "part"]) >> return () |
|
165 |
return ( |
|
166 |
clID, |
|
167 |
serverInfo, |
|
168 |
adjust (\cl -> cl{roomID = 0}) clID clients, |
|
1823 | 169 |
adjust (\r -> r{ |
170 |
playersIDs = IntSet.delete clID (playersIDs r), |
|
171 |
playersIn = (playersIn r) - 1, |
|
1827 | 172 |
readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r |
1823 | 173 |
}) rID $ |
1804 | 174 |
adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r)}) 0 rooms |
175 |
) |
|
176 |
where |
|
177 |
rID = roomID client |
|
178 |
client = clients ! clID |
|
179 |
||
180 |
||
181 |
processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do |
|
182 |
let newServerInfo = serverInfo {nextRoomID = newID} |
|
183 |
let room = newRoom{ |
|
184 |
roomUID = newID, |
|
185 |
name = roomName, |
|
186 |
password = roomPassword, |
|
187 |
roomProto = (clientProto client) |
|
188 |
} |
|
189 |
||
190 |
processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName] |
|
191 |
||
192 |
processAction ( |
|
193 |
clID, |
|
194 |
newServerInfo, |
|
195 |
adjust (\cl -> cl{isMaster = True}) clID clients, |
|
196 |
insert newID room rooms |
|
197 |
) $ RoomAddThisClient newID |
|
198 |
where |
|
199 |
newID = (nextRoomID serverInfo) - 1 |
|
200 |
client = clients ! clID |
|
201 |
||
202 |
||
203 |
processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do |
|
1811 | 204 |
processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room] |
205 |
processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room] |
|
1804 | 206 |
return (clID, |
207 |
serverInfo, |
|
1827 | 208 |
Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False} else cl) clients, |
1811 | 209 |
delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms |
1804 | 210 |
) |
211 |
where |
|
1811 | 212 |
room = rooms ! rID |
1804 | 213 |
rID = roomID client |
214 |
client = clients ! clID |
|
215 |
||
1813 | 216 |
|
1811 | 217 |
processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do |
218 |
processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers) |
|
219 |
return (clID, |
|
220 |
serverInfo, |
|
221 |
Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients, |
|
1827 | 222 |
adjust (\r -> r{readyPlayers = 0}) rID rooms) |
1811 | 223 |
where |
224 |
room = rooms ! rID |
|
225 |
rID = roomID client |
|
226 |
client = clients ! clID |
|
227 |
roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs |
|
228 |
roomPlayersIDs = IntSet.elems $ playersIDs room |
|
229 |
||
230 |
||
1813 | 231 |
processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do |
232 |
newRooms <- if not $ gameinprogress room then |
|
233 |
do |
|
234 |
processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName] |
|
235 |
return $ |
|
236 |
adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms |
|
237 |
else |
|
238 |
do |
|
1866 | 239 |
processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg] |
1813 | 240 |
return $ |
241 |
adjust (\r -> r{ |
|
242 |
teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, |
|
243 |
leftTeams = teamName : leftTeams r, |
|
244 |
roundMsgs = roundMsgs r Seq.|> rmTeamMsg |
|
245 |
}) rID rooms |
|
246 |
return (clID, serverInfo, clients, newRooms) |
|
247 |
where |
|
248 |
room = rooms ! rID |
|
249 |
rID = roomID client |
|
250 |
client = clients ! clID |
|
251 |
rmTeamMsg = toEngineMsg $ 'F' : teamName |
|
252 |
||
253 |
||
1834 | 254 |
processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do |
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
255 |
writeChan (dbQueries serverInfo) $ CheckAccount clID (nick client) |
1834 | 256 |
return (clID, serverInfo, clients, rooms) |
257 |
where |
|
258 |
client = clients ! clID |
|
259 |
||
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
260 |
|
1804 | 261 |
processAction (clID, serverInfo, clients, rooms) (Dump) = do |
262 |
writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] |
|
263 |
return (clID, serverInfo, clients, rooms) |
|
264 |
||
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
265 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
266 |
processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) = do |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
267 |
case info of |
1847
2178c0fc838c
Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents:
1846
diff
changeset
|
268 |
HasAccount passwd isAdmin -> do |
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
269 |
infoM "Clients" $ show clID ++ " has account" |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
270 |
writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"] |
1847
2178c0fc838c
Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents:
1846
diff
changeset
|
271 |
return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms) |
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
272 |
Guest -> do |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
273 |
infoM "Clients" $ show clID ++ " is guest" |
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
274 |
processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
275 |
|
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
276 |
|
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
277 |
processAction (clID, serverInfo, clients, rooms) (MoveToLobby) = do |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
278 |
foldM processAction (clID, serverInfo, clients, rooms) $ |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
279 |
(RoomAddThisClient 0) |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
280 |
: answerLobbyNicks |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
281 |
-- ++ (answerServerMessage client clients) |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
282 |
where |
1846 | 283 |
lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients |
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
284 |
answerLobbyNicks = if not $ Prelude.null lobbyNicks then |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
285 |
[AnswerThisClient (["LOBBY:JOINED"] ++ lobbyNicks)] |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
286 |
else |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
287 |
[] |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
288 |
|
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
289 |
|
1862 | 290 |
processAction (clID, serverInfo, clients, rooms) (KickClient kickID) = do |
1879 | 291 |
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked") |
292 |
||
293 |
||
294 |
processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do |
|
295 |
writeChan (sendChan $ clients ! kickID) ["KICKED"] |
|
296 |
liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient) |
|
297 |
||
298 |
||
299 |
processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) = do |
|
300 |
liftM2 replaceID (return clID) $ |
|
301 |
foldM processAction (teamsClID, serverInfo, clients, rooms) $ removeTeamsActions |
|
302 |
where |
|
303 |
client = clients ! teamsClID |
|
304 |
room = rooms ! (roomID client) |
|
305 |
teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room |
|
306 |
removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove |