- Fix applying vote result
- Votes expiring (I'm sure it doesn't even build, but my ghc is broken for now, hoping for the best)
--- a/gameServer/Actions.hs Mon Mar 24 21:32:24 2014 +0400
+++ b/gameServer/Actions.hs Thu Mar 27 23:25:31 2014 +0400
@@ -803,3 +803,6 @@
rnc <- gets roomsClients
actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
forM_ (actions `deepseq` actions) processAction
+
+processAction CheckVotes =
+ checkVotes >>= mapM_ processAction
\ No newline at end of file
--- a/gameServer/CoreTypes.hs Mon Mar 24 21:32:24 2014 +0400
+++ b/gameServer/CoreTypes.hs Thu Mar 27 23:25:31 2014 +0400
@@ -82,6 +82,7 @@
| SaveRoom B.ByteString
| LoadRoom B.ByteString
| ReactCmd [B.ByteString]
+ | CheckVotes
data Event = LobbyChatMessage
--- a/gameServer/HWProtoInRoomState.hs Mon Mar 24 21:32:24 2014 +0400
+++ b/gameServer/HWProtoInRoomState.hs Thu Mar 27 23:25:31 2014 +0400
@@ -434,7 +434,6 @@
handleCmd_inRoom ["LOADROOM", fileName] = serverAdminOnly $ do
return [LoadRoom fileName]
-
handleCmd_inRoom ["LIST"] = return [] -- for old clients (<= 0.9.17)
handleCmd_inRoom (s:_) = return [ProtocolError $ "Incorrect command '" `B.append` s `B.append` "' (state: in room)"]
--- a/gameServer/RoomsAndClients.hs Mon Mar 24 21:32:24 2014 +0400
+++ b/gameServer/RoomsAndClients.hs Thu Mar 27 23:25:31 2014 +0400
@@ -158,6 +158,9 @@
allClientsM :: MRoomsAndClients r c -> IO [ClientIndex]
allClientsM (MRoomsAndClients (_, clients)) = liftM (map ClientIndex) $ indicesM clients
+allRoomsM :: MRoomsAndClients r c -> IO [RoomIndex]
+allRoomsM (MRoomsAndClients (rooms, _)) = liftM (map RoomIndex) $ indicesM rooms
+
clientsM :: MRoomsAndClients r c -> IO [c]
clientsM (MRoomsAndClients (_, clients)) = indicesM clients >>= mapM (liftM client' . readElem clients)
--- a/gameServer/ServerCore.hs Mon Mar 24 21:32:24 2014 +0400
+++ b/gameServer/ServerCore.hs Thu Mar 27 23:25:31 2014 +0400
@@ -53,6 +53,7 @@
TimerAction tick ->
mapM_ processAction $
PingAll
+ : CheckVotes
: [StatsAction | even tick]
++ [Cleanup | tick `mod` 100 == 0]
--- a/gameServer/Votes.hs Mon Mar 24 21:32:24 2014 +0400
+++ b/gameServer/Votes.hs Thu Mar 27 23:25:31 2014 +0400
@@ -37,8 +37,9 @@
if length contra >= v then
closeVoting
else if length pro >= v then do
- act $ voteType vt
- closeVoting
+ a <- act $ voteType vt
+ c <- closeVoting
+ return $ c ++ a
else
return [ModifyRoom $ \r -> r{voting = Just vt}]
@@ -67,7 +68,7 @@
let rs = Map.lookup roomSave (roomSaves rm)
case rs of
Nothing -> return []
- Just (mp, p) -> return [Warning "ye!", ModifyRoom $ \r -> r{params = p, mapParams = mp}]
+ Just (mp, p) -> return [ModifyRoom $ \r -> r{params = p, mapParams = mp}]
startVote :: VoteType -> Reader (ClientIndex, IRnC) [Action]
@@ -86,11 +87,28 @@
ModifyRoom (\r -> r{voting = Just (newVoting vt){entitledToVote = uids}})
, AnswerClients chans ["CHAT", "[server]", B.concat [loc "New voting started", ": ", voteInfo vt]]
, ReactCmd ["VOTE", "YES"]
- ]
+ ]
-checkVotes :: StateT ServerState IO ()
-checkVotes = undefined
+checkVotes :: StateT ServerState IO [Action]
+checkVotes = do
+ rnc <- gets roomsClients
+ io $ do
+ ris <- allRoomsM rnc
+ actions <- mapM (check rnc) ris
+ mapM_ processAction actions
+ 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 sendChan $ roomClientsM rnc ri
+ return [AnswerClients chans ["CHAT", "[server]", loc "Voting expired"]]
+ else
+ return []
+ Nothing -> return []
voteInfo :: VoteType -> B.ByteString