author  unc0rr 
Thu, 28 Jun 2012 22:45:06 +0400  
changeset 7321  57bd4f201401 
parent 7266  74ad631a72bf 
child 7537  833a0c34fafc 
permissions  rwrr 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

1 
{# LANGUAGE OverloadedStrings #} 
1804  2 
module HWProtoInRoomState where 
3 

4 
import qualified Data.Map as Map 

4614  5 
import Data.Sequence((>), empty) 
1804  6 
import Data.List 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

7 
import Data.Maybe 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

8 
import qualified Data.ByteString.Char8 as B 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

9 
import Control.Monad 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

10 
import Control.Monad.Reader 
1804  11 
 
12 
import CoreTypes 

13 
import Actions 

14 
import Utils 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

15 
import HandlerUtils 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

16 
import RoomsAndClients 
6068  17 
import EngineInteraction 
1804  18 

4989  19 
handleCmd_inRoom :: CmdHandler 
1804  20 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

21 
handleCmd_inRoom ["CHAT", msg] = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

22 
n < clientNick 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

23 
s < roomOthersChans 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

24 
return [AnswerClients s ["CHAT", n, msg]] 
1804  25 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

26 
handleCmd_inRoom ["PART"] = return [MoveToLobby "part"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

27 
handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg] 
3531  28 

1811  29 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

30 
handleCmd_inRoom ("CFG" : paramName : paramStrs) 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

31 
 null paramStrs = return [ProtocolError "Empty config entry"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

32 
 otherwise = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

33 
chans < roomOthersChans 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

34 
cl < thisClient 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

35 
if isMaster cl then 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

36 
return [ 
4941  37 
ModifyRoom f, 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

38 
AnswerClients chans ("CFG" : paramName : paramStrs)] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

39 
else 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

40 
return [ProtocolError "Not room master"] 
4941  41 
where 
42 
f r = if paramName `Map.member` (mapParams r) then 

43 
r{mapParams = Map.insert paramName (head paramStrs) (mapParams r)} 

44 
else 

45 
r{params = Map.insert paramName paramStrs (params r)} 

1804  46 

4932  47 
handleCmd_inRoom ("ADD_TEAM" : tName : color : grave : fort : voicepack : flag : difStr : hhsInfo) 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

48 
 length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

49 
 otherwise = do 
4932  50 
(ci, _) < ask 
51 
rm < thisRoom 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

52 
clNick < clientNick 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

53 
clChan < thisClientChans 
4932  54 
othChans < roomOthersChans 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

55 
return $ 
5931  56 
if not . null . drop (maxTeams rm  1) $ teams rm then 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

57 
[Warning "too many teams"] 
4932  58 
else if canAddNumber rm <= 0 then 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

59 
[Warning "too many hedgehogs"] 
4932  60 
else if isJust $ findTeam rm then 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

61 
[Warning "There's already a team with same name in the list"] 
5996
2c72fe81dd37
Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents:
5931
diff
changeset

62 
else if isJust $ gameInfo rm then 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

63 
[Warning "round in progress"] 
4932  64 
else if isRestrictedTeams rm then 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

65 
[Warning "restricted"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

66 
else 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

67 
[ModifyRoom (\r > r{teams = teams r ++ [newTeam ci clNick r]}), 
4986
33fe91b2bcbf
Use Maybe for storing client's clan, allows less errorprone spectator checks
unc0rr
parents:
4975
diff
changeset

68 
ModifyClient (\c > c{teamsInGame = teamsInGame c + 1, clientClan = Just color}), 
4932  69 
AnswerClients clChan ["TEAM_ACCEPTED", tName], 
70 
AnswerClients othChans $ teamToNet $ newTeam ci clNick rm, 

71 
AnswerClients othChans ["TEAM_COLOR", tName, color] 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

72 
] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

73 
where 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

74 
canAddNumber r = 48  (sum . map hhnum $ teams r) 
4932  75 
findTeam = find (\t > tName == teamname t) . teams 
76 
newTeam ci clNick r = TeamInfo ci clNick tName color grave fort voicepack flag dif (newTeamHHNum r) (hhsList hhsInfo) 

5030
42746c5d4a80
Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents:
4989
diff
changeset

77 
dif = readInt_ difStr 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

78 
hhsList [] = [] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

79 
hhsList [_] = error "Hedgehogs list with odd elements number" 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

80 
hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

81 
newTeamHHNum r = min 4 (canAddNumber r) 
7321
57bd4f201401
 Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7266
diff
changeset

82 
maxTeams r 
5931  83 
 roomProto r < 38 = 6 
84 
 otherwise = 8 

7321
57bd4f201401
 Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7266
diff
changeset

85 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

86 

4932  87 
handleCmd_inRoom ["REMOVE_TEAM", tName] = do 
88 
(ci, _) < ask 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

89 
r < thisRoom 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

90 
clNick < clientNick 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

91 

1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

92 
let maybeTeam = findTeam r 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

93 
let team = fromJust maybeTeam 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

94 

1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

95 
return $ 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

96 
if isNothing $ findTeam r then 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

97 
[Warning "REMOVE_TEAM: no such team"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

98 
else if clNick /= teamowner team then 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

99 
[ProtocolError "Not team owner!"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

100 
else 
4932  101 
[RemoveTeam tName, 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

102 
ModifyClient 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

103 
(\c > c{ 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

104 
teamsInGame = teamsInGame c  1, 
4989  105 
clientClan = if teamsInGame c == 1 then Nothing else Just $ anotherTeamClan ci r 
106 
}) 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

107 
] 
4568  108 
where 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

109 
anotherTeamClan ci = teamcolor . fromJust . find (\t > teamownerId t == ci) . teams 
4932  110 
findTeam = find (\t > tName == teamname t) . teams 
3561  111 

3568  112 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

113 
handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

114 
cl < thisClient 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

115 
others < roomOthersChans 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

116 
r < thisRoom 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

117 

1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

118 
let maybeTeam = findTeam r 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

119 
let team = fromJust maybeTeam 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

120 

1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

121 
return $ 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

122 
if not $ isMaster cl then 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

123 
[ProtocolError "Not room master"] 
4932  124 
else if hhNumber < 1  hhNumber > 8  isNothing maybeTeam  hhNumber > canAddNumber r + hhnum team then 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

125 
[] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

126 
else 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

127 
[ModifyRoom $ modifyTeam team{hhnum = hhNumber}, 
5030
42746c5d4a80
Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents:
4989
diff
changeset

128 
AnswerClients others ["HH_NUM", teamName, showB hhNumber]] 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

129 
where 
5030
42746c5d4a80
Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents:
4989
diff
changeset

130 
hhNumber = readInt_ numberStr 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

131 
findTeam = find (\t > teamName == teamname t) . teams 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

132 
canAddNumber = () 48 . sum . map hhnum . teams 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

133 

1804  134 

3568  135 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

136 
handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

137 
cl < thisClient 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

138 
others < roomOthersChans 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

139 
r < thisRoom 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

140 

1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

141 
let maybeTeam = findTeam r 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

142 
let team = fromJust maybeTeam 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

143 

1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

144 
return $ 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

145 
if not $ isMaster cl then 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

146 
[ProtocolError "Not room master"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

147 
else if isNothing maybeTeam then 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

148 
[] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

149 
else 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

150 
[ModifyRoom $ modifyTeam team{teamcolor = newColor}, 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

151 
AnswerClients others ["TEAM_COLOR", teamName, newColor], 
4986
33fe91b2bcbf
Use Maybe for storing client's clan, allows less errorprone spectator checks
unc0rr
parents:
4975
diff
changeset

152 
ModifyClient2 (teamownerId team) (\c > c{clientClan = Just newColor})] 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

153 
where 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

154 
findTeam = find (\t > teamName == teamname t) . teams 
3568  155 

1804  156 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

157 
handleCmd_inRoom ["TOGGLE_READY"] = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

158 
cl < thisClient 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

159 
chans < roomClientsChans 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

160 
return [ 
7266  161 
ModifyRoom (\r > r{readyPlayers = readyPlayers r + (if isReady cl then 1 else 1)}), 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

162 
ModifyClient (\c > c{isReady = not $ isReady cl}), 
4942
1c85a8e6e11c
Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents:
4941
diff
changeset

163 
AnswerClients chans $ if clientProto cl < 38 then 
1c85a8e6e11c
Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents:
4941
diff
changeset

164 
[if isReady cl then "NOT_READY" else "READY", nick cl] 
1c85a8e6e11c
Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents:
4941
diff
changeset

165 
else 
1c85a8e6e11c
Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents:
4941
diff
changeset

166 
["CLIENT_FLAGS", if isReady cl then "r" else "+r", nick cl] 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

167 
] 
1804  168 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

169 
handleCmd_inRoom ["START_GAME"] = do 
6012  170 
(ci, rnc) < ask 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

171 
cl < thisClient 
4932  172 
rm < thisRoom 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

173 
chans < roomClientsChans 
7321
57bd4f201401
 Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7266
diff
changeset

174 

6012  175 
let allPlayersRegistered = all ((<) 0 . B.length . webPassword . client rnc . teamownerId) $ teams rm 
3577  176 

5996
2c72fe81dd37
Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents:
5931
diff
changeset

177 
if isMaster cl && playersIn rm == readyPlayers rm && not (isJust $ gameInfo rm) then 
4932  178 
if enoughClans rm then 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

179 
return [ 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

180 
ModifyRoom 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

181 
(\r > r{ 
6756
344d32bb1328
Also consider game finished when the last player reports ROUNDFINISHED despite the correctness parameter.
unc0rr
parents:
6753
diff
changeset

182 
gameInfo = Just $ newGameInfo (teams rm) (length $ teams rm) allPlayersRegistered (mapParams rm) (params rm) 
5996
2c72fe81dd37
Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents:
5931
diff
changeset

183 
} 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

184 
), 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

185 
AnswerClients chans ["RUN_GAME"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

186 
] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

187 
else 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

188 
return [Warning "Less than two clans!"] 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

189 
else 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

190 
return [] 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

191 
where 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

192 
enoughClans = not . null . drop 1 . group . map teamcolor . teams 
1804  193 

194 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

195 
handleCmd_inRoom ["EM", msg] = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

196 
cl < thisClient 
4932  197 
rm < thisRoom 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

198 
chans < roomOthersChans 
4931
da43c36a6e92
Don't accept EM message when the game isn't started
unc0rr
parents:
4917
diff
changeset

199 

5996
2c72fe81dd37
Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents:
5931
diff
changeset

200 
if teamsInGame cl > 0 && (isJust $ gameInfo rm) && isLegal then 
2c72fe81dd37
Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents:
5931
diff
changeset

201 
return $ AnswerClients chans ["EM", msg] : [ModifyRoom (\r > r{gameInfo = liftM (\g > g{roundMsgs = roundMsgs g > msg}) $ gameInfo r})  not isKeepAlive] 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

202 
else 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

203 
return [] 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

204 
where 
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

205 
(isLegal, isKeepAlive) = checkNetCmd msg 
1804  206 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

207 

5996
2c72fe81dd37
Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents:
5931
diff
changeset

208 
handleCmd_inRoom ["ROUNDFINISHED", correctly] = do 
6690
46b3f4776538
Send team removal message on incorrect engine shutdown (when game not finished). Should help with game hang when room master closes engine, then quits room.
unc0rr
parents:
6541
diff
changeset

209 
clId < asks fst 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

210 
cl < thisClient 
4932  211 
rm < thisRoom 
6753
e95b1f62d0de
Don't remove client's teams from teams list on "ROUNDFINISHED 0", just send team removal message to others.
unc0rr
parents:
6738
diff
changeset

212 
let clTeams = map teamname . filter (\t > teamowner t == nick cl) . teams $ rm 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

213 

6738
dd98869d74b4
Remove client's teams only when game is running and exit status is 'incorrect exit'. Frontend still sends excessive ROUND_FINISHED, so the bug is not fixed completely.
unc0rr
parents:
6721
diff
changeset

214 
if isJust $ gameInfo rm then 
6758
26bf919aeb57
Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents:
6756
diff
changeset

215 
if (isMaster cl && isCorrect) then 
26bf919aeb57
Oh, should also check for game finish when player quits without ROUNDFINISHED message: small refactoring, not tested at all
unc0rr
parents:
6756
diff
changeset

216 
return [FinishGame] 
6815
ed63275e02b7
Fix server thinking game is still not finished sometimes
unc0rr
parents:
6758
diff
changeset

217 
else return $ map SendTeamRemovalMessage clTeams 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

218 
else 
6738
dd98869d74b4
Remove client's teams only when game is running and exit status is 'incorrect exit'. Frontend still sends excessive ROUND_FINISHED, so the bug is not fixed completely.
unc0rr
parents:
6721
diff
changeset

219 
return [] 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

220 
where 
5996
2c72fe81dd37
Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents:
5931
diff
changeset

221 
isCorrect = correctly == "1" 
1811  222 

4942
1c85a8e6e11c
Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents:
4941
diff
changeset

223 
 compatibility with clients with protocol < 38 
1c85a8e6e11c
Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents:
4941
diff
changeset

224 
handleCmd_inRoom ["ROUNDFINISHED"] = 
1c85a8e6e11c
Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents:
4941
diff
changeset

225 
handleCmd_inRoom ["ROUNDFINISHED", "1"] 
1c85a8e6e11c
Okay, a compatibility layer for clients of 0.9.15 version (not sure about old versions, as I removed all compatibility hacks for older versions previously)
unc0rr
parents:
4941
diff
changeset

226 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

227 
handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

228 
cl < thisClient 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

229 
return $ 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

230 
if not $ isMaster cl then 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

231 
[ProtocolError "Not room master"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

232 
else 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

233 
[ModifyRoom (\r > r{isRestrictedJoins = not $ isRestrictedJoins r})] 
4568  234 

1831  235 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

236 
handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

237 
cl < thisClient 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

238 
return $ 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

239 
if not $ isMaster cl then 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

240 
[ProtocolError "Not room master"] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

241 
else 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

242 
[ModifyRoom (\r > r{isRestrictedTeams = not $ isRestrictedTeams r})] 
1879  243 

1831  244 

5098  245 
handleCmd_inRoom ["ROOM_NAME", newName] = do 
246 
cl < thisClient 

247 
rs < allRoomInfos 

6541
08ed346ed341
Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents:
6403
diff
changeset

248 
rm < thisRoom 
08ed346ed341
Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents:
6403
diff
changeset

249 
chans < sameProtoChans 
7321
57bd4f201401
 Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7266
diff
changeset

250 

5098  251 
return $ 
252 
if not $ isMaster cl then 

253 
[ProtocolError "Not room master"] 

254 
else 

255 
if isJust $ find (\r > newName == name r) rs then 

256 
[Warning "Room with such name already exists"] 

257 
else 

6541
08ed346ed341
Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents:
6403
diff
changeset

258 
[ModifyRoom roomUpdate, 
08ed346ed341
Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents:
6403
diff
changeset

259 
AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo (nick cl) (roomUpdate rm))] 
08ed346ed341
Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents:
6403
diff
changeset

260 
where 
08ed346ed341
Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents:
6403
diff
changeset

261 
roomUpdate r = r{name = newName} 
5098  262 

263 

4614  264 
handleCmd_inRoom ["KICK", kickNick] = do 
265 
(thisClientId, rnc) < ask 

266 
maybeClientId < clientByNick kickNick 

267 
master < liftM isMaster thisClient 

268 
let kickId = fromJust maybeClientId 

4932  269 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId 
4614  270 
return 
271 
[KickRoomClient kickId  master && isJust maybeClientId && (kickId /= thisClientId) && sameRoom] 

1879  272 

1831  273 

4614  274 
handleCmd_inRoom ["TEAMCHAT", msg] = do 
275 
cl < thisClient 

276 
chans < roomSameClanChans 

277 
return [AnswerClients chans ["EM", engineMsg cl]] 

2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

278 
where 
5030
42746c5d4a80
Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents:
4989
diff
changeset

279 
engineMsg cl = toEngineMsg $ B.concat ["b", nick cl, "(team): ", msg, "\x20\x20"] 
4568  280 

6912
831416764d2d
Allow LIST command while in room to not annoy old frontends (0.9.17 or less) with warnings
unc0rr
parents:
6815
diff
changeset

281 
handleCmd_inRoom ["LIST"] = return []  for old clients (<= 0.9.17) 
831416764d2d
Allow LIST command while in room to not annoy old frontends (0.9.17 or less) with warnings
unc0rr
parents:
6815
diff
changeset

282 

6721
7dbf8a0c1f5d
 Register HWTeam metatype so HWTeam objects could be passed via queued connections
unc0rr
parents:
6690
diff
changeset

283 
handleCmd_inRoom (s:_) = return [ProtocolError $ "Incorrect command '" `B.append` s `B.append` "' (state: in room)"] 
7dbf8a0c1f5d
 Register HWTeam metatype so HWTeam objects could be passed via queued connections
unc0rr
parents:
6690
diff
changeset

284 

7dbf8a0c1f5d
 Register HWTeam metatype so HWTeam objects could be passed via queued connections
unc0rr
parents:
6690
diff
changeset

285 
handleCmd_inRoom [] = return [ProtocolError "Empty command (state: in room)"] 