author  Wuzzy <Wuzzy2@mail.ru> 
Mon, 21 Jan 2019 19:28:39 +0100  
changeset 14648  be8af70adf2c 
parent 14447  b444f100a625 
child 14841  111c4d750c6d 
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 

13504
f747c385b5ba
Server: Replace hardcoded hogrelated numbers with consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13079
diff
changeset

30 
import Consts 
1804  31 
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

32 
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

33 
import RoomsAndClients 
6068  34 
import EngineInteraction 
10039  35 
import Votes 
13509
9ba5e4594322
Refactor server chat command help, also add admin commands to help
Wuzzy <Wuzzy2@mail.ru>
parents:
13508
diff
changeset

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

37 

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

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

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

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

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

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

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

44 

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

45 
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

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

47 

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

48 
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

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

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

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

52 
(\r > r{ 
10392  53 
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

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

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

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

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

58 
, AnswerClients chans $ "CLIENT_FLAGS" : "+g" : nicks 
11557  59 
, 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

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

61 
else 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

62 
return [Warning $ loc "The game can't be started with less than two clans!"] 
9995
8bf092ddc536
In special rooms game starts when all players are ready
unc0rr
parents:
9787
diff
changeset

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

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

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

66 
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

67 

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

68 

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

69 

4989  70 
handleCmd_inRoom :: CmdHandler 
1804  71 

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

73 
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

74 
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

75 
return [AnswerClients s ["CHAT", n, msg]] 
1804  76 

13673
1aa5e884326a
Fix some string/translation inconsistencies in strings related to leaving
Wuzzy <Wuzzy2@mail.ru>
parents:
13510
diff
changeset

77 
 Leave room normally 
1aa5e884326a
Fix some string/translation inconsistencies in strings related to leaving
Wuzzy <Wuzzy2@mail.ru>
parents:
13510
diff
changeset

78 
handleCmd_inRoom ["PART"] = return [MoveToLobby ""] 
13846  79 
handleCmd_inRoom ["PART", _] = return [MoveToLobby ""] 
3531  80 

1811  81 

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

82 
handleCmd_inRoom ("CFG" : paramName : paramStrs) 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

83 
 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

84 
 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

85 
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

86 
cl < thisClient 
9770  87 
rm < thisRoom 
88 

89 
if isSpecial rm then 

13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

90 
return [Warning $ loc "Access denied."] 
9770  91 
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

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

93 
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

94 
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

95 
else 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

96 
return [ProtocolError $ loc "You're not the room master!"] 
4941  97 
where 
10730
eac6a4d53752
Serverside workaround for frontend's script parameter bug in .21
unc0rr
parents:
10511
diff
changeset

98 
f clproto r = if paramName `Map.member` (mapParams r) then 
4941  99 
r{mapParams = Map.insert paramName (head paramStrs) (mapParams r)} 
100 
else 

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

101 
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

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

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

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

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

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

107 

4932  108 
handleCmd_inRoom ("ADD_TEAM" : tName : color : grave : fort : voicepack : flag : difStr : hhsInfo) 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

109 
 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

110 
 otherwise = do 
4932  111 
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

112 
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

113 
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

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

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

117 
teamColor < 
8924  118 
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

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

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

121 
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

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

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

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

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

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

127 
defaultHedgehogsNumber rm 
12114
cdadc1d487f1
Only registered players regain their teams on rejoin
unc0rr
parents:
11575
diff
changeset

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

129 
return $ 
10884  130 
if not . null . drop (teamsNumberLimit rm  1) $ roomTeams then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

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

132 
else if canAddNumber roomTeams <= 0 then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

133 
[Warning $ loc "Too many hedgehogs!"] 
4932  134 
else if isJust $ findTeam rm then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

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

136 
else if isJust $ gameInfo rm then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

137 
[Warning $ loc "Joining not possible: Round is in progress."] 
4932  138 
else if isRestrictedTeams rm then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

139 
[Warning $ loc "This room currently does not allow adding new teams."] 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

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

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

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

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

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

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

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

149 
where 
13504
f747c385b5ba
Server: Replace hardcoded hogrelated numbers with consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13079
diff
changeset

150 
canAddNumber rt = (cMaxHHs)  (sum $ map hhnum rt) 
4932  151 
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

152 
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

153 
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

154 
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

155 
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

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

157 
maxTeams r 
5931  158 
 roomProto r < 38 = 6 
13504
f747c385b5ba
Server: Replace hardcoded hogrelated numbers with consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13079
diff
changeset

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

160 

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

161 

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

164 
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

165 
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

166 

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

168 
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

169 

1f5604cd99be
This revision should, in 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 
return $ 
8428  171 
if isNothing $ maybeTeam then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

172 
[Warning $ loc "Error: The team you tried to remove does not exist."] 
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

173 
else if clNick /= teamowner team then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

174 
[ProtocolError $ loc "You can't remove a team you don't own."] 
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 
else 
4932  176 
[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

177 
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

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

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

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

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

184 
anotherTeamClan clNick team = liftM teamcolor . find (\t > (teamowner t == clNick) && (t /= team)) . teams 
4932  185 
findTeam = find (\t > tName == teamname t) . teams 
3561  186 

3568  187 

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

188 
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

189 
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

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

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

192 
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

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

195 
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

196 

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

198 
if not $ isMaster cl then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

199 
[ProtocolError $ loc "You're not the room master!"] 
8429  200 
else if isNothing maybeTeam then 
201 
[] 

13504
f747c385b5ba
Server: Replace hardcoded hogrelated numbers with consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13079
diff
changeset

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

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

204 
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

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

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

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

208 
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

209 
findTeam = find (\t > teamName == teamname t) . teams 
13504
f747c385b5ba
Server: Replace hardcoded hogrelated numbers with consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13079
diff
changeset

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

211 

1804  212 

3568  213 

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

214 
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

215 
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

216 
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

217 
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

218 

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

219 
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

220 
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

221 
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

222 
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

223 

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

224 
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

225 
if not $ isMaster cl then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

226 
[ProtocolError $ loc "You're not the 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

227 
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

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

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

231 
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

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

233 
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

234 
findTeam = find (\t > teamName == teamname t) . teams 
3568  235 

1804  236 

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

237 
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

238 
cl < thisClient 
4932  239 
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

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

241 

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

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

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

244 
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

245 

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

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

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

249 
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

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

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

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

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

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

255 
: gs 
1804  256 

257 

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

259 

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

260 
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

261 
cl < thisClient 
4932  262 
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

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

264 

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

265 
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

266 

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

267 
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

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

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

271 
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

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

274 
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

275 
return [] 
1804  276 

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 

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

278 
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

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

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

282 

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

283 
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

284 
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

285 

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

286 
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

287 
if isJust $ gameInfo rm then 
8422  288 
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

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

290 
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

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

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

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

294 
 isCorrect = correctly == "1" 
1811  295 

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

296 
 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

297 
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

298 
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

299 

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

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

1831  303 

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

1879  306 

1831  307 

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

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

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

311 

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

315 
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

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

317 

5098  318 
return $ 
10017  319 
if illegalName newName then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

320 
[Warning $ loc "Illegal room name! The room name must be between 140 characters long, must not have a trailing or leading space and must not have any of these characters: $()*+?[]^{}"] 
9454  321 
else 
9770  322 
if isSpecial rm then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

323 
[Warning $ loc "Access denied."] 
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

324 
else 
5098  325 
if isJust $ find (\r > newName == name r) rs then 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
12114
diff
changeset

326 
[Warning $ loc "A room with the same name already exists."] 
5098  327 
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

328 
[ModifyRoom roomUpdate, 
9702  329 
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

330 
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

331 
roomUpdate r = r{name = newName} 
5098  332 

333 

10194  334 
handleCmd_inRoom ["KICK", kickNick] = roomAdminOnly $ do 
4614  335 
(thisClientId, rnc) < ask 
13697
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

336 
maybeKickId < clientByNick kickNick 
8513  337 
rm < thisRoom 
13697
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

338 
let kickId = fromJust maybeKickId 
8513  339 
let kickCl = rnc `client` kickId 
4932  340 
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

341 
let notOnly2Players = (length . group . sort . map teamowner . teams $ rm) > 2 
13697
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

342 
return $ 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

343 
 Catch some error conditions 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

344 
if (isNothing maybeKickId) then 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

345 
[Warning $ loc "Player is not online."] 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

346 
else if (kickId == thisClientId) then 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

347 
[Warning $ loc "You can't kick yourself!"] 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

348 
else if (not ((isNothing $ gameInfo rm)  notOnly2Players  teamsInGame kickCl == 0)) then 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

349 
[Warning $ loc "You can't kick the only other player!"] 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

350 
else if (not sameRoom) then 
13703
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

351 
[Warning $ loc "The player is not in your room."] 
13697
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

352 
else if (hasSuperPower kickCl) then 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

353 
[Warning $ loc "This player is protected from being kicked."] 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

354 
else 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

355 
 Kick! 
7f174e7285e5
Add a few helpful error messages from server when kicking failed
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

356 
[KickRoomClient kickId] 
1831  357 

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

360 
maybeClientId < clientByNick newAdmin 

361 
master < liftM isMaster thisClient 

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

362 
serverAdmin < liftM isAdministrator thisClient 
9715  363 
thisRoomMasterId < liftM masterID thisRoom 
8247  364 
let newAdminId = fromJust maybeClientId 
365 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc newAdminId 

13703
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

366 
return $ 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

367 
if (not (master  serverAdmin)) then 
13712  368 
[Warning $ loc "You're not the room master or a server admin!"] 
13703
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

369 
else if (isNothing maybeClientId) then 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

370 
[Warning $ loc "Player is not online."] 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

371 
else if (Just newAdminId == thisRoomMasterId) then 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

372 
[Warning $ loc "You're already the room master."] 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

373 
else if (not sameRoom) then 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

374 
[Warning $ loc "The player is not in your room."] 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

375 
else 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

376 
[ChangeMaster (Just newAdminId)] 
8247  377 

4614  378 
handleCmd_inRoom ["TEAMCHAT", msg] = do 
379 
cl < thisClient 

380 
chans < roomSameClanChans 

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

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

382 
where 
13828
76a1d6275cd3
Teach engine to properly display clan message received from the net
Wuzzy <Wuzzy2@mail.ru>
parents:
13729
diff
changeset

383 
 This is formatted in a way so it can parsed by engine to make it translatable 
76a1d6275cd3
Teach engine to properly display clan message received from the net
Wuzzy <Wuzzy2@mail.ru>
parents:
13729
diff
changeset

384 
 Format: b<PLAYER NAME>]<MESSAGE> 
14447  385 
engineMsg cl = toEngineMsg $ B.concat ["b", nick cl, "]", msg, "\x20\x20"] 
4568  386 

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

387 

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

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

390 
maybeClientId < clientByNick banNick 
8002  391 
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

392 
let banId = fromJust maybeClientId 
8002  393 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc banId 
394 
if master && isJust maybeClientId && (banId /= thisClientId) && sameRoom then 

395 
return [ 

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

8002  398 
] 
399 
else 

400 
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

401 

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

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

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

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

405 
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

406 

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

407 

13729
f4c8c6a174e8
Display error when using /maxteams if not room master
Wuzzy <Wuzzy2@mail.ru>
parents:
13712
diff
changeset

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

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

410 
let m = readInt_ n 
13729
f4c8c6a174e8
Display error when using /maxteams if not room master
Wuzzy <Wuzzy2@mail.ru>
parents:
13712
diff
changeset

411 
if not $ isMaster cl then 
f4c8c6a174e8
Display error when using /maxteams if not room master
Wuzzy <Wuzzy2@mail.ru>
parents:
13712
diff
changeset

412 
return [Warning $ loc "You're not the room master!"] 
f4c8c6a174e8
Display error when using /maxteams if not room master
Wuzzy <Wuzzy2@mail.ru>
parents:
13712
diff
changeset

413 
else if m < 2  m > cMaxTeams then 
14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

414 
return [Warning $ loc "/maxteams: specify number from 2 to 8"] 
10882
ed7717f659ae
 Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset

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

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

417 

14118
589a752c01ca
GameServer: Print syntax help if calling /maxteams without argument
Wuzzy <Wuzzy2@mail.ru>
parents:
14117
diff
changeset

418 
handleCmd_inRoom ["MAXTEAMS"] = handleCmd_inRoom ["MAXTEAMS", ""] 
589a752c01ca
GameServer: Print syntax help if calling /maxteams without argument
Wuzzy <Wuzzy2@mail.ru>
parents:
14117
diff
changeset

419 

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

422 

13703
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

423 
handleCmd_inRoom ["UNFIX"] = serverAdminOnly $ do 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

424 
cl < thisClient 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

425 
return $ if not $ isMaster cl then 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

426 
[Warning $ loc "You're not the room master!"] 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

427 
else 
2df519242d41
Add a couple of more useful server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
13700
diff
changeset

428 
[ModifyRoom (\r > r{isSpecial = False})] 
9770  429 

13508
da59012fbd7a
Add /help command for lobby and rooms too
Wuzzy <Wuzzy2@mail.ru>
parents:
13504
diff
changeset

430 
handleCmd_inRoom ["HELP"] = do 
da59012fbd7a
Add /help command for lobby and rooms too
Wuzzy <Wuzzy2@mail.ru>
parents:
13504
diff
changeset

431 
cl < thisClient 
13509
9ba5e4594322
Refactor server chat command help, also add admin commands to help
Wuzzy <Wuzzy2@mail.ru>
parents:
13508
diff
changeset

432 
if isAdministrator cl then 
9ba5e4594322
Refactor server chat command help, also add admin commands to help
Wuzzy <Wuzzy2@mail.ru>
parents:
13508
diff
changeset

433 
return (cmdHelpActionList [sendChan cl] cmdHelpRoomAdmin) 
9ba5e4594322
Refactor server chat command help, also add admin commands to help
Wuzzy <Wuzzy2@mail.ru>
parents:
13508
diff
changeset

434 
else 
9ba5e4594322
Refactor server chat command help, also add admin commands to help
Wuzzy <Wuzzy2@mail.ru>
parents:
13508
diff
changeset

435 
return (cmdHelpActionList [sendChan cl] cmdHelpRoomPlayer) 
13508
da59012fbd7a
Add /help command for lobby and rooms too
Wuzzy <Wuzzy2@mail.ru>
parents:
13504
diff
changeset

436 

9787  437 
handleCmd_inRoom ["GREETING", msg] = do 
438 
cl < thisClient 

439 
rm < thisRoom 

13704
54eb4c774ef5
/greeting chat commands now clears greeting if called w/o arguments
Wuzzy <Wuzzy2@mail.ru>
parents:
13703
diff
changeset

440 
return $ if (not (isAdministrator cl  (isMaster cl && (not $ isSpecial rm)))) then 
54eb4c774ef5
/greeting chat commands now clears greeting if called w/o arguments
Wuzzy <Wuzzy2@mail.ru>
parents:
13703
diff
changeset

441 
[Warning $ loc "You're not the room master or a server admin!"] 
54eb4c774ef5
/greeting chat commands now clears greeting if called w/o arguments
Wuzzy <Wuzzy2@mail.ru>
parents:
13703
diff
changeset

442 
else 
54eb4c774ef5
/greeting chat commands now clears greeting if called w/o arguments
Wuzzy <Wuzzy2@mail.ru>
parents:
13703
diff
changeset

443 
[ModifyRoom (\r > r{greeting = msg}), 
54eb4c774ef5
/greeting chat commands now clears greeting if called w/o arguments
Wuzzy <Wuzzy2@mail.ru>
parents:
13703
diff
changeset

444 
AnswerClients [sendChan cl] 
54eb4c774ef5
/greeting chat commands now clears greeting if called w/o arguments
Wuzzy <Wuzzy2@mail.ru>
parents:
13703
diff
changeset

445 
["CHAT", nickServer, 
13705
aa1d71ca6c19
Change empty string check in gameServer
Wuzzy <Wuzzy2@mail.ru>
parents:
13704
diff
changeset

446 
if B.null msg then 
13704
54eb4c774ef5
/greeting chat commands now clears greeting if called w/o arguments
Wuzzy <Wuzzy2@mail.ru>
parents:
13703
diff
changeset

447 
loc "Greeting message cleared." 
54eb4c774ef5
/greeting chat commands now clears greeting if called w/o arguments
Wuzzy <Wuzzy2@mail.ru>
parents:
13703
diff
changeset

448 
else 
54eb4c774ef5
/greeting chat commands now clears greeting if called w/o arguments
Wuzzy <Wuzzy2@mail.ru>
parents:
13703
diff
changeset

449 
loc "Greeting message set." 
54eb4c774ef5
/greeting chat commands now clears greeting if called w/o arguments
Wuzzy <Wuzzy2@mail.ru>
parents:
13703
diff
changeset

450 
]] 
10039  451 

452 
handleCmd_inRoom ["CALLVOTE"] = do 

453 
cl < thisClient 

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

454 
return [AnswerClients [sendChan cl] 
14379
b33127bc2424
Fix incomplete syntax help of /callvote
Wuzzy <Wuzzy2@mail.ru>
parents:
14118
diff
changeset

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

456 
] 
10039  457 

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

459 
cl < thisClient 

13991
4ae01eabf611
Tweak error messages of /callvote kick
Wuzzy <Wuzzy2@mail.ru>
parents:
13970
diff
changeset

460 
rm < thisRoom 
4ae01eabf611
Tweak error messages of /callvote kick
Wuzzy <Wuzzy2@mail.ru>
parents:
13970
diff
changeset

461 
return 
14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

462 
[Warning $ 
13991
4ae01eabf611
Tweak error messages of /callvote kick
Wuzzy <Wuzzy2@mail.ru>
parents:
13970
diff
changeset

463 
if isJust $ masterID rm then 
4ae01eabf611
Tweak error messages of /callvote kick
Wuzzy <Wuzzy2@mail.ru>
parents:
13970
diff
changeset

464 
loc "/callvote kick: This is only allowed in rooms without a room master." 
4ae01eabf611
Tweak error messages of /callvote kick
Wuzzy <Wuzzy2@mail.ru>
parents:
13970
diff
changeset

465 
else 
4ae01eabf611
Tweak error messages of /callvote kick
Wuzzy <Wuzzy2@mail.ru>
parents:
13970
diff
changeset

466 
loc "/callvote kick: You need to specify a nickname." 
14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

467 
] 
10039  468 

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

470 
(thisClientId, rnc) < ask 

471 
cl < thisClient 

10058  472 
rm < thisRoom 
10039  473 
maybeClientId < clientByNick nickname 
474 
let kickId = fromJust maybeClientId 

475 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId 

476 

10217  477 
if isJust $ masterID rm then 
14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

478 
return [Warning $ loc "/callvote kick: This is only allowed in rooms without a room master."] 
10039  479 
else 
10058  480 
if isJust maybeClientId && sameRoom then 
481 
startVote $ VoteKick nickname 

482 
else 

14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

483 
return [Warning $ loc "/callvote kick: No such user!"] 
10039  484 

10195  485 

10212  486 
handleCmd_inRoom ["CALLVOTE", "MAP"] = do 
13700
feda0d1da62c
Add error message for /callvote map if no maps are available
Wuzzy <Wuzzy2@mail.ru>
parents:
13697
diff
changeset

487 
 Display list of available maps for voting 
10212  488 
cl < thisClient 
489 
s < liftM (Map.keys . roomSaves) thisRoom 

13700
feda0d1da62c
Add error message for /callvote map if no maps are available
Wuzzy <Wuzzy2@mail.ru>
parents:
13697
diff
changeset

490 
return [AnswerClients [sendChan cl] 
feda0d1da62c
Add error message for /callvote map if no maps are available
Wuzzy <Wuzzy2@mail.ru>
parents:
13697
diff
changeset

491 
["CHAT", nickServer, 
feda0d1da62c
Add error message for /callvote map if no maps are available
Wuzzy <Wuzzy2@mail.ru>
parents:
13697
diff
changeset

492 
if (not $ null s) then 
feda0d1da62c
Add error message for /callvote map if no maps are available
Wuzzy <Wuzzy2@mail.ru>
parents:
13697
diff
changeset

493 
(B.concat ["/callvote map: ", B.intercalate ", " s]) 
feda0d1da62c
Add error message for /callvote map if no maps are available
Wuzzy <Wuzzy2@mail.ru>
parents:
13697
diff
changeset

494 
else 
feda0d1da62c
Add error message for /callvote map if no maps are available
Wuzzy <Wuzzy2@mail.ru>
parents:
13697
diff
changeset

495 
loc "/callvote map: No maps available." 
feda0d1da62c
Add error message for /callvote map if no maps are available
Wuzzy <Wuzzy2@mail.ru>
parents:
13697
diff
changeset

496 
]] 
10212  497 

498 

10195  499 
handleCmd_inRoom ["CALLVOTE", "MAP", roomSave] = do 
500 
cl < thisClient 

501 
rm < thisRoom 

502 

503 
if Map.member roomSave $ roomSaves rm then 

504 
startVote $ VoteMap roomSave 

505 
else 

14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

506 
return [Warning $ loc "/callvote map: No such map!"] 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

507 

10195  508 

10392  509 
handleCmd_inRoom ["CALLVOTE", "PAUSE"] = do 
510 
cl < thisClient 

511 
rm < thisRoom 

512 

513 
if isJust $ gameInfo rm then 

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

514 
startVote VotePause 
10392  515 
else 
14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

516 
return [Warning $ loc "/callvote pause: No game in progress!"] 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

517 

13992
863604736cf5
GameServer: Fix protocol error when receiving CALLVOTE cmd with incorrect mode
Wuzzy <Wuzzy2@mail.ru>
parents:
13991
diff
changeset

518 
handleCmd_inRoom ["CALLVOTE", "PAUSE", _] = handleCmd_inRoom ["CALLVOTE", "PAUSE"] 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

519 

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

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

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

522 

13992
863604736cf5
GameServer: Fix protocol error when receiving CALLVOTE cmd with incorrect mode
Wuzzy <Wuzzy2@mail.ru>
parents:
13991
diff
changeset

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

524 

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

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

526 
cl < thisClient 
14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

527 
return [Warning $ loc "/callvote hedgehogs: Specify number from 1 to 8."] 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

528 

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

529 

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

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

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

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

533 

13504
f747c385b5ba
Server: Replace hardcoded hogrelated numbers with consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13079
diff
changeset

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

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

536 
else 
14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

537 
return [Warning $ loc "/callvote hedgehogs: Specify number from 1 to 8."] 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10732
diff
changeset

538 

13992
863604736cf5
GameServer: Fix protocol error when receiving CALLVOTE cmd with incorrect mode
Wuzzy <Wuzzy2@mail.ru>
parents:
13991
diff
changeset

539 
handleCmd_inRoom ["CALLVOTE", _] = handleCmd_inRoom ["CALLVOTE"] 
863604736cf5
GameServer: Fix protocol error when receiving CALLVOTE cmd with incorrect mode
Wuzzy <Wuzzy2@mail.ru>
parents:
13991
diff
changeset

540 
handleCmd_inRoom ["CALLVOTE", _, _] = handleCmd_inRoom ["CALLVOTE"] 
10195  541 

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

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

545 
if isJust b then 

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

546 
voted (p == ["FORCE"]) (fromJust b) 
13510
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13509
diff
changeset

547 
else 
14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

548 
return [Warning $ 
13510
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13509
diff
changeset

549 
if (p == ["FORCE"]) then 
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13509
diff
changeset

550 
loc "/force: Please use 'yes' or 'no'." 
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13509
diff
changeset

551 
else 
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13509
diff
changeset

552 
loc "/vote: Please use 'yes' or 'no'." 
14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13992
diff
changeset

553 
] 
10039  554 

10194  555 

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

10194  558 

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

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

561 

10195  562 
handleCmd_inRoom ["SAVEROOM", fileName] = serverAdminOnly $ do 
563 
return [SaveRoom fileName] 

10194  564 

10195  565 
handleCmd_inRoom ["LOADROOM", fileName] = serverAdminOnly $ do 
566 
return [LoadRoom fileName] 

567 

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

568 
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

569 

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

570 
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

571 

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

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