|
1 {-# LANGUAGE OverloadedStrings #-} |
1 module HWProtoLobbyState where |
2 module HWProtoLobbyState where |
2 |
3 |
3 import qualified Data.Map as Map |
4 import qualified Data.Map as Map |
4 import qualified Data.IntMap as IntMap |
|
5 import qualified Data.IntSet as IntSet |
5 import qualified Data.IntSet as IntSet |
6 import qualified Data.Foldable as Foldable |
6 import qualified Data.Foldable as Foldable |
7 import Data.Maybe |
7 import Data.Maybe |
8 import Data.List |
8 import Data.List |
9 import Data.Word |
9 import Data.Word |
|
10 import Control.Monad.Reader |
|
11 import qualified Data.ByteString.Char8 as B |
|
12 import Control.DeepSeq |
10 -------------------------------------- |
13 -------------------------------------- |
11 import CoreTypes |
14 import CoreTypes |
12 import Actions |
15 import Actions |
13 import Utils |
16 import Utils |
|
17 import HandlerUtils |
|
18 import RoomsAndClients |
14 |
19 |
15 answerAllTeams protocol teams = concatMap toAnswer teams |
20 answerAllTeams cl = concatMap toAnswer |
16 where |
21 where |
|
22 clChan = sendChan cl |
17 toAnswer team = |
23 toAnswer team = |
18 [AnswerThisClient $ teamToNet protocol team, |
24 [AnswerClients [clChan] $ teamToNet team, |
19 AnswerThisClient ["TEAM_COLOR", teamname team, teamcolor team], |
25 AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team], |
20 AnswerThisClient ["HH_NUM", teamname team, show $ hhnum team]] |
26 AnswerClients [clChan] ["HH_NUM", teamname team, B.pack . show $ hhnum team]] |
21 |
27 |
22 handleCmd_lobby :: CmdHandler |
28 handleCmd_lobby :: CmdHandler |
23 |
29 |
24 handleCmd_lobby clID clients rooms ["LIST"] = |
30 |
25 [AnswerThisClient ("ROOMS" : roomsInfoList)] |
31 handleCmd_lobby ["LIST"] = do |
|
32 (ci, irnc) <- ask |
|
33 let cl = irnc `client` ci |
|
34 rooms <- allRoomInfos |
|
35 let roomsInfoList = concatMap (roomInfo irnc) . filter (\r -> (roomProto r == clientProto cl) && not (isRestrictedJoins r)) |
|
36 return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)] |
26 where |
37 where |
27 roomsInfoList = concatMap roomInfo sameProtoRooms |
38 roomInfo irnc room = [ |
28 sameProtoRooms = filter (\r -> (roomProto r == protocol) && not (isRestrictedJoins r)) roomsList |
39 showB $ gameinprogress room, |
29 roomsList = IntMap.elems rooms |
|
30 protocol = clientProto client |
|
31 client = clients IntMap.! clID |
|
32 roomInfo room |
|
33 | clientProto client < 28 = [ |
|
34 name room, |
40 name room, |
35 show (playersIn room) ++ "(" ++ show (length $ teams room) ++ ")", |
41 showB $ playersIn room, |
36 show $ gameinprogress room |
42 showB $ length $ teams room, |
37 ] |
43 nick $ irnc `client` masterID room, |
38 | otherwise = [ |
|
39 show $ gameinprogress room, |
|
40 name room, |
|
41 show $ playersIn room, |
|
42 show $ length $ teams room, |
|
43 nick $ clients IntMap.! (masterID room), |
|
44 head (Map.findWithDefault ["+gen+"] "MAP" (params room)), |
44 head (Map.findWithDefault ["+gen+"] "MAP" (params room)), |
45 head (Map.findWithDefault ["Default"] "SCHEME" (params room)), |
45 head (Map.findWithDefault ["Default"] "SCHEME" (params room)), |
46 head (Map.findWithDefault ["Default"] "AMMO" (params room)) |
46 head (Map.findWithDefault ["Default"] "AMMO" (params room)) |
47 ] |
47 ] |
48 |
48 |
49 handleCmd_lobby clID clients _ ["CHAT", msg] = |
49 |
50 [AnswerOthersInRoom ["CHAT", clientNick, msg]] |
50 handleCmd_lobby ["CHAT", msg] = do |
51 where |
51 n <- clientNick |
52 clientNick = nick $ clients IntMap.! clID |
52 s <- roomOthersChans |
|
53 return [AnswerClients s ["CHAT", n, msg]] |
|
54 |
|
55 handleCmd_lobby ["CREATE_ROOM", newRoom, roomPassword] |
|
56 | illegalName newRoom = return [Warning "Illegal room name"] |
|
57 | otherwise = do |
|
58 rs <- allRoomInfos |
|
59 cl <- thisClient |
|
60 return $ if isJust $ find (\room -> newRoom == name room) rs then |
|
61 [Warning "Room exists"] |
|
62 else |
|
63 [ |
|
64 AddRoom newRoom roomPassword, |
|
65 AnswerClients [sendChan cl] ["NOT_READY", nick cl] |
|
66 ] |
53 |
67 |
54 |
68 |
55 handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, roomPassword] |
69 handleCmd_lobby ["CREATE_ROOM", newRoom] = |
56 | haveSameRoom = [Warning "Room exists"] |
70 handleCmd_lobby ["CREATE_ROOM", newRoom, ""] |
57 | illegalName newRoom = [Warning "Illegal room name"] |
|
58 | otherwise = |
|
59 [RoomRemoveThisClient "", -- leave lobby |
|
60 AddRoom newRoom roomPassword, |
|
61 AnswerThisClient ["NOT_READY", clientNick] |
|
62 ] |
|
63 where |
|
64 clientNick = nick $ clients IntMap.! clID |
|
65 haveSameRoom = isJust $ find (\room -> newRoom == name room) $ IntMap.elems rooms |
|
66 |
71 |
67 |
72 |
68 handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom] = |
73 handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do |
69 handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, ""] |
74 (ci, irnc) <- ask |
|
75 let ris = allRooms irnc |
|
76 cl <- thisClient |
|
77 let maybeRI = find (\ri -> roomName == name (irnc `room` ri)) ris |
|
78 let jRI = fromJust maybeRI |
|
79 let jRoom = irnc `room` jRI |
|
80 let jRoomClients = map (client irnc) $ roomClients irnc jRI |
|
81 let nicks = map nick jRoomClients |
|
82 let chans = map sendChan (cl : jRoomClients) |
|
83 return $ |
|
84 if isNothing maybeRI then |
|
85 [Warning "No such rooms"] |
|
86 else if isRestrictedJoins jRoom then |
|
87 [Warning "Joining restricted"] |
|
88 else if roomPassword /= password jRoom then |
|
89 [Warning "Wrong password"] |
|
90 else |
|
91 [ |
|
92 MoveToRoom jRI, |
|
93 AnswerClients [sendChan cl] $ "JOINED" : nicks, |
|
94 AnswerClients chans ["NOT_READY", nick cl] |
|
95 ] |
|
96 ++ (map (readynessMessage cl) jRoomClients) |
|
97 ++ (answerFullConfig cl $ params jRoom) |
|
98 ++ (answerTeams cl jRoom) |
|
99 ++ (watchRound cl jRoom) |
|
100 |
|
101 where |
|
102 readynessMessage cl c = AnswerClients [sendChan cl] [if isReady c then "READY" else "NOT_READY", nick c] |
|
103 |
|
104 toAnswer cl (paramName, paramStrs) = AnswerClients [sendChan cl] $ "CFG" : paramName : paramStrs |
|
105 |
|
106 answerFullConfig cl params = map (toAnswer cl) (leftConfigPart ++ rightConfigPart) |
|
107 where |
|
108 (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p /= "MAP") $ Map.toList params |
|
109 |
|
110 answerTeams cl jRoom = let f = if gameinprogress jRoom then teamsAtStart else teams in answerAllTeams cl $ f jRoom |
|
111 |
|
112 watchRound cl jRoom = if not $ gameinprogress jRoom then |
|
113 [] |
|
114 else |
|
115 [AnswerClients [sendChan cl] ["RUN_GAME"], |
|
116 AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)] |
70 |
117 |
71 |
118 |
72 handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, roomPassword] |
119 handleCmd_lobby ["JOIN_ROOM", roomName] = |
73 | noSuchRoom = [Warning "No such room"] |
120 handleCmd_lobby ["JOIN_ROOM", roomName, ""] |
74 | isRestrictedJoins jRoom = [Warning "Joining restricted"] |
|
75 | roomPassword /= password jRoom = [Warning "Wrong password"] |
|
76 | otherwise = |
|
77 [RoomRemoveThisClient "", -- leave lobby |
|
78 RoomAddThisClient rID] -- join room |
|
79 ++ answerNicks |
|
80 ++ answerReady |
|
81 ++ [AnswerThisRoom ["NOT_READY", nick client]] |
|
82 ++ answerFullConfig |
|
83 ++ answerTeams |
|
84 ++ watchRound |
|
85 where |
|
86 noSuchRoom = isNothing mbRoom |
|
87 mbRoom = find (\r -> roomName == name r && roomProto r == clientProto client) $ IntMap.elems rooms |
|
88 jRoom = fromJust mbRoom |
|
89 rID = roomUID jRoom |
|
90 client = clients IntMap.! clID |
|
91 roomClientsIDs = IntSet.elems $ playersIDs jRoom |
|
92 answerNicks = |
|
93 [AnswerThisClient $ "JOINED" : |
|
94 map (\clID -> nick $ clients IntMap.! clID) roomClientsIDs | playersIn jRoom /= 0] |
|
95 answerReady = map |
|
96 ((\ c -> |
|
97 AnswerThisClient |
|
98 [if isReady c then "READY" else "NOT_READY", nick c]) |
|
99 . (\ clID -> clients IntMap.! clID)) |
|
100 roomClientsIDs |
|
101 |
|
102 toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs |
|
103 |
|
104 answerFullConfig = map toAnswer ((Data.List.reverse . Data.List.sort $ leftConfigPart) ++ rightConfigPart) |
|
105 (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p == "MAP" || p == "MAPGEN" || p == "SCHEME") (Map.toList $ params jRoom) |
|
106 |
|
107 watchRound = if not $ gameinprogress jRoom then |
|
108 [] |
|
109 else |
|
110 [AnswerThisClient ["RUN_GAME"], |
|
111 AnswerThisClient $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)] |
|
112 |
|
113 answerTeams = if gameinprogress jRoom then |
|
114 answerAllTeams (clientProto client) (teamsAtStart jRoom) |
|
115 else |
|
116 answerAllTeams (clientProto client) (teams jRoom) |
|
117 |
121 |
118 |
122 |
119 handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName] = |
123 handleCmd_lobby ["FOLLOW", asknick] = do |
120 handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, ""] |
124 (_, rnc) <- ask |
121 |
125 ci <- clientByNick asknick |
122 |
126 let ri = clientRoom rnc $ fromJust ci |
123 handleCmd_lobby clID clients rooms ["FOLLOW", asknick] = |
127 let clRoom = room rnc ri |
124 if noSuchClient || roomID followClient == 0 then |
128 if isNothing ci || ri == lobbyId then |
125 [] |
129 return [] |
126 else |
130 else |
127 handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName] |
131 handleCmd_lobby ["JOIN_ROOM", name clRoom] |
128 where |
|
129 maybeClient = Foldable.find (\cl -> asknick == nick cl) clients |
|
130 noSuchClient = isNothing maybeClient |
|
131 followClient = fromJust maybeClient |
|
132 roomName = name $ rooms IntMap.! roomID followClient |
|
133 |
|
134 |
132 |
135 --------------------------- |
133 --------------------------- |
136 -- Administrator's stuff -- |
134 -- Administrator's stuff -- |
137 |
135 |
138 handleCmd_lobby clID clients rooms ["KICK", kickNick] = |
136 handleCmd_lobby ["KICK", kickNick] = do |
139 [KickClient kickID | isAdministrator client && (not noSuchClient) && kickID /= clID] |
137 (ci, _) <- ask |
140 where |
138 cl <- thisClient |
141 client = clients IntMap.! clID |
139 kickId <- clientByNick kickNick |
142 maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients |
140 return [KickClient $ fromJust kickId | isAdministrator cl && isJust kickId && fromJust kickId /= ci] |
143 noSuchClient = isNothing maybeClient |
|
144 kickID = clientUID $ fromJust maybeClient |
|
145 |
141 |
146 |
142 {- |
147 handleCmd_lobby clID clients rooms ["BAN", banNick] = |
143 handleCmd_lobby clID clients rooms ["BAN", banNick] = |
148 if not $ isAdministrator client then |
144 if not $ isAdministrator client then |
149 [] |
145 [] |
150 else |
146 else |
151 BanClient banNick : handleCmd_lobby clID clients rooms ["KICK", banNick] |
147 BanClient banNick : handleCmd_lobby clID clients rooms ["KICK", banNick] |
152 where |
148 where |
153 client = clients IntMap.! clID |
149 client = clients IntMap.! clID |
|
150 -} |
154 |
151 |
155 |
152 |
|
153 handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = do |
|
154 cl <- thisClient |
|
155 return [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator cl] |
156 |
156 |
157 handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = |
157 handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do |
158 [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator client] |
158 cl <- thisClient |
|
159 return [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage}) | isAdministrator cl] |
|
160 |
|
161 handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do |
|
162 cl <- thisClient |
|
163 return [ModifyServerInfo (\si -> si{latestReleaseVersion = readNum}) | isAdministrator cl && readNum > 0] |
159 where |
164 where |
160 client = clients IntMap.! clID |
165 readNum = case B.readInt protoNum of |
|
166 Just (i, t) | B.null t -> fromIntegral i |
|
167 otherwise -> 0 |
161 |
168 |
162 handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = |
169 handleCmd_lobby ["GET_SERVER_VAR"] = do |
163 [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage}) | isAdministrator client] |
170 cl <- thisClient |
164 where |
171 return [SendServerVars | isAdministrator cl] |
165 client = clients IntMap.! clID |
|
166 |
172 |
167 handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = |
173 handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do |
168 [ModifyServerInfo (\si -> si{latestReleaseVersion = fromJust readNum}) | isAdministrator client && isJust readNum] |
174 cl <- thisClient |
169 where |
175 return [ClearAccountsCache | isAdministrator cl] |
170 client = clients IntMap.! clID |
|
171 readNum = maybeRead protoNum :: Maybe Word16 |
|
172 |
|
173 handleCmd_lobby clID clients rooms ["GET_SERVER_VAR"] = |
|
174 [SendServerVars | isAdministrator client] |
|
175 where |
|
176 client = clients IntMap.! clID |
|
177 |
176 |
178 |
177 |
179 handleCmd_lobby clID clients rooms ["CLEAR_ACCOUNTS_CACHE"] = |
178 handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"] |
180 [ClearAccountsCache | isAdministrator client] |
|
181 where |
|
182 client = clients IntMap.! clID |
|
183 |
|
184 |
|
185 handleCmd_lobby clID _ _ _ = [ProtocolError "Incorrect command (state: in lobby)"] |
|