author  Wuzzy <almikes@aol.com> 
Wed, 13 Apr 2016 02:44:37 +0200  
changeset 11726  4addfad422ab 
parent 11575  db7743e2fad1 
child 12114  cdadc1d487f1 
permissions  rwrr 
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

1 
{ 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

2 
* Hedgewars, a free turn based strategy game 
11046  3 
* Copyright (c) 20042015 Andrey Korotaev <unC0Rr@gmail.com> 
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

4 
* 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

5 
* This program is free software; you can redistribute it and/or modify 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

6 
* it under the terms of the GNU General Public License as published by 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

7 
* the Free Software Foundation; version 2 of the License 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

8 
* 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

9 
* This program is distributed in the hope that it will be useful, 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

10 
* but WITHOUT ANY WARRANTY; without even the implied warranty of 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

11 
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

12 
* GNU General Public License for more details. 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

13 
* 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

14 
* You should have received a copy of the GNU General Public License 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

15 
* along with this program; if not, write to the Free Software 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

16 
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 021101301 USA. 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

17 
\} 
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

18 

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

19 
{# LANGUAGE OverloadedStrings #} 
1804  20 
module HWProtoInRoomState where 
21 

22 
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

23 
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

24 
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

25 
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

26 
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

27 
import Control.Monad.Reader 
1804  28 
 
29 
import CoreTypes 

30 
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

31 
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

32 
import RoomsAndClients 
6068  33 
import EngineInteraction 
10039  34 
import Votes 
9995
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 
startGame :: Reader (ClientIndex, IRnC) [Action] 
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

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

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

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

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

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

42 

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

43 
let nicks = map (nick . client rnc) . roomClients rnc $ clientRoom rnc ci 
10732
7c4f9e5e447c
Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents:
10730
diff
changeset

44 
let allPlayersRegistered = all isOwnerRegistered $ teams rm 
9995
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

45 

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

46 
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

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

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

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

50 
(\r > r{ 
10392  51 
gameInfo = Just $ newGameInfo (teams rm) (length $ teams rm) allPlayersRegistered (mapParams rm) (params rm) False 
9995
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

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

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

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

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

56 
, AnswerClients chans $ "CLIENT_FLAGS" : "+g" : nicks 
11557  57 
, ModifyRoomClients (\c > c{isInGame = True, teamIndexes = map snd . filter (\(t, _) > teamowner t == nick c) $ zip (teams rm) [0..]}) 
9995
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

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

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

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

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

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

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

64 
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

65 

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

66 

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

67 

4989  68 
handleCmd_inRoom :: CmdHandler 
1804  69 

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

71 
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

72 
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

73 
return [AnswerClients s ["CHAT", n, msg]] 
1804  74 

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

3531  77 

1811  78 

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

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

80 
 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

81 
 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

82 
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

83 
cl < thisClient 
9770  84 
rm < thisRoom 
85 

86 
if isSpecial rm then 

87 
return [Warning $ loc "Restricted"] 

88 
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

89 
return [ 
10730
eac6a4d53752
Serverside workaround for frontend's script parameter bug in .21
unc0rr
parents:
10511
diff
changeset

90 
ModifyRoom $ f (clientProto cl), 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

91 
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

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

93 
return [ProtocolError $ loc "Not room master"] 
4941  94 
where 
10730
eac6a4d53752
Serverside workaround for frontend's script parameter bug in .21
unc0rr
parents:
10511
diff
changeset

95 
f clproto r = if paramName `Map.member` (mapParams r) then 
4941  96 
r{mapParams = Map.insert paramName (head paramStrs) (mapParams r)} 
97 
else 

10730
eac6a4d53752
Serverside workaround for frontend's script parameter bug in .21
unc0rr
parents:
10511
diff
changeset

98 
r{params = Map.insert paramName (fixedParamStr clproto) (params r)} 
eac6a4d53752
Serverside workaround for frontend's script parameter bug in .21
unc0rr
parents:
10511
diff
changeset

99 
fixedParamStr clproto 
eac6a4d53752
Serverside workaround for frontend's script parameter bug in .21
unc0rr
parents:
10511
diff
changeset

100 
 clproto /= 49 = paramStrs 
eac6a4d53752
Serverside workaround for frontend's script parameter bug in .21
unc0rr
parents:
10511
diff
changeset

101 
 paramName /= "SCHEME" = paramStrs 
eac6a4d53752
Serverside workaround for frontend's script parameter bug in .21
unc0rr
parents:
10511
diff
changeset

102 
 otherwise = L.init paramStrs ++ [B.replicate 50 'X' `B.append` L.last paramStrs] 
1804  103 

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

104 

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

106 
 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

107 
 otherwise = do 
4932  108 
rm < thisRoom 
10732
7c4f9e5e447c
Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents:
10730
diff
changeset

109 
cl < thisClient 
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

110 
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

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

113 
roomChans < roomClientsChans 
10732
7c4f9e5e447c
Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents:
10730
diff
changeset

114 
let isRegistered = (<) 0 . B.length . webPassword $ cl 
7862
bd76ca40db68
Choose first unused color for added team (addresses issue 431) + other small changes
unc0rr
parents:
7775
diff
changeset

115 
teamColor < 
8924  116 
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

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

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

119 
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

120 
let roomTeams = teams rm 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

121 
let hhNum = newTeamHHNum roomTeams $ 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

122 
if not $ null roomTeams then 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

123 
minimum [hhnum $ head roomTeams, canAddNumber roomTeams] 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

124 
else 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

125 
defaultHedgehogsNumber rm 
10732
7c4f9e5e447c
Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents:
10730
diff
changeset

126 
let newTeam = clNick `seq` TeamInfo clNick tName teamColor grave fort voicepack flag isRegistered 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

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

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

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

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

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

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

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

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

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

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

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

141 
ModifyClient (\c > c{teamsInGame = teamsInGame c + 1, clientClan = Just teamColor}), 
4932  142 
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

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

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

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

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

150 
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

151 
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

152 
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

153 
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

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

155 
maxTeams r 
5931  156 
 roomProto r < 38 = 6 
157 
 otherwise = 8 

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

158 

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

159 

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

162 
r < thisRoom 
10732
7c4f9e5e447c
Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents:
10730
diff
changeset

163 
clNick < clientNick 
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

164 

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

166 
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

167 

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

170 
[Warning $ loc "REMOVE_TEAM: no such team"] 
10732
7c4f9e5e447c
Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents:
10730
diff
changeset

171 
else if clNick /= teamowner team then 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8369
diff
changeset

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

173 
else 
4932  174 
[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

175 
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

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

177 
teamsInGame = teamsInGame c  1, 
11414
6f119783a1ad
Remove CHECKPOINT 011 occurence, probably hiding some bug
unc0rr
parents:
11046
diff
changeset

178 
clientClan = if teamsInGame c == 1 then Nothing else anotherTeamClan clNick team r 
4989  179 
}) 
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

180 
] 
4568  181 
where 
11414
6f119783a1ad
Remove CHECKPOINT 011 occurence, probably hiding some bug
unc0rr
parents:
11046
diff
changeset

182 
anotherTeamClan clNick team = liftM teamcolor . find (\t > (teamowner t == clNick) && (t /= team)) . teams 
4932  183 
findTeam = find (\t > tName == teamname t) . teams 
3561  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 ["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

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 
r < thisRoom 
8421
fc39fe044a4f
Make number of hedgehogs restriction actually work in network game
unc0rr
parents:
8418
diff
changeset

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

190 
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

191 

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

193 
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

194 

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

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

197 
[ProtocolError $ loc "Not room master"] 
8429  198 
else if isNothing maybeTeam then 
199 
[] 

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

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

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

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

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

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

206 
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

207 
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

208 
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

209 

1804  210 

3568  211 

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

212 
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

213 
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

214 
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

215 
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

216 

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

217 
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

218 
let team = fromJust maybeTeam 
10732
7c4f9e5e447c
Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents:
10730
diff
changeset

219 
maybeClientId < clientByNick $ teamowner team 
7c4f9e5e447c
Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents:
10730
diff
changeset

220 
let teamOwnerId = fromJust maybeClientId 
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

221 

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

222 
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

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

224 
[ProtocolError $ loc "Not room master"] 
10732
7c4f9e5e447c
Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents:
10730
diff
changeset

225 
else if isNothing maybeTeam  isNothing maybeClientId 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

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

227 
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

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

229 
AnswerClients others ["TEAM_COLOR", teamName, newColor], 
10732
7c4f9e5e447c
Get rid of teamownerId since rejoin feature makes it virtually useless, as you cannot rely on it anymore. Should fix recently experienced server crashes.
unc0rr
parents:
10730
diff
changeset

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

231 
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

232 
findTeam = find (\t > teamName == teamname t) . teams 
3568  233 

1804  234 

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

235 
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

236 
cl < thisClient 
4932  237 
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

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

239 

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

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

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

242 
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

243 

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

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

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

247 
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

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

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

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

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

252 
["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

253 
: gs 
1804  254 

255 

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

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

259 
cl < thisClient 
4932  260 
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

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

262 

11556
af9aa8d5863c
Filter out hog speech messages with nonlocal team index (not tested)
unc0rr
parents:
11508
diff
changeset

263 
let (legalMsgs, nonEmptyMsgs, lastFTMsg) = checkNetCmd (teamIndexes cl) msg 
af9aa8d5863c
Filter out hog speech messages with nonlocal team index (not tested)
unc0rr
parents:
11508
diff
changeset

264 

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

265 
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

266 
return $ AnswerClients chans ["EM", legalMsgs] 
10017  267 
: [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

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

269 
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

270 
, lastFilteredTimedMsg = fromMaybe (lastFilteredTimedMsg g) lastFTMsg}) 
10092  271 
$ 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

272 
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

273 
return [] 
1804  274 

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

275 

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

276 
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

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

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

280 

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

281 
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

282 
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

283 

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

284 
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

285 
if isJust $ gameInfo rm then 
8422  286 
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

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

288 
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

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

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

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

292 
 isCorrect = correctly == "1" 
1811  293 

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

294 
 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

295 
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

296 
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

297 

10194  298 
handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = roomAdminOnly $ 
10511
c33b2f001730
This should work, can't test: room flags passed in room info message instead of just 'ingame' state, including 'ingame', 'restricted joins', 'registered only' and 'passworded' flags
unc0rr
parents:
10460
diff
changeset

299 
return [ModifyRoom (\r > r{isRestrictedJoins = not $ isRestrictedJoins r}), SendUpdateOnThisRoom] 
4568  300 

1831  301 

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

1879  304 

1831  305 

10194  306 
handleCmd_inRoom ["TOGGLE_REGISTERED_ONLY"] = roomAdminOnly $ 
10511
c33b2f001730
This should work, can't test: room flags passed in room info message instead of just 'ingame' state, including 'ingame', 'restricted joins', 'registered only' and 'passworded' flags
unc0rr
parents:
10460
diff
changeset

307 
return [ModifyRoom (\r > r{isRegisteredOnly = not $ isRegisteredOnly r}), SendUpdateOnThisRoom] 
8232  308 

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

309 

10194  310 
handleCmd_inRoom ["ROOM_NAME", newName] = roomAdminOnly $ do 
5098  311 
cl < thisClient 
312 
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

313 
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

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

315 

5098  316 
return $ 
10017  317 
if illegalName newName then 
9454  318 
[Warning $ loc "Illegal room name"] 
319 
else 

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

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

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

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

326 
[ModifyRoom roomUpdate, 
9702  327 
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

328 
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

329 
roomUpdate r = r{name = newName} 
5098  330 

331 

10194  332 
handleCmd_inRoom ["KICK", kickNick] = roomAdminOnly $ do 
4614  333 
(thisClientId, rnc) < ask 
334 
maybeClientId < clientByNick kickNick 

8513  335 
rm < thisRoom 
4614  336 
let kickId = fromJust maybeClientId 
8513  337 
let kickCl = rnc `client` kickId 
4932  338 
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

339 
let notOnly2Players = (length . group . sort . map teamowner . teams $ rm) > 2 
4614  340 
return 
8513  341 
[KickRoomClient kickId  
10194  342 
isJust maybeClientId 
8513  343 
&& (kickId /= thisClientId) 
344 
&& sameRoom 

11508
a4ad8a9e0f69
Don't allow to kick an admin with super power enabled
unc0rr
parents:
11414
diff
changeset

345 
&& (not $ hasSuperPower kickCl) 
8627
ea2d32a03ac9
Eh, two players condition seems to make more sense than two clans here
unc0rr
parents:
8550
diff
changeset

346 
&& ((isNothing $ gameInfo rm)  notOnly2Players  teamsInGame kickCl == 0) 
8513  347 
] 
1879  348 

1831  349 

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

352 
maybeClientId < clientByNick newAdmin 

353 
master < liftM isMaster thisClient 

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

354 
serverAdmin < liftM isAdministrator thisClient 
9715  355 
thisRoomMasterId < liftM masterID thisRoom 
8247  356 
let newAdminId = fromJust maybeClientId 
357 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc newAdminId 

358 
return 

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

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

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

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

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

363 
&& sameRoom] 
8247  364 

365 

4614  366 
handleCmd_inRoom ["TEAMCHAT", msg] = do 
367 
cl < thisClient 

368 
chans < roomSameClanChans 

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

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

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

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

373 

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

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

376 
maybeClientId < clientByNick banNick 
8002  377 
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

378 
let banId = fromJust maybeClientId 
8002  379 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc banId 
380 
if master && isJust maybeClientId && (banId /= thisClientId) && sameRoom then 

381 
return [ 

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

8002  384 
] 
385 
else 

386 
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

387 

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

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

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

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

391 
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

392 

10882
ed7717f659ae
 Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset

393 

ed7717f659ae
 Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset

394 
handleCmd_inRoom ["MAXTEAMS", n] = roomAdminOnly $ do 
ed7717f659ae
 Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset

395 
cl < thisClient 
ed7717f659ae
 Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset

396 
let m = readInt_ n 
ed7717f659ae
 Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset

397 
if m < 2  m > 8 then 
ed7717f659ae
 Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset

398 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "/maxteams: specify number from 2 to 8"]] 
ed7717f659ae
 Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset

399 
else 
ed7717f659ae
 Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset

400 
return [ModifyRoom (\r > r{teamsNumberLimit = m})] 
ed7717f659ae
 Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset

401 

10194  402 
handleCmd_inRoom ["FIX"] = serverAdminOnly $ 
403 
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

404 

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

9770  407 

9787  408 
handleCmd_inRoom ["GREETING", msg] = do 
409 
cl < thisClient 

410 
rm < thisRoom 

411 
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

412 

10039  413 

414 
handleCmd_inRoom ["CALLVOTE"] = do 

415 
cl < thisClient 

10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

416 
return [AnswerClients [sendChan cl] 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

417 
["CHAT", "[server]", loc "Available callvote commands: kick <nickname>, map <name>, pause, newseed, hedgehogs"] 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

418 
] 
10039  419 

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

421 
cl < thisClient 

10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

422 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "callvote kick: specify nickname"]] 
10039  423 

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

425 
(thisClientId, rnc) < ask 

426 
cl < thisClient 

10058  427 
rm < thisRoom 
10039  428 
maybeClientId < clientByNick nickname 
429 
let kickId = fromJust maybeClientId 

430 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId 

431 

10217  432 
if isJust $ masterID rm then 
10058  433 
return [] 
10039  434 
else 
10058  435 
if isJust maybeClientId && sameRoom then 
436 
startVote $ VoteKick nickname 

437 
else 

10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

438 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "callvote kick: no such user"]] 
10039  439 

10195  440 

10212  441 
handleCmd_inRoom ["CALLVOTE", "MAP"] = do 
442 
cl < thisClient 

443 
s < liftM (Map.keys . roomSaves) thisRoom 

444 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", B.concat ["callvote map: ", B.intercalate ", " s]]] 

445 

446 

10195  447 
handleCmd_inRoom ["CALLVOTE", "MAP", roomSave] = do 
448 
cl < thisClient 

449 
rm < thisRoom 

450 

451 
if Map.member roomSave $ roomSaves rm then 

452 
startVote $ VoteMap roomSave 

453 
else 

10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

454 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "callvote map: no such map"]] 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

455 

10195  456 

10392  457 
handleCmd_inRoom ["CALLVOTE", "PAUSE"] = do 
458 
cl < thisClient 

