gameServer/Votes.hs
author nemo
Sat, 01 Mar 2014 14:52:36 -0500
changeset 10171 00f41ff0bf2d
parent 10090 a471a7bbc339
child 10195 d1c23bb73346
permissions -rw-r--r--
Script might well override a static map, but can't risk it not doing it, and preview completely failing. Better to just not try it for static maps. Some script cfg might help. Could also avoid unnnecessary preview regenerations even if the script was doing nothing at all.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10058
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
     1
{-# LANGUAGE OverloadedStrings #-}
10049
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
     2
module Votes where
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
     3
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
     4
import Control.Monad.Reader
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
     5
import Control.Monad.State
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
     6
import ServerState
10058
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
     7
import qualified Data.ByteString.Char8 as B
10081
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
     8
import qualified Data.List as L
10058
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
     9
import Data.Maybe
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    10
-------------------
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    11
import Utils
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    12
import CoreTypes
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    13
import HandlerUtils
10049
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
    14
10081
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    15
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    16
voted :: Bool -> Reader (ClientIndex, IRnC) [Action]
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    17
voted vote = do
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    18
    cl <- thisClient
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    19
    rm <- thisRoom
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    20
    uid <- liftM clUID thisClient
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    21
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    22
    if isNothing $ voting rm then
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    23
        return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "There's no voting going on"]]
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    24
    else if uid `L.notElem` entitledToVote (fromJust $ voting rm) then
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    25
        return []
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    26
    else if uid `L.elem` map fst (votes . fromJust $ voting rm) then
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    27
        return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "You already have voted"]]
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    28
    else
10087
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    29
        actOnVoting . fromJust . liftM (\v -> v{votes = (uid, vote):votes v}) $ voting rm
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    30
    where
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    31
    actOnVoting :: Voting -> Reader (ClientIndex, IRnC) [Action]
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    32
    actOnVoting vt = do
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    33
        let (contra, pro) = L.partition snd $ votes vt
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    34
        let v = (length $ entitledToVote vt) `div` 2 + 1
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    35
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    36
        if length contra >= v then
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    37
            closeVoting
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    38
        else if length pro >= v then do
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    39
            act $ voteType vt
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    40
            closeVoting
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    41
        else
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    42
            return [ModifyRoom $ \r -> r{voting = Just vt}]
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    43
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    44
    closeVoting = do
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    45
        chans <- roomClientsChans
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    46
        return [
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    47
            AnswerClients chans ["CHAT", "[server]", loc "Voting closed"]
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    48
            , ModifyRoom (\r -> r{voting = Nothing})
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    49
            ]
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    50
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    51
    act (VoteKick nickname) = do
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    52
        (thisClientId, rnc) <- ask
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    53
        maybeClientId <- clientByNick nickname
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    54
        rm <- thisRoom
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    55
        let kickId = fromJust maybeClientId
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    56
        let kickCl = rnc `client` kickId
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    57
        let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    58
        return
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    59
            [KickRoomClient kickId |
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    60
                isJust maybeClientId
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    61
                && sameRoom
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    62
                && ((isNothing $ gameInfo rm) || teamsInGame kickCl == 0)
5ba891578621 Implement kick voting
unc0rr
parents: 10081
diff changeset
    63
            ]
10081
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    64
10049
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
    65
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
    66
startVote :: VoteType -> Reader (ClientIndex, IRnC) [Action]
10058
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    67
startVote vt = do
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    68
    (ci, rnc) <- ask
10090
a471a7bbc339 - Start work on flood detector
unc0rr
parents: 10087
diff changeset
    69
    --cl <- thisClient
10058
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    70
    rm <- thisRoom
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    71
    chans <- roomClientsChans
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    72
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    73
    let uids = map (clUID . client rnc) . roomClients rnc $ clientRoom rnc ci
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    74
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    75
    if isJust $ voting rm then
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    76
        return []
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    77
    else
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    78
        liftM ([ModifyRoom (\r -> r{voting = Just (newVoting vt){entitledToVote = uids}})
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    79
        , AnswerClients chans ["CHAT", "[server]", B.concat [loc "New voting started", ": ", voteInfo vt]]
10081
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    80
        ] ++ ) $ voted True
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    81
10049
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
    82
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
    83
checkVotes :: StateT ServerState IO ()
ca11d122f54e Oops, forgot this
unc0rr
parents:
diff changeset
    84
checkVotes = undefined
10058
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    85
10081
0af84e5cbd4d Implement 'voted' function
unc0rr
parents: 10058
diff changeset
    86
10058
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    87
voteInfo :: VoteType -> B.ByteString
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    88
voteInfo (VoteKick n) = B.concat [loc "kick", " ", n]
4ed428389c4e - Implement /callvote
unc0rr
parents: 10049
diff changeset
    89