gameServer/Votes.hs
author Wuzzy <Wuzzy2@mail.ru>
Thu, 25 Apr 2019 23:01:05 +0200
changeset 14844 e239378a9400
parent 14122 d6915d15b6de
permissions -rw-r--r--
Prevent entering “/”, “\” and “:” in team and scheme names. The name of teams and schems is saved in the file name itself, so these characters would cause trouble as they are used in path names in Linux and Windows.

{-
 * Hedgewars, a free turn based strategy game
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; version 2 of the License
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 \-}

{-# LANGUAGE OverloadedStrings #-}
module Votes where

import Control.Monad.Reader
import Control.Monad.State.Strict
import ServerState
import qualified Data.ByteString.Char8 as B
import qualified Data.List as L
import qualified Data.Map as Map
import Data.Maybe
import Control.Applicative
-------------------
import Consts
import Utils
import CoreTypes
import HandlerUtils
import EngineInteraction


voted :: Bool -> Bool -> Reader (ClientIndex, IRnC) [Action]
voted forced vote = do
    cl <- thisClient
    rm <- thisRoom
    uid <- liftM clUID thisClient

    case voting rm of
        Nothing -> 
            return [Warning $ loc "There's no voting going on."]
        Just voting ->
            if (not forced) && (uid `L.notElem` entitledToVote voting) then
                return []
            else if (not forced) && (uid `L.elem` map fst (votes voting)) then
                return [Warning $ loc "You already have voted."]
            else if forced && (not $ isAdministrator cl) then
                return []
            else
                ((:) (AnswerClients [sendChan cl] ["CHAT", nickServer, loc "Your vote has been counted."]))
                <$> (actOnVoting $ voting{votes = (uid, vote):votes voting})

    where
    actOnVoting :: Voting -> Reader (ClientIndex, IRnC) [Action]
    actOnVoting vt = do
        let (pro, contra) = L.partition snd $ votes vt
        let totalV = length $ entitledToVote vt 
        let successV = totalV `div` 2 + 1

        if (forced && not vote) || (length contra > totalV - successV) then
            closeVoting
        else if (forced && vote) || (length pro >= successV) then do
            a <- act $ voteType vt
            c <- closeVoting
            return $ c ++ a
        else
            return [ModifyRoom $ \r -> r{voting = Just vt}]

    closeVoting = do
        chans <- roomClientsChans
        return [
            AnswerClients chans ["CHAT", nickServer, loc "Voting closed."]
            , ModifyRoom (\r -> r{voting = Nothing})
            ]

    act (VoteKick nickname) = do
        (thisClientId, rnc) <- ask
        maybeClientId <- clientByNick nickname
        rm <- thisRoom
        let kickId = fromJust maybeClientId
        let kickCl = rnc `client` kickId
        let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId
        return
            [KickRoomClient kickId |
                isJust maybeClientId
                && sameRoom
                && ((isNothing $ gameInfo rm) || teamsInGame kickCl == 0)
            ]
    act (VoteMap roomSave) = do
        rm <- thisRoom
        let rs = Map.lookup roomSave (roomSaves rm)
        case rs of
             Nothing -> return []
             Just (location, mp, p) -> do
                 cl <- thisClient
                 chans <- roomClientsChans
                 return $
                    [ModifyRoom $ \r -> r{params = p, mapParams = mp}
                    , AnswerClients chans ["CHAT", nickServer, location]
                    , SendUpdateOnThisRoom
                    , LoadGhost location]
    act (VotePause) = do
        rm <- thisRoom
        chans <- roomClientsChans
        let modifyGameInfo f room  = room{gameInfo = fmap f $ gameInfo room}
        return [ModifyRoom (modifyGameInfo $ \g -> g{isPaused = not $ isPaused g}),
                AnswerClients chans ["CHAT", nickServer, loc "Pause toggled."],
                AnswerClients chans ["EM", toEngineMsg "I"]]
    act (VoteNewSeed) =
        return [SetRandomSeed]
    act (VoteHedgehogsPerTeam h) = do
        rm <- thisRoom
        chans <- roomClientsChans
        let answers = concatMap (\t -> 
                [ModifyRoom $ modifyTeam t{hhnum = h}
                , AnswerClients chans ["HH_NUM", teamname t, showB h]]
                ) $ if length curteams * h > cMaxHHs then [] else curteams
            ;
            curteams =
                if isJust $ gameInfo rm then
                    teamsAtStart . fromJust . gameInfo $ rm
                else
                    teams rm

        return $ ModifyRoom (\r -> r{defaultHedgehogsNumber = h}) : answers


startVote :: VoteType -> Reader (ClientIndex, IRnC) [Action]
startVote vt = do
    (ci, rnc) <- ask
    --cl <- thisClient
    rm <- thisRoom
    chans <- roomClientsChans

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

    if isJust $ voting rm then
        return []
    else
        return [
            ModifyRoom (\r -> r{voting = Just (newVoting vt){entitledToVote = uids}})
            , AnswerClients chans ["CHAT", nickServer, B.concat [loc "New voting started", ": ", voteInfo vt]]
            , ReactCmd ["VOTE", "YES"]
        ]


checkVotes :: StateT ServerState IO [Action]
checkVotes = do
    rnc <- gets roomsClients
    liftM concat $ io $ do
        ris <- allRoomsM rnc
        mapM (check rnc) ris
    where
        check rnc ri = do
            e <- room'sM rnc voting ri
            case e of
                 Just rv -> do
                     modifyRoom rnc (\r -> r{voting = if voteTTL rv == 0 then Nothing else Just rv{voteTTL = voteTTL rv - 1}}) ri
                     if voteTTL rv == 0 then do
                        chans <- liftM (map sendChan) $ roomClientsM rnc ri
                        return [AnswerClients chans ["CHAT", nickServer, loc "Voting expired."]]
                        else
                        return []
                 Nothing -> return []


voteInfo :: VoteType -> B.ByteString
voteInfo (VoteKick n) = B.concat [loc "kick", " ", n]
voteInfo (VoteMap n) = B.concat [loc "map", " ", n]
voteInfo (VotePause) = B.concat [loc "pause"]
voteInfo (VoteNewSeed) = B.concat [loc "new seed"]
voteInfo (VoteHedgehogsPerTeam i) = B.concat [loc "hedgehogs per team: ", " ", showB i]