1 {-# LANGUAGE OverloadedStrings #-} |
|
2 module HWProtoInRoomState where |
1 module HWProtoInRoomState where |
3 |
2 |
4 import qualified Data.Foldable as Foldable |
3 import qualified Data.Foldable as Foldable |
|
4 import qualified Data.IntMap as IntMap |
5 import qualified Data.Map as Map |
5 import qualified Data.Map as Map |
6 import Data.Sequence(Seq, (|>), (><), fromList, empty) |
6 import Data.Sequence(Seq, (|>), (><), fromList, empty) |
7 import Data.List |
7 import Data.List |
8 import Data.Maybe |
8 import Data.Maybe |
9 import qualified Data.ByteString.Char8 as B |
|
10 import Control.Monad |
|
11 import Control.Monad.Reader |
|
12 -------------------------------------- |
9 -------------------------------------- |
13 import CoreTypes |
10 import CoreTypes |
14 import Actions |
11 import Actions |
15 import Utils |
12 import Utils |
16 import HandlerUtils |
13 |
17 import RoomsAndClients |
|
18 |
14 |
19 handleCmd_inRoom :: CmdHandler |
15 handleCmd_inRoom :: CmdHandler |
20 |
16 |
21 handleCmd_inRoom ["CHAT", msg] = do |
17 handleCmd_inRoom clID clients _ ["CHAT", msg] = |
22 n <- clientNick |
18 [AnswerOthersInRoom ["CHAT", clientNick, msg]] |
23 s <- roomOthersChans |
19 where |
24 return [AnswerClients s ["CHAT", n, msg]] |
20 clientNick = nick $ clients IntMap.! clID |
25 |
21 |
26 handleCmd_inRoom ["PART"] = return [MoveToLobby "part"] |
22 handleCmd_inRoom clID clients rooms ["PART"] = |
27 handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg] |
23 [RoomRemoveThisClient "part"] |
|
24 where |
|
25 client = clients IntMap.! clID |
28 |
26 |
29 |
27 |
30 handleCmd_inRoom ("CFG" : paramName : paramStrs) |
28 handleCmd_inRoom clID clients rooms ("CFG" : paramName : paramStrs) |
31 | null paramStrs = return [ProtocolError "Empty config entry"] |
29 | null paramStrs = [ProtocolError "Empty config entry"] |
32 | otherwise = do |
30 | isMaster client = |
33 chans <- roomOthersChans |
31 [ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}), |
34 cl <- thisClient |
32 AnswerOthersInRoom ("CFG" : paramName : paramStrs)] |
35 if isMaster cl then |
33 | otherwise = [ProtocolError "Not room master"] |
36 return [ |
34 where |
37 ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}), |
35 client = clients IntMap.! clID |
38 AnswerClients chans ("CFG" : paramName : paramStrs)] |
|
39 else |
|
40 return [ProtocolError "Not room master"] |
|
41 |
36 |
42 handleCmd_inRoom ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo) |
37 handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo) |
43 | length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"] |
38 | length hhsInfo == 15 && clientProto client < 30 = handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : " " : flag : difStr : hhsInfo) |
44 | otherwise = do |
39 | length hhsInfo /= 16 = [ProtocolError "Corrupted hedgehogs info"] |
45 (ci, rnc) <- ask |
40 | length (teams room) == 6 = [Warning "too many teams"] |
46 r <- thisRoom |
41 | canAddNumber <= 0 = [Warning "too many hedgehogs"] |
47 clNick <- clientNick |
42 | isJust findTeam = [Warning "There's already a team with same name in the list"] |
48 clChan <- thisClientChans |
43 | gameinprogress room = [Warning "round in progress"] |
49 othersChans <- roomOthersChans |
44 | isRestrictedTeams room = [Warning "restricted"] |
50 return $ |
45 | otherwise = |
51 if not . null . drop 5 $ teams r then |
46 [ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}), |
52 [Warning "too many teams"] |
47 ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}), |
53 else if canAddNumber r <= 0 then |
48 AnswerThisClient ["TEAM_ACCEPTED", name], |
54 [Warning "too many hedgehogs"] |
49 AnswerOthersInRoom $ teamToNet (clientProto client) newTeam, |
55 else if isJust $ findTeam r then |
50 AnswerOthersInRoom ["TEAM_COLOR", name, color] |
56 [Warning "There's already a team with same name in the list"] |
51 ] |
57 else if gameinprogress r then |
52 where |
58 [Warning "round in progress"] |
53 client = clients IntMap.! clID |
59 else if isRestrictedTeams r then |
54 room = rooms IntMap.! (roomID client) |
60 [Warning "restricted"] |
55 canAddNumber = 48 - (sum . map hhnum $ teams room) |
61 else |
56 findTeam = find (\t -> name == teamname t) $ teams room |
62 [ModifyRoom (\r -> r{teams = teams r ++ [newTeam ci clNick r]}), |
57 newTeam = (TeamInfo clID (nick client) name color grave fort voicepack flag difficulty newTeamHHNum (hhsList hhsInfo)) |
63 ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}), |
58 difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int) |
64 AnswerClients clChan ["TEAM_ACCEPTED", name], |
|
65 AnswerClients othersChans $ teamToNet $ newTeam ci clNick r, |
|
66 AnswerClients othersChans ["TEAM_COLOR", name, color] |
|
67 ] |
|
68 where |
|
69 canAddNumber r = 48 - (sum . map hhnum $ teams r) |
|
70 findTeam = find (\t -> name == teamname t) . teams |
|
71 newTeam ci clNick r = (TeamInfo ci clNick name color grave fort voicepack flag difficulty (newTeamHHNum r) (hhsList hhsInfo)) |
|
72 difficulty = case B.readInt difStr of |
|
73 Just (i, t) | B.null t -> fromIntegral i |
|
74 otherwise -> 0 |
|
75 hhsList [] = [] |
59 hhsList [] = [] |
76 hhsList [_] = error "Hedgehogs list with odd elements number" |
|
77 hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs |
60 hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs |
78 newTeamHHNum r = min 4 (canAddNumber r) |
61 newTeamHHNum = min 4 canAddNumber |
79 |
62 |
80 handleCmd_inRoom ["REMOVE_TEAM", name] = do |
63 handleCmd_inRoom clID clients rooms ["REMOVE_TEAM", teamName] |
81 (ci, rnc) <- ask |
64 | noSuchTeam = [Warning "REMOVE_TEAM: no such team"] |
82 r <- thisRoom |
65 | nick client /= teamowner team = [ProtocolError "Not team owner!"] |
83 clNick <- clientNick |
66 | otherwise = |
84 |
67 [RemoveTeam teamName, |
85 let maybeTeam = findTeam r |
68 ModifyClient (\c -> c{teamsInGame = teamsInGame c - 1, clientClan = if teamsInGame client == 1 then undefined else anotherTeamClan}) |
86 let team = fromJust maybeTeam |
69 ] |
87 |
|
88 return $ |
|
89 if isNothing $ findTeam r then |
|
90 [Warning "REMOVE_TEAM: no such team"] |
|
91 else if clNick /= teamowner team then |
|
92 [ProtocolError "Not team owner!"] |
|
93 else |
|
94 [RemoveTeam name, |
|
95 ModifyClient |
|
96 (\c -> c{ |
|
97 teamsInGame = teamsInGame c - 1, |
|
98 clientClan = if teamsInGame c == 1 then undefined else anotherTeamClan ci r |
|
99 }) |
|
100 ] |
|
101 where |
70 where |
102 anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams |
71 client = clients IntMap.! clID |
103 findTeam = find (\t -> name == teamname t) . teams |
72 room = rooms IntMap.! (roomID client) |
|
73 noSuchTeam = isNothing findTeam |
|
74 team = fromJust findTeam |
|
75 findTeam = find (\t -> teamName == teamname t) $ teams room |
|
76 anotherTeamClan = teamcolor $ fromJust $ find (\t -> teamownerId t == clID) $ teams room |
104 |
77 |
105 |
78 |
106 handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do |
79 handleCmd_inRoom clID clients rooms ["HH_NUM", teamName, numberStr] |
107 cl <- thisClient |
80 | not $ isMaster client = [ProtocolError "Not room master"] |
108 others <- roomOthersChans |
81 | hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) = [] |
109 r <- thisRoom |
82 | otherwise = |
110 |
83 [ModifyRoom $ modifyTeam team{hhnum = hhNumber}, |
111 let maybeTeam = findTeam r |
84 AnswerOthersInRoom ["HH_NUM", teamName, show hhNumber]] |
112 let team = fromJust maybeTeam |
|
113 |
|
114 return $ |
|
115 if not $ isMaster cl then |
|
116 [ProtocolError "Not room master"] |
|
117 else if hhNumber < 1 || hhNumber > 8 || isNothing maybeTeam || hhNumber > (canAddNumber r) + (hhnum team) then |
|
118 [] |
|
119 else |
|
120 [ModifyRoom $ modifyTeam team{hhnum = hhNumber}, |
|
121 AnswerClients others ["HH_NUM", teamName, B.pack $ show hhNumber]] |
|
122 where |
85 where |
123 hhNumber = case B.readInt numberStr of |
86 client = clients IntMap.! clID |
124 Just (i, t) | B.null t -> fromIntegral i |
87 room = rooms IntMap.! (roomID client) |
125 otherwise -> 0 |
88 hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int) |
126 findTeam = find (\t -> teamName == teamname t) . teams |
89 noSuchTeam = isNothing findTeam |
127 canAddNumber = (-) 48 . sum . map hhnum . teams |
90 team = fromJust findTeam |
|
91 findTeam = find (\t -> teamName == teamname t) $ teams room |
|
92 canAddNumber = 48 - (sum . map hhnum $ teams room) |
128 |
93 |
129 |
94 |
130 |
95 handleCmd_inRoom clID clients rooms ["TEAM_COLOR", teamName, newColor] |
131 handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do |
96 | not $ isMaster client = [ProtocolError "Not room master"] |
132 cl <- thisClient |
97 | noSuchTeam = [] |
133 others <- roomOthersChans |
98 | otherwise = [ModifyRoom $ modifyTeam team{teamcolor = newColor}, |
134 r <- thisRoom |
99 AnswerOthersInRoom ["TEAM_COLOR", teamName, newColor], |
135 |
|
136 let maybeTeam = findTeam r |
|
137 let team = fromJust maybeTeam |
|
138 |
|
139 return $ |
|
140 if not $ isMaster cl then |
|
141 [ProtocolError "Not room master"] |
|
142 else if isNothing maybeTeam then |
|
143 [] |
|
144 else |
|
145 [ModifyRoom $ modifyTeam team{teamcolor = newColor}, |
|
146 AnswerClients others ["TEAM_COLOR", teamName, newColor], |
|
147 ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})] |
100 ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})] |
148 where |
101 where |
149 findTeam = find (\t -> teamName == teamname t) . teams |
102 noSuchTeam = isNothing findTeam |
|
103 team = fromJust findTeam |
|
104 findTeam = find (\t -> teamName == teamname t) $ teams room |
|
105 client = clients IntMap.! clID |
|
106 room = rooms IntMap.! (roomID client) |
150 |
107 |
151 |
108 |
152 handleCmd_inRoom ["TOGGLE_READY"] = do |
109 handleCmd_inRoom clID clients rooms ["TOGGLE_READY"] = |
153 cl <- thisClient |
110 [ModifyClient (\c -> c{isReady = not $ isReady client}), |
154 chans <- roomClientsChans |
111 ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady client then -1 else 1)}), |
155 return [ |
112 AnswerThisRoom [if isReady client then "NOT_READY" else "READY", nick client]] |
156 ModifyClient (\c -> c{isReady = not $ isReady cl}), |
113 where |
157 ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)}), |
114 client = clients IntMap.! clID |
158 AnswerClients chans [if isReady cl then "NOT_READY" else "READY", nick cl] |
|
159 ] |
|
160 |
115 |
161 handleCmd_inRoom ["START_GAME"] = do |
|
162 cl <- thisClient |
|
163 r <- thisRoom |
|
164 chans <- roomClientsChans |
|
165 |
116 |
166 if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then |
117 handleCmd_inRoom clID clients rooms ["START_GAME"] = |
167 if enoughClans r then |
118 if isMaster client && (playersIn room == readyPlayers room) && (not . gameinprogress) room then |
168 return [ |
119 if enoughClans then |
169 ModifyRoom |
120 [ModifyRoom |
170 (\r -> r{ |
121 (\r -> r{ |
171 gameinprogress = True, |
122 gameinprogress = True, |
172 roundMsgs = empty, |
123 roundMsgs = empty, |
173 leftTeams = [], |
124 leftTeams = [], |
174 teamsAtStart = teams r} |
125 teamsAtStart = teams r} |
175 ), |
126 ), |
176 AnswerClients chans ["RUN_GAME"] |
127 AnswerThisRoom ["RUN_GAME"]] |
177 ] |
|
178 else |
|
179 return [Warning "Less than two clans!"] |
|
180 else |
128 else |
181 return [] |
129 [Warning "Less than two clans!"] |
|
130 else |
|
131 [] |
182 where |
132 where |
183 enoughClans = not . null . drop 1 . group . map teamcolor . teams |
133 client = clients IntMap.! clID |
|
134 room = rooms IntMap.! (roomID client) |
|
135 enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room |
184 |
136 |
185 |
137 |
186 handleCmd_inRoom ["EM", msg] = do |
138 handleCmd_inRoom clID clients rooms ["EM", msg] = |
187 cl <- thisClient |
139 if (teamsInGame client > 0) && isLegal then |
188 r <- thisRoom |
140 (AnswerOthersInRoom ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive] |
189 chans <- roomOthersChans |
141 else |
190 |
142 [] |
191 if (teamsInGame cl > 0) && isLegal then |
|
192 return $ (AnswerClients chans ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive] |
|
193 else |
|
194 return [] |
|
195 where |
143 where |
|
144 client = clients IntMap.! clID |
196 (isLegal, isKeepAlive) = checkNetCmd msg |
145 (isLegal, isKeepAlive) = checkNetCmd msg |
197 |
146 |
198 |
147 handleCmd_inRoom clID clients rooms ["ROUNDFINISHED"] = |
199 handleCmd_inRoom ["ROUNDFINISHED"] = do |
148 if isMaster client then |
200 cl <- thisClient |
149 [ModifyRoom |
201 r <- thisRoom |
|
202 chans <- roomClientsChans |
|
203 |
|
204 if isMaster cl && (gameinprogress r) then |
|
205 return $ (ModifyRoom |
|
206 (\r -> r{ |
150 (\r -> r{ |
207 gameinprogress = False, |
151 gameinprogress = False, |
208 readyPlayers = 0, |
152 readyPlayers = 0, |
209 roundMsgs = empty, |
153 roundMsgs = empty, |
210 leftTeams = [], |
154 leftTeams = [], |
211 teamsAtStart = []} |
155 teamsAtStart = []} |
212 )) |
156 ), |
213 : UnreadyRoomClients |
157 UnreadyRoomClients |
214 : answerRemovedTeams chans r |
158 ] ++ answerRemovedTeams |
215 else |
159 else |
216 return [] |
160 [] |
217 where |
161 where |
218 answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams |
162 client = clients IntMap.! clID |
219 |
163 room = rooms IntMap.! (roomID client) |
220 handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do |
164 answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room |
221 cl <- thisClient |
|
222 return $ |
|
223 if not $ isMaster cl then |
|
224 [ProtocolError "Not room master"] |
|
225 else |
|
226 [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})] |
|
227 |
165 |
228 |
166 |
229 handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do |
167 handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_JOINS"] |
230 cl <- thisClient |
168 | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})] |
231 return $ |
169 | otherwise = [ProtocolError "Not room master"] |
232 if not $ isMaster cl then |
170 where |
233 [ProtocolError "Not room master"] |
171 client = clients IntMap.! clID |
234 else |
|
235 [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})] |
|
236 |
172 |
237 {- |
173 |
|
174 handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_TEAMS"] |
|
175 | isMaster client = [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})] |
|
176 | otherwise = [ProtocolError "Not room master"] |
|
177 where |
|
178 client = clients IntMap.! clID |
|
179 |
238 handleCmd_inRoom clID clients rooms ["KICK", kickNick] = |
180 handleCmd_inRoom clID clients rooms ["KICK", kickNick] = |
239 [KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)] |
181 [KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)] |
240 where |
182 where |
241 client = clients IntMap.! clID |
183 client = clients IntMap.! clID |
242 maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients |
184 maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients |