author  unc0rr 
Fri, 14 Mar 2014 00:42:04 +0400  
changeset 10195  d1c23bb73346 
parent 10194  7025bd3c3131 
child 10212  5fb3bb2de9d2 
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 

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

5 
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

6 
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

7 
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

8 
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

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

12 
import Actions 

13 
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

14 
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

15 
import RoomsAndClients 
6068  16 
import EngineInteraction 
10039  17 
import Votes 
9995
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

18 

8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

19 
startGame :: Reader (ClientIndex, IRnC) [Action] 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

20 
startGame = do 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

21 
(ci, rnc) < ask 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

22 
cl < thisClient 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

23 
rm < thisRoom 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

24 
chans < roomClientsChans 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

25 

8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

26 
let nicks = map (nick . client rnc) . roomClients rnc $ clientRoom rnc ci 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

27 
let allPlayersRegistered = all ((<) 0 . B.length . webPassword . client rnc . teamownerId) $ teams rm 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

28 

8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

29 
if (playersIn rm == readyPlayers rm  clientProto cl > 43) && not (isJust $ gameInfo rm) then 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

30 
if enoughClans rm then 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

31 
return [ 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

32 
ModifyRoom 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

33 
(\r > r{ 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

34 
gameInfo = Just $ newGameInfo (teams rm) (length $ teams rm) allPlayersRegistered (mapParams rm) (params rm) 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

35 
} 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

36 
) 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

37 
, AnswerClients chans ["RUN_GAME"] 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

38 
, SendUpdateOnThisRoom 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

39 
, AnswerClients chans $ "CLIENT_FLAGS" : "+g" : nicks 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

40 
, ModifyRoomClients (\c > c{isInGame = True}) 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

41 
] 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

42 
else 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

43 
return [Warning $ loc "Less than two clans!"] 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

44 
else 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

45 
return [] 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

46 
where 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

47 
enoughClans = not . null . drop 1 . group . map teamcolor . teams 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

48 

8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

49 

8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

50 

4989  51 
handleCmd_inRoom :: CmdHandler 
1804  52 

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

54 
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

55 
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

56 
return [AnswerClients s ["CHAT", n, msg]] 
1804  57 

10095  58 
handleCmd_inRoom ["PART"] = return [MoveToLobby "part"] 
59 
handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg] 

3531  60 

1811  61 

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

62 
handleCmd_inRoom ("CFG" : paramName : paramStrs) 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

63 
 null paramStrs = return [ProtocolError $ loc "Empty config entry"] 
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 
 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

65 
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

66 
cl < thisClient 
9770  67 
rm < thisRoom 
68 

69 
if isSpecial rm then 

70 
return [Warning $ loc "Restricted"] 

71 
else if isMaster cl 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 
return [ 
4941  73 
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

74 
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

75 
else 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

76 
return [ProtocolError $ loc "Not room master"] 
4941  77 
where 
78 
f r = if paramName `Map.member` (mapParams r) then 

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

80 
else 

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

1804  82 

9753
9579596cf471
 Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents:
9715
diff
changeset

83 

4932  84 
handleCmd_inRoom ("ADD_TEAM" : tName : color : grave : fort : voicepack : flag : difStr : hhsInfo) 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

85 
 length hhsInfo /= 16 = return [ProtocolError $ loc "Corrupted hedgehogs info"] 
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 
 otherwise = do 
4932  87 
(ci, _) < ask 
88 
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

89 
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

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

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

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

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

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

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

98 
liftM (head . (L.\\) (map B.singleton ['0'..]) . map teamcolor . teams) thisRoom 
8421
fc39fe044a4f
Make number of hedgehogs restriction actually work in network game
unc0rr
parents:
8418
diff
changeset

99 
let roomTeams = teams rm 
8897
d6c310c65c91
 Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents:
8757
diff
changeset

100 
let hhNum = let p = if not $ null roomTeams then minimum [hhnum $ head roomTeams, canAddNumber roomTeams] else 4 in newTeamHHNum roomTeams p 
8421
fc39fe044a4f
Make number of hedgehogs restriction actually work in network game
unc0rr
parents:
8418
diff
changeset

101 
let newTeam = clNick `seq` TeamInfo ci clNick tName teamColor grave fort voicepack flag dif hhNum (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

102 
return $ 
8421
fc39fe044a4f
Make number of hedgehogs restriction actually work in network game
unc0rr
parents:
8418
diff
changeset

103 
if not . null . drop (maxTeams rm  1) $ roomTeams then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

104 
[Warning $ loc "too many teams"] 
8421
fc39fe044a4f
Make number of hedgehogs restriction actually work in network game
unc0rr
parents:
8418
diff
changeset

105 
else if canAddNumber roomTeams <= 0 then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

106 
[Warning $ loc "too many hedgehogs"] 
4932  107 
else if isJust $ findTeam rm then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

108 
[Warning $ loc "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

109 
else if isJust $ gameInfo rm then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

110 
[Warning $ loc "round in progress"] 
4932  111 
else if isRestrictedTeams rm then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

112 
[Warning $ loc "restricted"] 
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 
else 
7986
53b1da5ee7f4
Maybe this caused server crashes? Add more strictness on team owner record field
unc0rr
parents:
7947
diff
changeset

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

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

116 
ModifyClient (\c > c{teamsInGame = teamsInGame c + 1, clientClan = Just teamColor}), 
4932  117 
AnswerClients clChan ["TEAM_ACCEPTED", tName], 
8550
17378d33e62e
This change from r0cd63b963330 caused more troubles than solved. Also fix some warnings.
unc0rr
parents:
8541
diff
changeset

118 
AnswerClients othChans $ teamToNet $ newTeam, 
17378d33e62e
This change from r0cd63b963330 caused more troubles than solved. Also fix some warnings.
unc0rr
parents:
8541
diff
changeset

119 
AnswerClients roomChans ["TEAM_COLOR", tName, teamColor], 
8899  120 
AnswerClients roomChans ["HH_NUM", tName, showB $ hhnum newTeam] 
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

121 
] 
1f5604cd99be
This revision should, in 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 
where 
8421
fc39fe044a4f
Make number of hedgehogs restriction actually work in network game
unc0rr
parents:
8418
diff
changeset

123 
canAddNumber rt = (48::Int)  (sum $ map hhnum rt) 
4932  124 
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

125 
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

126 
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

127 
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

128 
hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs 
8421
fc39fe044a4f
Make number of hedgehogs restriction actually work in network game
unc0rr
parents:
8418
diff
changeset

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

130 
maxTeams r 
5931  131 
 roomProto r < 38 = 6 
132 
 otherwise = 8 

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

133 

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 

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

137 
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

138 

1f5604cd99be
This revision should, in 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 
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

140 
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

141 

1f5604cd99be
This revision should, in 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 
return $ 
8428  143 
if isNothing $ maybeTeam then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

144 
[Warning $ loc "REMOVE_TEAM: no such team"] 
8431  145 
else if ci /= teamownerId team then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

146 
[ProtocolError $ loc "Not team owner!"] 
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

147 
else 
4932  148 
[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

149 
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

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

151 
teamsInGame = teamsInGame c  1, 
8433  152 
clientClan = if teamsInGame c == 1 then Nothing else Just $ anotherTeamClan ci team r 
4989  153 
}) 
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 
] 
4568  155 
where 
8433  156 
anotherTeamClan ci team = teamcolor . fromMaybe (error "CHECKPOINT 011") . find (\t > (teamownerId t == ci) && (t /= team)) . teams 
4932  157 
findTeam = find (\t > tName == teamname t) . teams 
3561  158 

3568  159 

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

160 
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

161 
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

162 
r < thisRoom 
8421
fc39fe044a4f
Make number of hedgehogs restriction actually work in network game
unc0rr
parents:
8418
diff
changeset

163 
clChan < thisClientChans 
8477
330b0b8846cf
Don't confirm hogs number to room admin when no constraint hit
unc0rr
parents:
8433
diff
changeset

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

165 

1f5604cd99be
This revision should, in 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 
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

167 
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

168 

1f5604cd99be
This revision should, in 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 
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

170 
if not $ isMaster cl then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

171 
[ProtocolError $ loc "Not room master"] 
8429  172 
else if isNothing maybeTeam then 
173 
[] 

8428  174 
else if hhNumber < 1  hhNumber > 8  hhNumber > canAddNumber r + hhnum team then 
8421
fc39fe044a4f
Make number of hedgehogs restriction actually work in network game
unc0rr
parents:
8418
diff
changeset

175 
[AnswerClients clChan ["HH_NUM", teamName, showB $ hhnum team]] 
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

176 
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

177 
[ModifyRoom $ modifyTeam team{hhnum = hhNumber}, 
8477
330b0b8846cf
Don't confirm hogs number to room admin when no constraint hit
unc0rr
parents:
8433
diff
changeset

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

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

180 
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

181 
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

182 
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

183 

1804  184 

3568  185 

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

186 
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

187 
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

188 
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

189 
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

190 

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

191 
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

192 
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

193 

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

194 
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

195 
if not $ isMaster cl then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

196 
[ProtocolError $ loc "Not room master"] 
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

197 
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

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

199 
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

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

201 
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

202 
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

203 
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

204 
findTeam = find (\t > teamName == teamname t) . teams 
3568  205 

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

208 
cl < thisClient 
4932  209 
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

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

211 

9995
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

212 
(ci, rnc) < ask 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

213 
let ri = clientRoom rnc ci 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

214 
let unreadyClients = filter (not . isReady) . map (client rnc) $ roomClients rnc ri 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

215 

8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

216 
gs < if (not $ isReady cl) && (isSpecial rm) && (unreadyClients == [cl]) then startGame else return [] 
3577  217 

10017  218 
return $ 
9995
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

219 
ModifyRoom (\r > r{readyPlayers = readyPlayers r + (if isReady cl then 1 else 1)}) 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

220 
: ModifyClient (\c > c{isReady = not $ isReady cl}) 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

221 
: (AnswerClients chans $ if clientProto cl < 38 then 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

222 
[if isReady cl then "NOT_READY" else "READY", nick cl] 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

223 
else 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

224 
["CLIENT_FLAGS", if isReady cl then "r" else "+r", nick cl]) 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

225 
: gs 
1804  226 

227 

10194  228 
handleCmd_inRoom ["START_GAME"] = roomAdminOnly startGame 
9995
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

229 

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

230 
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

231 
cl < thisClient 
4932  232 
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

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

234 

8484
99c14f14f788
New checker of engine messages which is aware of glued together messages
unc0rr
parents:
8477
diff
changeset

235 
if teamsInGame cl > 0 && (isJust $ gameInfo rm) && (not $ B.null legalMsgs) then 
99c14f14f788
New checker of engine messages which is aware of glued together messages
unc0rr
parents:
8477
diff
changeset

236 
return $ AnswerClients chans ["EM", legalMsgs] 
10017  237 
: [ModifyRoom (\r > r{gameInfo = liftM 
9304
3f4c3fc146c2
Fix spectator desync in rare conditions (there was team which left during its turn, and last command with timestamp from it was '+')
unc0rr
parents:
9035
diff
changeset

238 
(\g > g{ 
3f4c3fc146c2
Fix spectator desync in rare conditions (there was team which left during its turn, and last command with timestamp from it was '+')
unc0rr
parents:
9035
diff
changeset

239 
roundMsgs = if B.null nonEmptyMsgs then roundMsgs g else nonEmptyMsgs : roundMsgs g 
3f4c3fc146c2
Fix spectator desync in rare conditions (there was team which left during its turn, and last command with timestamp from it was '+')
unc0rr
parents:
9035
diff
changeset

240 
, lastFilteredTimedMsg = fromMaybe (lastFilteredTimedMsg g) lastFTMsg}) 
10092  241 
$ gameInfo r}), RegisterEvent EngineMessage] 
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

242 
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

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

244 
where 
9304
3f4c3fc146c2
Fix spectator desync in rare conditions (there was team which left during its turn, and last command with timestamp from it was '+')
unc0rr
parents:
9035
diff
changeset

245 
(legalMsgs, nonEmptyMsgs, lastFTMsg) = checkNetCmd msg 
1804  246 

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

247 

8550
17378d33e62e
This change from r0cd63b963330 caused more troubles than solved. Also fix some warnings.
unc0rr
parents:
8541
diff
changeset

248 
handleCmd_inRoom ["ROUNDFINISHED", _] = 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

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

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

252 

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

253 
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

254 
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

255 

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

256 
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

257 
if isJust $ gameInfo rm then 
8422  258 
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

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

260 
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

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

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

263 
where 
8550
17378d33e62e
This change from r0cd63b963330 caused more troubles than solved. Also fix some warnings.
unc0rr
parents:
8541
diff
changeset

264 
 isCorrect = correctly == "1" 
1811  265 

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

266 
 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

267 
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

268 
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

269 

10194  270 
handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = roomAdminOnly $ 
271 
return [ModifyRoom (\r > r{isRestrictedJoins = not $ isRestrictedJoins r})] 

4568  272 

1831  273 

10194  274 
handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = roomAdminOnly $ 
275 
return [ModifyRoom (\r > r{isRestrictedTeams = not $ isRestrictedTeams r})] 

1879  276 

1831  277 

10194  278 
handleCmd_inRoom ["TOGGLE_REGISTERED_ONLY"] = roomAdminOnly $ 
279 
return [ModifyRoom (\r > r{isRegisteredOnly = not $ isRegisteredOnly r})] 

8232  280 

8484
99c14f14f788
New checker of engine messages which is aware of glued together messages
unc0rr
parents:
8477
diff
changeset

281 

10194  282 
handleCmd_inRoom ["ROOM_NAME", newName] = roomAdminOnly $ do 
5098  283 
cl < thisClient 
284 
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

285 
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

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

287 

5098  288 
return $ 
10017  289 
if illegalName newName then 
9454  290 
[Warning $ loc "Illegal room name"] 
291 
else 

9770  292 
if isSpecial rm then 
9753
9579596cf471
 Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents:
9715
diff
changeset

293 
[Warning $ loc "Restricted"] 
9579596cf471
 Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents:
9715
diff
changeset

294 
else 
5098  295 
if isJust $ find (\r > newName == name r) rs then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

296 
[Warning $ loc "Room with such name already exists"] 
5098  297 
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

298 
[ModifyRoom roomUpdate, 
9702  299 
AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo (clientProto cl) (nick cl) (roomUpdate rm))] 
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

