author  unc0rr 
Sun, 02 Dec 2012 22:14:21 +0400  
changeset 8189  328f429c3ecc 
parent 8002  8113afd3858f 
child 8227  3a2ce574aa3b 
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 

7766  5 
import Data.Sequence((>)) 
7862
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

6 
import Data.List as L 
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 
8002  11 
import Control.DeepSeq 
1804  12 
 
13 
import CoreTypes 

14 
import Actions 

15 
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

16 
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

17 
import RoomsAndClients 
6068  18 
import EngineInteraction 
1804  19 

4989  20 
handleCmd_inRoom :: CmdHandler 
1804  21 

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

22 
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

23 
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

24 
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

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

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

27 
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

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

1811  30 

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

31 
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

32 
 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

33 
 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

34 
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

35 
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

36 
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

37 
return [ 
4941  38 
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

39 
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

40 
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

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

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

45 
else 

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

1804  47 

4932  48 
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

49 
 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

50 
 otherwise = do 
4932  51 
(ci, _) < ask 
52 
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

53 
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

54 
clChan < thisClientChans 
4932  55 
othChans < roomOthersChans 
7862
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

56 
roomChans < roomClientsChans 
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

57 
cl < thisClient 
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

58 
teamColor < 
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

59 
if clientProto cl < 42 then 
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

60 
return color 
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

61 
else 
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

62 
liftM (head . (L.\\) (map B.singleton ['0'..]) . map teamcolor . teams) thisRoom 
7986
53b1da5ee7f4
Maybe this caused server crashes? Add more strictness on team owner record field
unc0rr
parents:
7947
diff
changeset

63 
let newTeam = clNick `seq` TeamInfo ci clNick tName teamColor grave fort voicepack flag dif (newTeamHHNum rm) (hhsList 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

64 
return $ 
5931  65 
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

66 
[Warning "too many teams"] 
4932  67 
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

68 
[Warning "too many hedgehogs"] 
4932  69 
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

70 
[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

71 
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

72 
[Warning "round in progress"] 
4932  73 
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

74 
[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

75 
else 
7986
53b1da5ee7f4
Maybe this caused server crashes? Add more strictness on team owner record field
unc0rr
parents:
7947
diff
changeset

76 
[ModifyRoom (\r > r{teams = teams r ++ [newTeam]}), 
7921
6b074de32bea
Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents:
7862
diff
changeset

77 
SendUpdateOnThisRoom, 
7862
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

78 
ModifyClient (\c > c{teamsInGame = teamsInGame c + 1, clientClan = Just teamColor}), 
4932  79 
AnswerClients clChan ["TEAM_ACCEPTED", tName], 
7986
53b1da5ee7f4
Maybe this caused server crashes? Add more strictness on team owner record field
unc0rr
parents:
7947
diff
changeset

80 
AnswerClients othChans $ teamToNet $ newTeam, 
7862
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

81 
AnswerClients roomChans ["TEAM_COLOR", tName, teamColor] 
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

82 
] 
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

83 
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

84 
canAddNumber r = 48  (sum . map hhnum $ teams r) 
4932  85 
findTeam = find (\t > tName == teamname t) . teams 
5030
42746c5d4a80
Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents:
4989
diff
changeset

86 
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

87 
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

88 
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

89 
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

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

91 
maxTeams r 
5931  92 
 roomProto r < 38 = 6 
93 
 otherwise = 8 

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

94 

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

95 

4932  96 
handleCmd_inRoom ["REMOVE_TEAM", tName] = do 
97 
(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

98 
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

99 
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

100 

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

101 
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

102 
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

103 

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 
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

105 
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

106 
[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

107 
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

108 
[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

109 
else 
4932  110 
[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

111 
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

112 
(\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

113 
teamsInGame = teamsInGame c  1, 
4989  114 
clientClan = if teamsInGame c == 1 then Nothing else Just $ anotherTeamClan ci r 
115 
}) 

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

116 
] 
4568  117 
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

118 
anotherTeamClan ci = teamcolor . fromJust . find (\t > teamownerId t == ci) . teams 
4932  119 
findTeam = find (\t > tName == teamname t) . teams 
3561  120 

3568  121 

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

122 
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

123 
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

124 
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

125 
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

126 

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 
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

128 
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

129 

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

130 
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

131 
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

132 
[ProtocolError "Not room master"] 
4932  133 
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

134 
[] 
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

135 
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

136 
[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

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

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

139 
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

140 
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

141 
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

142 

1804  143 

3568  144 

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

145 
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

146 
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

147 
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

148 
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

149 

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 
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

151 
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

152 

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

153 
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

154 
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

155 
[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

156 
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

157 
[] 
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 
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

159 
[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

160 
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

161 
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

162 
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

163 
findTeam = find (\t > teamName == teamname t) . teams 
3568  164 

1804  165 

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

166 
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

167 
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

168 
chans < roomClientsChans 
7775  169 
if isMaster cl then 
170 
return [] 

171 
else 

172 
return [ 

173 
ModifyRoom (\r > r{readyPlayers = readyPlayers r + (if isReady cl then 1 else 1)}), 

174 
ModifyClient (\c > c{isReady = not $ isReady cl}), 

175 
AnswerClients chans $ if clientProto cl < 38 then 

176 
[if isReady cl then "NOT_READY" else "READY", nick cl] 

177 
else 

178 
["CLIENT_FLAGS", if isReady cl then "r" else "+r", nick cl] 

179 
] 

1804  180 

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

181 
handleCmd_inRoom ["START_GAME"] = do 
6012  182 
(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

183 
cl < thisClient 
4932  184 
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

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

186 

7765
1e162c1d6dc7
'In game' client flag, both server and frontend support
unc0rr
parents:
7757
diff
changeset

187 
let nicks = map (nick . client rnc) . roomClients rnc $ clientRoom rnc ci 
6012  188 
let allPlayersRegistered = all ((<) 0 . B.length . webPassword . client rnc . teamownerId) $ teams rm 
3577  189 

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

190 
if isMaster cl && playersIn rm == readyPlayers rm && not (isJust $ gameInfo rm) then 
4932  191 
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

192 
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

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

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

195 
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

196 
} 
7757
c20e6c80e249
Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents:
7537
diff
changeset

197 
) 
c20e6c80e249
Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents:
7537
diff
changeset

198 
, AnswerClients chans ["RUN_GAME"] 
7921
6b074de32bea
Send ROOM UPD message when team is added/deleted from room, and when game starts or finishes
unc0rr
parents:
7862
diff
changeset

199 
, SendUpdateOnThisRoom 
7765
1e162c1d6dc7
'In game' client flag, both server and frontend support
unc0rr
parents:
7757
diff
changeset

200 
, AnswerClients chans $ "CLIENT_FLAGS" : "+g" : nicks 
7757
c20e6c80e249
Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents:
7537
diff
changeset

201 
, ModifyRoomClients (\c > c{isInGame = True}) 
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 
] 
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 
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

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

205 
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

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

207 
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

208 
enoughClans = not . null . drop 1 . group . map teamcolor . teams 
1804  209 

210 

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

211 
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

212 
cl < thisClient 
4932  213 
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

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

215 

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

216 
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

217 
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

218 
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

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

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

221 
(isLegal, isKeepAlive) = checkNetCmd msg 
1804  222 

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

223 

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

224 
handleCmd_inRoom ["ROUNDFINISHED", correctly] = do 
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

225 
cl < thisClient 
4932  226 
rm < thisRoom 
7765
1e162c1d6dc7
'In game' client flag, both server and frontend support
unc0rr
parents:
7757
diff
changeset

227 
chans < roomClientsChans 
1e162c1d6dc7
'In game' client flag, both server and frontend support
unc0rr
parents:
7757
diff
changeset

228 

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

229 
let clTeams = map teamname . filter (\t > teamowner t == nick cl) . teams $ rm 
7765
1e162c1d6dc7
'In game' client flag, both server and frontend support
unc0rr
parents:
7757
diff
changeset

230 
let unsetInGameState = [AnswerClients chans ["CLIENT_FLAGS", "g", nick cl], ModifyClient (\c > c{isInGame = False})] 
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

231 

7757
c20e6c80e249
Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents:
7537
diff
changeset

232 
if isInGame cl then 
c20e6c80e249
Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents:
7537
diff
changeset

233 
if isJust $ gameInfo rm then 
c20e6c80e249
Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents:
7537
diff
changeset

234 
if (isMaster cl && isCorrect) then 
7765
1e162c1d6dc7
'In game' client flag, both server and frontend support
unc0rr
parents:
7757
diff
changeset

235 
return $ FinishGame : unsetInGameState 
7757
c20e6c80e249
Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents:
7537
diff
changeset

236 
else 
7765
1e162c1d6dc7
'In game' client flag, both server and frontend support
unc0rr
parents:
7757
diff
changeset

237 
return $ unsetInGameState ++ map SendTeamRemovalMessage clTeams 
7757
c20e6c80e249
Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents:
7537
diff
changeset

238 
else 
7765
1e162c1d6dc7
'In game' client flag, both server and frontend support
unc0rr
parents:
7757
diff
changeset

239 
return unsetInGameState 
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

240 
else 
7757
c20e6c80e249
Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents:
7537
diff
changeset

241 
return []  don't accept this message twice 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2747
diff
changeset

242 
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

243 
isCorrect = correctly == "1" 
1811  244 

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

245 
 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

246 
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

247 
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

248 

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

249 
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

250 
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

251 
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

252 
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

253 
[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

254 
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

255 
[ModifyRoom (\r > r{isRestrictedJoins = not $ isRestrictedJoins r})] 
4568  256 

1831  257 

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

258 
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

259 
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

260 
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

261 
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

262 
[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

263 
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

264 
[ModifyRoom (\r > r{isRestrictedTeams = not $ isRestrictedTeams r})] 
1879  265 

1831  266 

5098  267 
handleCmd_inRoom ["ROOM_NAME", newName] = do 
268 
cl < thisClient 

269 
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

270 
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

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

272 

5098  273 
return $ 
274 
if not $ isMaster cl then 

275 
[ProtocolError "Not room master"] 

276 
else 

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

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

279 
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

280 
[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

281 
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

282 
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

283 
roomUpdate r = r{name = newName} 
5098  284 

285 

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

288 
maybeClientId < clientByNick kickNick 

289 
master < liftM isMaster thisClient 

290 
let kickId = fromJust maybeClientId 

4932  291 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId 
4614  292 
return 
293 
[KickRoomClient kickId  master && isJust maybeClientId && (kickId /= thisClientId) && sameRoom] 

1879  294 

1831  295 

4614  296 
handleCmd_inRoom ["TEAMCHAT", msg] = do 
297 
cl < thisClient 

298 
chans < roomSameClanChans 

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

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

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

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

7537
833a0c34fafc
Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents:
7321
diff
changeset

303 
handleCmd_inRoom ["BAN", banNick] = do 
8002  304 
(thisClientId, rnc) < ask 
7537
833a0c34fafc
Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents:
7321
diff
changeset

305 
maybeClientId < clientByNick banNick 
8002  306 
master < liftM isMaster thisClient 
7537
833a0c34fafc
Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents:
7321
diff
changeset

307 
let banId = fromJust maybeClientId 
8002  308 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc banId 
309 
if master && isJust maybeClientId && (banId /= thisClientId) && sameRoom then 

310 
return [ 

8189  311 
 ModifyRoom (\r > r{roomBansList = let h = host $ rnc `client` banId in h `deepseq` h : roomBansList r}) 
312 
KickRoomClient banId 

8002  313 
] 
314 
else 

315 
return [] 

7537
833a0c34fafc
Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents:
7321
diff
changeset

316 

833a0c34fafc
Room bans. They're more simple, than the global ones: if you ban someone, he is banned by ip in this room for the rest of the room lifetime. Not tested.
unc0rr
parents:
7321
diff
changeset

317 

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

318 
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

319 

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

320 
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

321 

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

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