|
10058
|
1 |
{-# LANGUAGE OverloadedStrings #-}
|
|
10049
|
2 |
module Votes where
|
|
|
3 |
|
|
|
4 |
import Control.Monad.Reader
|
|
|
5 |
import Control.Monad.State
|
|
|
6 |
import ServerState
|
|
10058
|
7 |
import qualified Data.ByteString.Char8 as B
|
|
10081
|
8 |
import qualified Data.List as L
|
|
10058
|
9 |
import Data.Maybe
|
|
|
10 |
-------------------
|
|
|
11 |
import Utils
|
|
|
12 |
import CoreTypes
|
|
|
13 |
import HandlerUtils
|
|
10087
|
14 |
import Actions
|
|
10049
|
15 |
|
|
10081
|
16 |
|
|
|
17 |
voted :: Bool -> Reader (ClientIndex, IRnC) [Action]
|
|
|
18 |
voted vote = do
|
|
|
19 |
cl <- thisClient
|
|
|
20 |
rm <- thisRoom
|
|
|
21 |
uid <- liftM clUID thisClient
|
|
|
22 |
|
|
|
23 |
if isNothing $ voting rm then
|
|
|
24 |
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "There's no voting going on"]]
|
|
|
25 |
else if uid `L.notElem` entitledToVote (fromJust $ voting rm) then
|
|
|
26 |
return []
|
|
|
27 |
else if uid `L.elem` map fst (votes . fromJust $ voting rm) then
|
|
|
28 |
return [AnswerClients [sendChan cl] ["CHAT", "[server]", loc "You already have voted"]]
|
|
|
29 |
else
|
|
10087
|
30 |
actOnVoting . fromJust . liftM (\v -> v{votes = (uid, vote):votes v}) $ voting rm
|
|
|
31 |
where
|
|
|
32 |
actOnVoting :: Voting -> Reader (ClientIndex, IRnC) [Action]
|
|
|
33 |
actOnVoting vt = do
|
|
|
34 |
let (contra, pro) = L.partition snd $ votes vt
|
|
|
35 |
let v = (length $ entitledToVote vt) `div` 2 + 1
|
|
|
36 |
|
|
|
37 |
if length contra >= v then
|
|
|
38 |
closeVoting
|
|
|
39 |
else if length pro >= v then do
|
|
|
40 |
act $ voteType vt
|
|
|
41 |
closeVoting
|
|
|
42 |
else
|
|
|
43 |
return [ModifyRoom $ \r -> r{voting = Just vt}]
|
|
|
44 |
|
|
|
45 |
closeVoting = do
|
|
|
46 |
chans <- roomClientsChans
|
|
|
47 |
return [
|
|
|
48 |
AnswerClients chans ["CHAT", "[server]", loc "Voting closed"]
|
|
|
49 |
, ModifyRoom (\r -> r{voting = Nothing})
|
|
|
50 |
]
|
|
|
51 |
|
|
|
52 |
act (VoteKick nickname) = do
|
|
|
53 |
(thisClientId, rnc) <- ask
|
|
|
54 |
maybeClientId <- clientByNick nickname
|
|
|
55 |
rm <- thisRoom
|
|
|
56 |
let kickId = fromJust maybeClientId
|
|
|
57 |
let kickCl = rnc `client` kickId
|
|
|
58 |
let sameRoom = clientRoom rnc thisClientId == clientRoom rnc kickId
|
|
|
59 |
return
|
|
|
60 |
[KickRoomClient kickId |
|
|
|
61 |
isJust maybeClientId
|
|
|
62 |
&& sameRoom
|
|
|
63 |
&& ((isNothing $ gameInfo rm) || teamsInGame kickCl == 0)
|
|
|
64 |
]
|
|
10081
|
65 |
|
|
10049
|
66 |
|
|
|
67 |
startVote :: VoteType -> Reader (ClientIndex, IRnC) [Action]
|
|
10058
|
68 |
startVote vt = do
|
|
|
69 |
(ci, rnc) <- ask
|
|
|
70 |
cl <- thisClient
|
|
|
71 |
rm <- thisRoom
|
|
|
72 |
chans <- roomClientsChans
|
|
|
73 |
|
|
|
74 |
let uids = map (clUID . client rnc) . roomClients rnc $ clientRoom rnc ci
|
|
|
75 |
|
|
|
76 |
if isJust $ voting rm then
|
|
|
77 |
return []
|
|
|
78 |
else
|
|
|
79 |
liftM ([ModifyRoom (\r -> r{voting = Just (newVoting vt){entitledToVote = uids}})
|
|
|
80 |
, AnswerClients chans ["CHAT", "[server]", B.concat [loc "New voting started", ": ", voteInfo vt]]
|
|
10081
|
81 |
] ++ ) $ voted True
|
|
|
82 |
|
|
10049
|
83 |
|
|
|
84 |
checkVotes :: StateT ServerState IO ()
|
|
|
85 |
checkVotes = undefined
|
|
10058
|
86 |
|
|
10081
|
87 |
|
|
10058
|
88 |
voteInfo :: VoteType -> B.ByteString
|
|
|
89 |
voteInfo (VoteKick n) = B.concat [loc "kick", " ", n]
|
|
|
90 |
|