300 
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

301 
roomUpdate r = r{name = newName} 
5098  302 

303 

10194  304 
handleCmd_inRoom ["KICK", kickNick] = roomAdminOnly $ do 
4614  305 
(thisClientId, rnc) < ask 
306 
maybeClientId < clientByNick kickNick 

8513  307 
rm < thisRoom 
4614  308 
let kickId = fromJust maybeClientId 
8513  309 
let kickCl = rnc `client` kickId 
4932  310 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId 
8627
ea2d32a03ac9
Eh, two players condition seems to make more sense than two clans here
unc0rr
parents:
8550
diff
changeset

311 
let notOnly2Players = (length . group . sort . map teamowner . teams $ rm) > 2 
4614  312 
return 
8513  313 
[KickRoomClient kickId  
10194  314 
isJust maybeClientId 
8513  315 
&& (kickId /= thisClientId) 
316 
&& sameRoom 

8627
ea2d32a03ac9
Eh, two players condition seems to make more sense than two clans here
unc0rr
parents:
8550
diff
changeset

317 
&& ((isNothing $ gameInfo rm)  notOnly2Players  teamsInGame kickCl == 0) 
8513  318 
] 
1879  319 

1831  320 

8247  321 
handleCmd_inRoom ["DELEGATE", newAdmin] = do 
322 
(thisClientId, rnc) < ask 

323 
maybeClientId < clientByNick newAdmin 

324 
master < liftM isMaster thisClient 

8403
fbc6e7602e05
 Allow server admins to use DELEGATE even when not room owner
unc0rr
parents:
8401
diff
changeset

325 
serverAdmin < liftM isAdministrator thisClient 
9715  326 
thisRoomMasterId < liftM masterID thisRoom 
8247  327 
let newAdminId = fromJust maybeClientId 
328 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc newAdminId 

329 
return 

8403
fbc6e7602e05
 Allow server admins to use DELEGATE even when not room owner
unc0rr
parents:
8401
diff
changeset

330 
[ChangeMaster (Just newAdminId)  
fbc6e7602e05
 Allow server admins to use DELEGATE even when not room owner
unc0rr
parents:
8401
diff
changeset

331 
(master  serverAdmin) 
fbc6e7602e05
 Allow server admins to use DELEGATE even when not room owner
unc0rr
parents:
8401
diff
changeset

332 
&& isJust maybeClientId 
9753
9579596cf471
 Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents:
9715
diff
changeset

333 
&& (Just newAdminId /= thisRoomMasterId) 
8403
fbc6e7602e05
 Allow server admins to use DELEGATE even when not room owner
unc0rr
parents:
8401
diff
changeset

334 
&& sameRoom] 
8247  335 

336 

4614  337 
handleCmd_inRoom ["TEAMCHAT", msg] = do 
338 
cl < thisClient 

339 
chans < roomSameClanChans 

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

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

341 
where 
8757  342 
engineMsg cl = toEngineMsg $ B.concat ["b", nick cl, " (team): ", msg, "\x20\x20"] 
4568  343 

