author | koda |
Sun, 10 Oct 2010 03:16:25 +0200 | |
changeset 3941 | 017b2b31e1c6 |
parent 3655 | 1ae653467897 |
child 4242 | 5e3c5fe2cb14 |
permissions | -rw-r--r-- |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3435
diff
changeset
|
1 |
{-# LANGUAGE OverloadedStrings #-} |
1804 | 2 |
module HWProtoInRoomState where |
3 |
||
1879 | 4 |
import qualified Data.Foldable as Foldable |
1804 | 5 |
import qualified Data.Map as Map |
6 |
import Data.Sequence(Seq, (|>), (><), fromList, empty) |
|
7 |
import Data.List |
|
3555 | 8 |
import Data.Maybe |
3531 | 9 |
import qualified Data.ByteString.Char8 as B |
3555 | 10 |
import Control.Monad |
11 |
import Control.Monad.Reader |
|
1804 | 12 |
-------------------------------------- |
13 |
import CoreTypes |
|
14 |
import Actions |
|
15 |
import Utils |
|
3435 | 16 |
import HandlerUtils |
3555 | 17 |
import RoomsAndClients |
1804 | 18 |
|
19 |
handleCmd_inRoom :: CmdHandler |
|
20 |
||
3435 | 21 |
handleCmd_inRoom ["CHAT", msg] = do |
22 |
n <- clientNick |
|
23 |
s <- roomOthersChans |
|
24 |
return [AnswerClients s ["CHAT", n, msg]] |
|
1804 | 25 |
|
3531 | 26 |
handleCmd_inRoom ["PART"] = return [MoveToLobby "part"] |
27 |
handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg] |
|
28 |
||
1811 | 29 |
|
3540 | 30 |
handleCmd_inRoom ("CFG" : paramName : paramStrs) |
31 |
| null paramStrs = return [ProtocolError "Empty config entry"] |
|
32 |
| otherwise = do |
|
33 |
chans <- roomOthersChans |
|
34 |
cl <- thisClient |
|
35 |
if isMaster cl then |
|
36 |
return [ |
|
37 |
ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}), |
|
38 |
AnswerClients chans ("CFG" : paramName : paramStrs)] |
|
39 |
else |
|
40 |
return [ProtocolError "Not room master"] |
|
1804 | 41 |
|
3544 | 42 |
handleCmd_inRoom ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo) |
43 |
| length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"] |
|
3555 | 44 |
| otherwise = do |
45 |
(ci, rnc) <- ask |
|
3568 | 46 |
r <- thisRoom |
3555 | 47 |
clNick <- clientNick |
48 |
clChan <- thisClientChans |
|
49 |
othersChans <- roomOthersChans |
|
50 |
return $ |
|
3566 | 51 |
if not . null . drop 5 $ teams r then |
3555 | 52 |
[Warning "too many teams"] |
53 |
else if canAddNumber r <= 0 then |
|
54 |
[Warning "too many hedgehogs"] |
|
55 |
else if isJust $ findTeam r then |
|
56 |
[Warning "There's already a team with same name in the list"] |
|
57 |
else if gameinprogress r then |
|
58 |
[Warning "round in progress"] |
|
59 |
else if isRestrictedTeams r then |
|
60 |
[Warning "restricted"] |
|
61 |
else |
|
62 |
[ModifyRoom (\r -> r{teams = teams r ++ [newTeam ci clNick r]}), |
|
63 |
ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}), |
|
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 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
75 |
hhsList [] = [] |
3566 | 76 |
hhsList [_] = error "Hedgehogs list with odd elements number" |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
77 |
hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs |
3555 | 78 |
newTeamHHNum r = min 4 (canAddNumber r) |
3561 | 79 |
|
80 |
handleCmd_inRoom ["REMOVE_TEAM", name] = do |
|
81 |
(ci, rnc) <- ask |
|
3568 | 82 |
r <- thisRoom |
3564 | 83 |
clNick <- clientNick |
84 |
||
85 |
let maybeTeam = findTeam r |
|
86 |
let team = fromJust maybeTeam |
|
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 |
] |
|
3561 | 101 |
where |
102 |
anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams |
|
3564 | 103 |
findTeam = find (\t -> name == teamname t) . teams |
3561 | 104 |
|
3568 | 105 |
|
106 |
handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do |
|
107 |
cl <- thisClient |
|
108 |
others <- roomOthersChans |
|
109 |
r <- thisRoom |
|
110 |
||
111 |
let maybeTeam = findTeam r |
|
112 |
let team = fromJust maybeTeam |
|
1804 | 113 |
|
3568 | 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]] |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
122 |
where |
3568 | 123 |
hhNumber = case B.readInt numberStr of |
124 |
Just (i, t) | B.null t -> fromIntegral i |
|
125 |
otherwise -> 0 |
|
126 |
findTeam = find (\t -> teamName == teamname t) . teams |
|
127 |
canAddNumber = (-) 48 . sum . map hhnum . teams |
|
1804 | 128 |
|
129 |
||
3568 | 130 |
|
131 |
handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do |
|
132 |
cl <- thisClient |
|
133 |
others <- roomOthersChans |
|
134 |
r <- thisRoom |
|
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], |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
147 |
ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
148 |
where |
3568 | 149 |
findTeam = find (\t -> teamName == teamname t) . teams |
150 |
||
1804 | 151 |
|
3543 | 152 |
handleCmd_inRoom ["TOGGLE_READY"] = do |
153 |
cl <- thisClient |
|
154 |
chans <- roomClientsChans |
|
155 |
return [ |
|
156 |
ModifyClient (\c -> c{isReady = not $ isReady cl}), |
|
157 |
ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)}), |
|
158 |
AnswerClients chans [if isReady cl then "NOT_READY" else "READY", nick cl] |
|
159 |
] |
|
1804 | 160 |
|
3577 | 161 |
handleCmd_inRoom ["START_GAME"] = do |
162 |
cl <- thisClient |
|
163 |
r <- thisRoom |
|
164 |
chans <- roomClientsChans |
|
165 |
||
166 |
if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then |
|
167 |
if enoughClans r then |
|
168 |
return [ |
|
169 |
ModifyRoom |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
170 |
(\r -> r{ |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
171 |
gameinprogress = True, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
172 |
roundMsgs = empty, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
173 |
leftTeams = [], |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
174 |
teamsAtStart = teams r} |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
175 |
), |
3577 | 176 |
AnswerClients chans ["RUN_GAME"] |
177 |
] |
|
178 |
else |
|
179 |
return [Warning "Less than two clans!"] |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
180 |
else |
3577 | 181 |
return [] |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
182 |
where |
3577 | 183 |
enoughClans = not . null . drop 1 . group . map teamcolor . teams |
1804 | 184 |
|
185 |
||
3579 | 186 |
handleCmd_inRoom ["EM", msg] = do |
187 |
cl <- thisClient |
|
188 |
r <- thisRoom |
|
189 |
chans <- roomOthersChans |
|
190 |
||
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 [] |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
195 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
196 |
(isLegal, isKeepAlive) = checkNetCmd msg |
1804 | 197 |
|
3655 | 198 |
|
199 |
handleCmd_inRoom ["ROUNDFINISHED"] = do |
|
200 |
cl <- thisClient |
|
201 |
r <- thisRoom |
|
202 |
chans <- roomClientsChans |
|
203 |
||
204 |
if isMaster cl && (gameinprogress r) then |
|
205 |
return $ (ModifyRoom |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
206 |
(\r -> r{ |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
207 |
gameinprogress = False, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
208 |
readyPlayers = 0, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
209 |
roundMsgs = empty, |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
210 |
leftTeams = [], |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
211 |
teamsAtStart = []} |
3655 | 212 |
)) |
213 |
: UnreadyRoomClients |
|
214 |
: answerRemovedTeams chans r |
|
215 |
else |
|
216 |
return [] |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
217 |
where |
3655 | 218 |
answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams |
3568 | 219 |
|
220 |
handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do |
|
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})] |
|
1811 | 227 |
|
228 |
||
3568 | 229 |
handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do |
230 |
cl <- thisClient |
|
231 |
return $ |
|
232 |
if not $ isMaster cl then |
|
233 |
[ProtocolError "Not room master"] |
|
234 |
else |
|
235 |
[ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})] |
|
1831 | 236 |
|
3568 | 237 |
{- |
1879 | 238 |
handleCmd_inRoom clID clients rooms ["KICK", kickNick] = |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
239 |
[KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)] |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
240 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
241 |
client = clients IntMap.! clID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
242 |
maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
243 |
noSuchClient = isNothing maybeClient |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
244 |
kickClient = fromJust maybeClient |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
245 |
kickID = clientUID kickClient |
1879 | 246 |
|
1831 | 247 |
|
2403 | 248 |
handleCmd_inRoom clID clients _ ["TEAMCHAT", msg] = |
2960 | 249 |
[AnswerSameClan ["EM", engineMsg]] |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
250 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
251 |
client = clients IntMap.! clID |
2952
18fada739b55
- Convert strings from utf-8 on recieve, and back to utf-8 when send them
unc0rr
parents:
2928
diff
changeset
|
252 |
engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20") |
3531 | 253 |
-} |
254 |
handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"] |