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 #-} 20module Votes where 21 22import Control.Monad.Reader 23import Control.Monad.State.Strict 24import ServerState 25import qualified Data.ByteString.Char8 as B 26import qualified Data.List as L 27import qualified Data.Map as Map 28import Data.Maybe 29import Control.Applicative 30------------------- 31import Consts 32import Utils 33import CoreTypes 34import HandlerUtils 35import EngineInteraction 36 37 38voted :: Bool -> Bool -> Reader (ClientIndex, IRnC) [Action] 39voted forced vote = do 40 cl <- thisClient 41 rm <- thisRoom 42 uid <- liftM clUID thisClient 43 44 case voting rm of 45 Nothing -> 46 return [Warning $ loc "There's no voting going on."] 47 Just voting -> 48 if (not forced) && (uid `L.notElem` entitledToVote voting) then 49 return [] 50 else if (not forced) && (uid `L.elem` map fst (votes voting)) then 51 return [Warning $ loc "You already have voted."] 52 else if forced && (not $ isAdministrator cl) then 53 return [] 54 else 55 ((:) (AnswerClients [sendChan cl] ["CHAT", nickServer, loc "Your vote has been counted."])) 56 <$> (actOnVoting $ voting{votes = (uid, vote):votes voting}) 57 58 where 59 actOnVoting :: Voting -> Reader (ClientIndex, IRnC) [Action] 60 actOnVoting vt = do 61 let (pro, contra) = L.partition snd $ votes vt 62 let totalV = length $ entitledToVote vt 63 let successV = totalV `div` 2 + 1 64 65 if (forced && not vote) || (length contra > totalV - successV) then 66 closeVoting 67 else if (forced && vote) || (length pro >= successV) then do 68 a <- act $ voteType vt 69 c <- closeVoting 70 return $ c ++ a 71 else 72 return [ModifyRoom $ \r -> r{voting = Just vt}] 73 74 closeVoting = do 75 chans <- roomClientsChans 76 return [ 77 AnswerClients chans ["CHAT", nickServer, loc "Voting closed."] 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 ] 94 act (VoteMap roomSave) = do 95 rm <- thisRoom 96 let rs = Map.lookup roomSave (roomSaves rm) 97 case rs of 98 Nothing -> return [] 99 Just (location, mp, p) -> do 100 cl <- thisClient 101 chans <- roomClientsChans 102 return $ 103 [ModifyRoom $ \r -> r{params = p, mapParams = mp} 104 , AnswerClients chans ["CHAT", nickServer, location] 105 , SendUpdateOnThisRoom 106 , LoadGhost location] 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}), 112 AnswerClients chans ["CHAT", nickServer, loc "Pause toggled."], 113 AnswerClients chans ["EM", toEngineMsg "I"]] 114 act (VoteNewSeed) = 115 return [SetRandomSeed] 116 act (VoteHedgehogsPerTeam h) = do 117 rm <- thisRoom 118 chans <- roomClientsChans 119 let answers = concatMap (\t -> 120 [ModifyRoom $ modifyTeam t{hhnum = h} 121 , AnswerClients chans ["HH_NUM", teamname t, showB h]] 122 ) $ if length curteams * h > cMaxHHs then [] else curteams 123 ; 124 curteams = 125 if isJust $ gameInfo rm then 126 teamsAtStart . fromJust . gameInfo $ rm 127 else 128 teams rm 129 130 return $ ModifyRoom (\r -> r{defaultHedgehogsNumber = h}) : answers 131 132 133startVote :: VoteType -> Reader (ClientIndex, IRnC) [Action] 134startVote vt = do 135 (ci, rnc) <- ask 136 --cl <- thisClient 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 145 return [ 146 ModifyRoom (\r -> r{voting = Just (newVoting vt){entitledToVote = uids}}) 147 , AnswerClients chans ["CHAT", nickServer, B.concat [loc "New voting started", ": ", voteInfo vt]] 148 , ReactCmd ["VOTE", "YES"] 149 ] 150 151 152checkVotes :: StateT ServerState IO [Action] 153checkVotes = do 154 rnc <- gets roomsClients 155 liftM concat $ io $ do 156 ris <- allRoomsM rnc 157 mapM (check rnc) ris 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 165 chans <- liftM (map sendChan) $ roomClientsM rnc ri 166 return [AnswerClients chans ["CHAT", nickServer, loc "Voting expired."]] 167 else 168 return [] 169 Nothing -> return [] 170 171 172voteInfo :: VoteType -> B.ByteString 173voteInfo (VoteKick n) = B.concat [loc "kick", " ", n] 174voteInfo (VoteMap n) = B.concat [loc "map", " ", n] 175voteInfo (VotePause) = B.concat [loc "pause"] 176voteInfo (VoteNewSeed) = B.concat [loc "new seed"] 177voteInfo (VoteHedgehogsPerTeam i) = B.concat [loc "hedgehogs per team: ", " ", showB i] 178