author  sheepluva 
Wed, 27 Apr 2016 16:20:59 +0200  
changeset 11744  ac58a063d26a 
parent 11575  db7743e2fad1 
child 13079  81c154fd4380 
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 
 
31 
import Utils 

32 
import CoreTypes 

33 
import HandlerUtils 

10392  34 
import EngineInteraction 
10049  35 

10081  36 

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

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

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

41 
uid < liftM clUID thisClient 

42 

10392  43 
case voting rm of 
44 
Nothing > 

45 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "There's no voting going on"]] 

46 
Just voting > 

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

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

49 
else if (not forced) && (uid `L.elem` map fst (votes voting)) then 
10392  50 
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "You already have voted"]] 
10881
941b5ab9e5a6
"/force" command for server admin to force voting result
unc0rr
parents:
10880
diff
changeset

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

52 
return [] 
10392  53 
else 
10880  54 
((:) (AnswerClients [sendChan cl] ["CHAT", "[server]", loc "Your vote counted"])) 
55 
<$> (actOnVoting $ voting{votes = (uid, vote):votes voting}) 

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

56 

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

59 
actOnVoting vt = do 

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

10087  63 

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

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

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

69 
return $ c ++ a 

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

72 

73 
closeVoting = do 

74 
chans < roomClientsChans 

75 
return [ 

76 
AnswerClients chans ["CHAT", "[server]", loc "Voting closed"] 

77 
, ModifyRoom (\r > r{voting = Nothing}) 

78 
] 

79 

80 
act (VoteKick nickname) = do 

81 
(thisClientId, rnc) < ask 

82 
maybeClientId < clientByNick nickname 

83 
rm < thisRoom 

84 
let kickId = fromJust maybeClientId 

85 
let kickCl = rnc `client` kickId 

86 
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId 

87 
return 

88 
[KickRoomClient kickId  

89 
isJust maybeClientId 

90 
&& sameRoom 

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

92 
] 

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

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

96 
case rs of 

97 
Nothing > return [] 

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

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

103 
, AnswerClients chans ["CHAT", "[server]", location] 

104 
, SendUpdateOnThisRoom 

105 
, LoadGhost location] 

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

108 
chans < roomClientsChans 

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

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

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

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

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

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

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

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

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

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

119 
[ModifyRoom $ modifyTeam t{hhnum = h} 
10787  120 
, AnswerClients chans ["HH_NUM", teamname t, showB h]] 
10879
9bedbd36de49
Don't change hedgehogs total number to a value > 48 as result of voting.
unc0rr
parents:
10787
diff
changeset

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

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

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

124 
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

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

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

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

128 

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

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

10049  131 

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

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

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

138 

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

140 

141 
if isJust $ voting rm then 

142 
return [] 

143 
else 

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

146 
, AnswerClients chans ["CHAT", "[server]", B.concat [loc "New voting started", ": ", voteInfo vt]] 

147 
, ReactCmd ["VOTE", "YES"] 

10215  148 
] 
10081  149 

10049  150 

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

153 
rnc < gets roomsClients 

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

159 
e < room'sM rnc voting ri 

160 
case e of 

161 
Just rv > do 

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

163 
if voteTTL rv == 0 then do 

10216  164 
chans < liftM (map sendChan) $ roomClientsM rnc ri 
10215  165 
return [AnswerClients chans ["CHAT", "[server]", loc "Voting expired"]] 
166 
else 

167 
return [] 

10216  168 
Nothing > return [] 
10058  169 

10081  170 

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

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

175 
voteInfo (VoteNewSeed) = B.concat [loc "new seed"] 
712283ed86e0
Implement /newseed and /hedgehogs commands. Only tested for building.
unc0rr
parents:
10464
diff
changeset

176 
voteInfo (VoteHedgehogsPerTeam i) = B.concat [loc "number of hedgehogs in team", " ", showB i] 