8484
99c14f14f788
New checker of engine messages which is aware of glued together messages
unc0rr
parents:
8477
diff
changeset

344 

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

345 
handleCmd_inRoom ["BAN", banNick] = do 
8002  346 
(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

347 
maybeClientId < clientByNick banNick 
8002  348 
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

349 
let banId = fromJust maybeClientId 
8002  350 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc banId 
351 
if master && isJust maybeClientId && (banId /= thisClientId) && sameRoom then 

352 
return [ 

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

8002  355 
] 
356 
else 

357 
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

358 

9035
e84d42a4311c
'/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents:
8983
diff
changeset

359 
handleCmd_inRoom ("RND":rs) = do 
e84d42a4311c
'/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents:
8983
diff
changeset

360 
n < clientNick 
e84d42a4311c
'/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents:
8983
diff
changeset

361 
s < roomClientsChans 
e84d42a4311c
'/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents:
8983
diff
changeset

362 
return [AnswerClients s ["CHAT", n, B.unwords $ "/rnd" : rs], Random s rs] 
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

363 

10194  364 
handleCmd_inRoom ["FIX"] = serverAdminOnly $ 
365 
return [ModifyRoom (\r > r{isSpecial = True})] 

9753
9579596cf471
 Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents:
9715
diff
changeset

366 

10194  367 
handleCmd_inRoom ["UNFIX"] = serverAdminOnly $ 
368 
return [ModifyRoom (\r > r{isSpecial = False})] 

9770  369 

9787  370 
handleCmd_inRoom ["GREETING", msg] = do 
371 
cl < thisClient 

372 
rm < thisRoom 

373 
return [ModifyRoom (\r > r{greeting = msg})  isAdministrator cl  (isMaster cl && (not $ isSpecial rm))] 

9753
9579596cf471
 Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents:
9715
diff
changeset

374 

10039  375 

376 
handleCmd_inRoom ["CALLVOTE"] = do 

377 
cl < thisClient 

10195  378 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "Available callvote commands: kick <nickname>, map <name>"]] 
10039  379 

380 
handleCmd_inRoom ["CALLVOTE", "KICK"] = do 

381 
cl < thisClient 

382 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "callvote kick: specify nickname"]] 

383 

384 
handleCmd_inRoom ["CALLVOTE", "KICK", nickname] = do 

385 
(thisClientId, rnc) < ask 

386 
cl < thisClient 

10058  387 
rm < thisRoom 
10039  388 
maybeClientId < clientByNick nickname 
389 
let kickId = fromJust maybeClientId 

390 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId 

391 

10058  392 
if isNothing $ masterID rm then 
393 
return [] 

10039  394 
else 
10058  395 
if isJust maybeClientId && sameRoom then 
396 
startVote $ VoteKick nickname 

397 
else 

398 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "callvote kick: no such user"]] 

10039  399 

10195  400 

401 
handleCmd_inRoom ["CALLVOTE", "MAP", roomSave] = do 

402 
cl < thisClient 

403 
rm < thisRoom 

404 

405 
if Map.member roomSave $ roomSaves rm then 

406 
startVote $ VoteMap roomSave 

407 
else 

408 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "callvote map: no such map"]] 

409 

410 

10039  411 
handleCmd_inRoom ["VOTE", m] = do 
412 
cl < thisClient 

413 
let b = if m == "YES" then Just True else if m == "NO" then Just False else Nothing 

414 
if isJust b then 

10081  415 
voted (fromJust b) 
10039  416 
else 
417 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "vote: 'yes' or 'no'"]] 

418 

10194  419 

420 
handleCmd_inRoom ["SAVE", stateName] = serverAdminOnly $ do 

421 
return [ModifyRoom $ \r > r{roomSaves = Map.insert stateName (mapParams r, params r) (roomSaves r)}] 

422 

423 
handleCmd_inRoom ["DELETE", stateName] = serverAdminOnly $ do 

424 
return [ModifyRoom $ \r > r{roomSaves = Map.delete stateName (roomSaves r)}] 

425 

10195  426 
handleCmd_inRoom ["SAVEROOM", fileName] = serverAdminOnly $ do 
427 
return [SaveRoom fileName] 

10194  428 

10195  429 
handleCmd_inRoom ["LOADROOM", fileName] = serverAdminOnly $ do 
430 
return [LoadRoom fileName] 

431 

432 

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

433 
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

434 

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

435 
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

436 

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

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