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