|
1 {- |
|
2 * Hedgewars, a free turn based strategy game |
|
3 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com> |
|
4 * |
|
5 * This program is free software; you can redistribute it and/or modify |
|
6 * it under the terms of the GNU General Public License as published by |
|
7 * the Free Software Foundation; version 2 of the License |
|
8 * |
|
9 * This program is distributed in the hope that it will be useful, |
|
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
12 * GNU General Public License for more details. |
|
13 * |
|
14 * You should have received a copy of the GNU General Public License |
|
15 * along with this program; if not, write to the Free Software |
|
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
|
17 \-} |
|
18 |
|
19 {-# LANGUAGE OverloadedStrings #-} |
|
20 module Votes where |
|
21 |
|
22 import Control.Monad.Reader |
|
23 import Control.Monad.State.Strict |
|
24 import ServerState |
|
25 import qualified Data.ByteString.Char8 as B |
|
26 import qualified Data.List as L |
|
27 import qualified Data.Map as Map |
|
28 import Data.Maybe |
|
29 import Control.Applicative |
|
30 ------------------- |
|
31 import Utils |
|
32 import CoreTypes |
|
33 import HandlerUtils |
|
34 import EngineInteraction |
|
35 |
|
36 |
|
37 voted :: Bool -> Bool -> Reader (ClientIndex, IRnC) [Action] |
|
38 voted forced vote = do |
|
39 cl <- thisClient |
|
40 rm <- thisRoom |
|
41 uid <- liftM clUID thisClient |
|
42 |
|
43 case voting rm of |
|
44 Nothing -> |
|
45 return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "There's no voting going on"]] |
|
46 Just voting -> |
|
47 if (not forced) && (uid `L.notElem` entitledToVote voting) then |
|
48 return [] |
|
49 else if (not forced) && (uid `L.elem` map fst (votes voting)) then |
|
50 return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "You already have voted"]] |
|
51 else if forced && (not $ isAdministrator cl) then |
|
52 return [] |
|
53 else |
|
54 ((:) (AnswerClients [sendChan cl] ["CHAT", "[server]", loc "Your vote counted"])) |
|
55 <$> (actOnVoting $ voting{votes = (uid, vote):votes voting}) |
|
56 |
|
57 where |
|
58 actOnVoting :: Voting -> Reader (ClientIndex, IRnC) [Action] |
|
59 actOnVoting vt = do |
|
60 let (pro, contra) = L.partition snd $ votes vt |
|
61 let totalV = length $ entitledToVote vt |
|
62 let successV = totalV `div` 2 + 1 |
|
63 |
|
64 if (forced && not vote) || (length contra > totalV - successV) then |
|
65 closeVoting |
|
66 else if (forced && vote) || (length pro >= successV) then do |
|
67 a <- act $ voteType vt |
|
68 c <- closeVoting |
|
69 return $ c ++ a |
|
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 ] |
|
93 act (VoteMap roomSave) = do |
|
94 rm <- thisRoom |
|
95 let rs = Map.lookup roomSave (roomSaves rm) |
|
96 case rs of |
|
97 Nothing -> return [] |
|
98 Just (mp, p) -> do |
|
99 cl <- thisClient |
|
100 chans <- roomClientsChans |
|
101 let a = map (replaceChans chans) $ answerFullConfigParams cl mp p |
|
102 return $ |
|
103 (ModifyRoom $ \r -> r{params = p, mapParams = mp}) |
|
104 : SendUpdateOnThisRoom |
|
105 : a |
|
106 where |
|
107 replaceChans chans (AnswerClients _ msg) = AnswerClients chans msg |
|
108 replaceChans _ a = a |
|
109 act (VotePause) = do |
|
110 rm <- thisRoom |
|
111 chans <- roomClientsChans |
|
112 let modifyGameInfo f room = room{gameInfo = fmap f $ gameInfo room} |
|
113 return [ModifyRoom (modifyGameInfo $ \g -> g{isPaused = not $ isPaused g}), |
|
114 AnswerClients chans ["CHAT", "[server]", loc "Pause toggled"], |
|
115 AnswerClients chans ["EM", toEngineMsg "I"]] |
|
116 act (VoteNewSeed) = |
|
117 return [SetRandomSeed] |
|
118 act (VoteHedgehogsPerTeam h) = do |
|
119 rm <- thisRoom |
|
120 chans <- roomClientsChans |
|
121 let answers = concatMap (\t -> |
|
122 [ModifyRoom $ modifyTeam t{hhnum = h} |
|
123 , AnswerClients chans ["HH_NUM", teamname t, showB h]] |
|
124 ) $ if length curteams * h > 48 then [] else curteams |
|
125 ; |
|
126 curteams = |
|
127 if isJust $ gameInfo rm then |
|
128 teamsAtStart . fromJust . gameInfo $ rm |
|
129 else |
|
130 teams rm |
|
131 |
|
132 return $ ModifyRoom (\r -> r{defaultHedgehogsNumber = h}) : answers |
|
133 |
|
134 |
|
135 startVote :: VoteType -> Reader (ClientIndex, IRnC) [Action] |
|
136 startVote vt = do |
|
137 (ci, rnc) <- ask |
|
138 --cl <- thisClient |
|
139 rm <- thisRoom |
|
140 chans <- roomClientsChans |
|
141 |
|
142 let uids = map (clUID . client rnc) . roomClients rnc $ clientRoom rnc ci |
|
143 |
|
144 if isJust $ voting rm then |
|
145 return [] |
|
146 else |
|
147 return [ |
|
148 ModifyRoom (\r -> r{voting = Just (newVoting vt){entitledToVote = uids}}) |
|
149 , AnswerClients chans ["CHAT", "[server]", B.concat [loc "New voting started", ": ", voteInfo vt]] |
|
150 , ReactCmd ["VOTE", "YES"] |
|
151 ] |
|
152 |
|
153 |
|
154 checkVotes :: StateT ServerState IO [Action] |
|
155 checkVotes = do |
|
156 rnc <- gets roomsClients |
|
157 liftM concat $ io $ do |
|
158 ris <- allRoomsM rnc |
|
159 mapM (check rnc) ris |
|
160 where |
|
161 check rnc ri = do |
|
162 e <- room'sM rnc voting ri |
|
163 case e of |
|
164 Just rv -> do |
|
165 modifyRoom rnc (\r -> r{voting = if voteTTL rv == 0 then Nothing else Just rv{voteTTL = voteTTL rv - 1}}) ri |
|
166 if voteTTL rv == 0 then do |
|
167 chans <- liftM (map sendChan) $ roomClientsM rnc ri |
|
168 return [AnswerClients chans ["CHAT", "[server]", loc "Voting expired"]] |
|
169 else |
|
170 return [] |
|
171 Nothing -> return [] |
|
172 |
|
173 |
|
174 voteInfo :: VoteType -> B.ByteString |
|
175 voteInfo (VoteKick n) = B.concat [loc "kick", " ", n] |
|
176 voteInfo (VoteMap n) = B.concat [loc "map", " ", n] |
|
177 voteInfo (VotePause) = B.concat [loc "pause"] |
|
178 voteInfo (VoteNewSeed) = B.concat [loc "new seed"] |
|
179 voteInfo (VoteHedgehogsPerTeam i) = B.concat [loc "number of hedgehogs in team", " ", showB i] |