459 
rm < thisRoom 

460 

461 
if isJust $ gameInfo rm then 

10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

462 
startVote VotePause 
10392  463 
else 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

464 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "callvote pause: no game in progress"]] 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

465 

712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

466 

712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

467 
handleCmd_inRoom ["CALLVOTE", "NEWSEED"] = do 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

468 
startVote VoteNewSeed 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

469 

712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

470 

712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

471 
handleCmd_inRoom ["CALLVOTE", "HEDGEHOGS"] = do 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

472 
cl < thisClient 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

473 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "callvote hedgehogs: specify number from 1 to 8"]] 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

474 

712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

475 

712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

476 
handleCmd_inRoom ["CALLVOTE", "HEDGEHOGS", hhs] = do 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

477 
cl < thisClient 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

478 
let h = readInt_ hhs 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

479 

712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

480 
if h > 0 && h <= 8 then 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

481 
startVote $ VoteHedgehogsPerTeam h 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

482 
else 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

483 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "callvote hedgehogs: specify number from 1 to 8"]] 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

484 

10195  485 

10881
941b5ab9e5a6
"/force" command for server admin to force voting result
unc0rr
parents:
10786
diff
changeset

486 
handleCmd_inRoom ("VOTE" : m : p) = do 
10039  487 
cl < thisClient 
488 
let b = if m == "YES" then Just True else if m == "NO" then Just False else Nothing 

489 
if isJust b then 

10881
941b5ab9e5a6
"/force" command for server admin to force voting result
unc0rr
parents:
10786
diff
changeset

490 
voted (p == ["FORCE"]) (fromJust b) 
10039  491 
else 
492 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", "vote: 'yes' or 'no'"]] 

493 

10194  494 

11575  495 
handleCmd_inRoom ["SAVE", stateName, location] = serverAdminOnly $ do 
496 
return [ModifyRoom $ \r > r{roomSaves = Map.insert stateName (location, mapParams r, params r) (roomSaves r)}] 

10194  497 

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

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

500 

10195  501 
handleCmd_inRoom ["SAVEROOM", fileName] = serverAdminOnly $ do 
502 
return [SaveRoom fileName] 

10194  503 

10195  504 
handleCmd_inRoom ["LOADROOM", fileName] = serverAdminOnly $ do 
505 
return [LoadRoom fileName] 

506 

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

507 
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

508 

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

509 
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

510 

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

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