author  alfadur 
Tue, 22 Jan 2019 20:35:11 +0300  
changeset 14664  def1b9870078 
parent 14117  d6915d15b6de 
permissions  rwrr 
10464
d08611b52000
Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

1 
{ 
d08611b52000
Added two copyrights on gameServer
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> 
10464
d08611b52000
Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

4 
* 
d08611b52000
Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

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

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

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

8 
* 
d08611b52000
Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

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

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

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

12 
* GNU General Public License for more details. 
d08611b52000
Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

13 
* 
d08611b52000
Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

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

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

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

17 
\} 
d08611b52000
Added two copyrights on gameServer
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10392
diff
changeset

18 

10058  19 
{# LANGUAGE OverloadedStrings #} 
10049  20 
module Votes where 
21 

22 
import Control.Monad.Reader 

10216  23 
import Control.Monad.State.Strict 
10049  24 
import ServerState 
10058  25 
import qualified Data.ByteString.Char8 as B 
10081  26 
import qualified Data.List as L 
10195  27 
import qualified Data.Map as Map 
10058  28 
import Data.Maybe 
10880  29 
import Control.Applicative 
10058  30 
 
13504
f747c385b5ba
Server: Replace hardcoded hogrelated numbers with consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13079
diff
changeset

31 
import Consts 
10058  32 
import Utils 
33 
import CoreTypes 

34 
import HandlerUtils 

10392  35 
import EngineInteraction 
10049  36 

10081  37 

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

38 
voted :: Bool > Bool > Reader (ClientIndex, IRnC) [Action] 
941b5ab9e5a6
"/force" command for server admin to force voting result
unc0rr
parents:
10880
diff
changeset

39 
voted forced vote = do 
10081  40 
cl < thisClient 
41 
rm < thisRoom 

42 
uid < liftM clUID thisClient 

43 

10392  44 
case voting rm of 
45 
Nothing > 

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

46 
return [Warning $ loc "There's no voting going on."] 
10392  47 
Just voting > 
10881
941b5ab9e5a6
"/force" command for server admin to force voting result
unc0rr
parents:
10880
diff
changeset

48 
if (not forced) && (uid `L.notElem` entitledToVote voting) then 
10392  49 
return [] 
10881
941b5ab9e5a6
"/force" command for server admin to force voting result
unc0rr
parents:
10880
diff
changeset

50 
else if (not forced) && (uid `L.elem` map fst (votes voting)) then 
14117
d6915d15b6de
GameServer: Turn some messages into warnings
Wuzzy <Wuzzy2@mail.ru>
parents:
13696
diff
changeset

51 
return [Warning $ loc "You already have voted."] 
10881
941b5ab9e5a6
"/force" command for server admin to force voting result
unc0rr
parents:
10880
diff
changeset

52 
else if forced && (not $ isAdministrator cl) then 
941b5ab9e5a6
"/force" command for server admin to force voting result
unc0rr
parents:
10880
diff
changeset

53 
return [] 
10392  54 
else 
13696
d732ca5dcab9
GameServer: Refactor fake nick names into Consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13504
diff
changeset

55 
((:) (AnswerClients [sendChan cl] ["CHAT", nickServer, loc "Your vote has been counted."])) 
10880  56 
<$> (actOnVoting $ voting{votes = (uid, vote):votes voting}) 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

57 

10087  58 
where 
59 
actOnVoting :: Voting > Reader (ClientIndex, IRnC) [Action] 

60 
actOnVoting vt = do 

10212  61 
let (pro, contra) = L.partition snd $ votes vt 
10392  62 
let totalV = length $ entitledToVote vt 
63 
let successV = totalV `div` 2 + 1 

10087  64 

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

65 
if (forced && not vote)  (length contra > totalV  successV) then 
10087  66 
closeVoting 
10881
941b5ab9e5a6
"/force" command for server admin to force voting result
unc0rr
parents:
10880
diff
changeset

67 
else if (forced && vote)  (length pro >= successV) then do 
10215  68 
a < act $ voteType vt 
69 
c < closeVoting 

70 
return $ c ++ a 

10087  71 
else 
72 
return [ModifyRoom $ \r > r{voting = Just vt}] 

73 

74 
closeVoting = do 

75 
chans < roomClientsChans 

76 
return [ 

13696
d732ca5dcab9
GameServer: Refactor fake nick names into Consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13504
diff
changeset

77 
AnswerClients chans ["CHAT", nickServer, loc "Voting closed."] 
10087  78 
, ModifyRoom (\r > r{voting = Nothing}) 
79 
] 

80 

81 
act (VoteKick nickname) = do 

82 
(thisClientId, rnc) < ask 

83 
maybeClientId < clientByNick nickname 

84 
rm < thisRoom 

85 
let kickId = fromJust maybeClientId 

86 
let kickCl = rnc `client` kickId 

87 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId 

88 
return 

89 
[KickRoomClient kickId  

90 
isJust maybeClientId 

91 
&& sameRoom 

92 
&& ((isNothing $ gameInfo rm)  teamsInGame kickCl == 0) 

93 
] 

10195  94 
act (VoteMap roomSave) = do 
95 
rm < thisRoom 

96 
let rs = Map.lookup roomSave (roomSaves rm) 

97 
case rs of 

98 
Nothing > return [] 

11575  99 
Just (location, mp, p) > do 
10218  100 
cl < thisClient 
101 
chans < roomClientsChans 

11575  102 
return $ 
103 
[ModifyRoom $ \r > r{params = p, mapParams = mp} 

13696
d732ca5dcab9
GameServer: Refactor fake nick names into Consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13504
diff
changeset

104 
, AnswerClients chans ["CHAT", nickServer, location] 
11575  105 
, SendUpdateOnThisRoom 
106 
, LoadGhost location] 

10392  107 
act (VotePause) = do 
108 
rm < thisRoom 

109 
chans < roomClientsChans 

110 
let modifyGameInfo f room = room{gameInfo = fmap f $ gameInfo room} 

111 
return [ModifyRoom (modifyGameInfo $ \g > g{isPaused = not $ isPaused g}), 

13696
d732ca5dcab9
GameServer: Refactor fake nick names into Consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13504
diff
changeset

112 
AnswerClients chans ["CHAT", nickServer, loc "Pause toggled."], 
10392  113 
AnswerClients chans ["EM", toEngineMsg "I"]] 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

114 
act (VoteNewSeed) = 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

115 
return [SetRandomSeed] 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

116 
act (VoteHedgehogsPerTeam h) = do 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

117 
rm < thisRoom 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

118 
chans < roomClientsChans 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

119 
let answers = concatMap (\t > 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

120 
[ModifyRoom $ modifyTeam t{hhnum = h} 
10787  121 
, AnswerClients chans ["HH_NUM", teamname t, showB h]] 
13504
f747c385b5ba
Server: Replace hardcoded hogrelated numbers with consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13079
diff
changeset

122 
) $ if length curteams * h > cMaxHHs then [] else curteams 
10879
9bedbd36de49
Don't change hedgehogs total number to a value > 48 as result of voting.
unc0rr
parents:
10787
diff
changeset

123 
; 
9bedbd36de49
Don't change hedgehogs total number to a value > 48 as result of voting.
unc0rr
parents:
10787
diff
changeset

124 
curteams = 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

125 
if isJust $ gameInfo rm then 
10879
9bedbd36de49
Don't change hedgehogs total number to a value > 48 as result of voting.
unc0rr
parents:
10787
diff
changeset

126 
teamsAtStart . fromJust . gameInfo $ rm 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

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

128 
teams rm 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

129 

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

130 
return $ ModifyRoom (\r > r{defaultHedgehogsNumber = h}) : answers 
10081  131 

10049  132 

133 
startVote :: VoteType > Reader (ClientIndex, IRnC) [Action] 

10058  134 
startVote vt = do 
135 
(ci, rnc) < ask 

10090  136 
cl < thisClient 
10058  137 
rm < thisRoom 
138 
chans < roomClientsChans 

139 

140 
let uids = map (clUID . client rnc) . roomClients rnc $ clientRoom rnc ci 

141 

142 
if isJust $ voting rm then 

143 
return [] 

144 
else 

10212  145 
return [ 
146 
ModifyRoom (\r > r{voting = Just (newVoting vt){entitledToVote = uids}}) 

13696
d732ca5dcab9
GameServer: Refactor fake nick names into Consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13504
diff
changeset

147 
, AnswerClients chans ["CHAT", nickServer, B.concat [loc "New voting started", ": ", voteInfo vt]] 
10212  148 
, ReactCmd ["VOTE", "YES"] 
10215  149 
] 
10081  150 

10049  151 

10215  152 
checkVotes :: StateT ServerState IO [Action] 
153 
checkVotes = do 

154 
rnc < gets roomsClients 

10216  155 
liftM concat $ io $ do 
10215  156 
ris < allRoomsM rnc 
10216  157 
mapM (check rnc) ris 
10215  158 
where 
159 
check rnc ri = do 

160 
e < room'sM rnc voting ri 

161 
case e of 

162 
Just rv > do 

163 
modifyRoom rnc (\r > r{voting = if voteTTL rv == 0 then Nothing else Just rv{voteTTL = voteTTL rv  1}}) ri 

164 
if voteTTL rv == 0 then do 

10216  165 
chans < liftM (map sendChan) $ roomClientsM rnc ri 
13696
d732ca5dcab9
GameServer: Refactor fake nick names into Consts
Wuzzy <Wuzzy2@mail.ru>
parents:
13504
diff
changeset

166 
return [AnswerClients chans ["CHAT", nickServer, loc "Voting expired."]] 
10215  167 
else 
168 
return [] 

10216  169 
Nothing > return [] 
10058  170 

10081  171 

10058  172 
voteInfo :: VoteType > B.ByteString 
173 
voteInfo (VoteKick n) = B.concat [loc "kick", " ", n] 

10195  174 
voteInfo (VoteMap n) = B.concat [loc "map", " ", n] 
10392  175 
voteInfo (VotePause) = B.concat [loc "pause"] 
10786
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

176 
voteInfo (VoteNewSeed) = B.concat [loc "new seed"] 
13079
81c154fd4380
More userfriendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents:
11575
diff
changeset

177 
voteInfo (VoteHedgehogsPerTeam i) = B.concat [loc "hedgehogs per team: ", " ", showB i] 