{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}

-- | The votes the node has accepted, from whichever peer.
--
-- Each LeiosNotify client already holds its own upstream peer to one vote per
-- seat in an election. But the node relays what it accepts from all its peers,
-- and a downstream peer holds the node to the same, and to having relayed the
-- announcement a vote is for. So the node decides once, here, whether a vote
-- is new and valid, and only then relays it.
--
-- A vote is relayed only to be aggregated into a certificate, which the
-- earliest block that can carry it needs in the first slot at or after the
-- vote's deadline, the end of its diffusion period ('voteUntil'). The node
-- neither keeps nor relays a vote it has only after its deadline. Such a vote
-- could still complete a certificate for a later block, but a quorum that late
-- is no evidence that the endorser block's data diffused in time, so the node
-- deliberately gives up that throughput rather than endanger safety.
module Ouroboros.Consensus.Leios.VoteState
  ( VoteState
  , newVoteState
  , TraceLeiosVoteState (..)
  , AddVoteResult (..)
  , addVote
  , votePruner

    -- * The votes kept
  , currentVotes
  , recordVote
  , pruneVotes
  ) where

import Cardano.Crypto.DSIGN.Class (verifyDSIGN)
import Cardano.Crypto.Leios
  ( LeiosCommittee
  , LeiosSeat (..)
  , LeiosSeatId
  , leiosSignContext
  , resolveLeiosSeat
  )
import Control.Monad (forever, when)
import Control.Tracer (Tracer, traceWith)
import Data.Bifunctor (first)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import qualified Data.Text as Text
import Data.Time.Clock (NominalDiffTime)
import Data.Void (Void)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block (ConvertRawHash, GetHeader, SlotNo)
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
  ( RelativeTime (..)
  , SystemTime (..)
  , diffRelTime
  )
import Ouroboros.Consensus.Leios.AnnounceState (AnnounceState, hasAnnouncement)
import Ouroboros.Consensus.Leios.NotifyLog
  ( Notification (..)
  , NotifyLog
  , appendNotifyLog
  )
import Ouroboros.Consensus.Leios.Types (LeiosVote (..))
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client.State
  ( AcceptedVote (..)
  , InvalidVoteReason (..)
  , VoteWindow (..)
  )
import Ouroboros.Consensus.Util.IOLike
  ( IOLike
  , MonadDelay (threadDelay)
  , MonadSTM
  , STM
  , StrictTVar
  , atomically
  , modifyTVar
  , newTVarIO
  , readTVar
  , writeTVar
  )
import Ouroboros.Consensus.Util.Time (nominalDelay)

-- | The node's votes, and where it learns which announcements it relays and
-- relays the votes.
data VoteState m blk = MkVoteState
  { forall (m :: * -> *) blk. VoteState m blk -> StrictTVar m Votes
votes :: !(StrictTVar m Votes)
  , forall (m :: * -> *) blk. VoteState m blk -> AnnounceState m blk
announceState :: !(AnnounceState m blk)
  -- ^ Which announcements the node relays, as it relays only votes for those.
  , forall (m :: * -> *) blk. VoteState m blk -> NotifyLog m blk
relayLog :: !(NotifyLog m blk)
  -- ^ Where the node relays the votes it adds.
  , forall (m :: * -> *) blk.
VoteState m blk -> Tracer m TraceLeiosVoteState
tracer :: !(Tracer m TraceLeiosVoteState)
  }

newVoteState ::
  IOLike m =>
  Tracer m TraceLeiosVoteState -> AnnounceState m blk -> NotifyLog m blk -> m (VoteState m blk)
newVoteState :: forall (m :: * -> *) blk.
IOLike m =>
Tracer m TraceLeiosVoteState
-> AnnounceState m blk -> NotifyLog m blk -> m (VoteState m blk)
newVoteState Tracer m TraceLeiosVoteState
tracer' AnnounceState m blk
announceState' NotifyLog m blk
notifyLog =
  StrictTVar m Votes
-> AnnounceState m blk
-> NotifyLog m blk
-> Tracer m TraceLeiosVoteState
-> VoteState m blk
forall (m :: * -> *) blk.
StrictTVar m Votes
-> AnnounceState m blk
-> NotifyLog m blk
-> Tracer m TraceLeiosVoteState
-> VoteState m blk
MkVoteState
    (StrictTVar m Votes
 -> AnnounceState m blk
 -> NotifyLog m blk
 -> Tracer m TraceLeiosVoteState
 -> VoteState m blk)
-> m (StrictTVar m Votes)
-> m (AnnounceState m blk
      -> NotifyLog m blk
      -> Tracer m TraceLeiosVoteState
      -> VoteState m blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Votes -> m (StrictTVar m Votes)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (RelativeTime -> Map SlotNo SlotVotes -> Votes
MkVotes (NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
0) Map SlotNo SlotVotes
forall k a. Map k a
Map.empty)
    m (AnnounceState m blk
   -> NotifyLog m blk
   -> Tracer m TraceLeiosVoteState
   -> VoteState m blk)
-> m (AnnounceState m blk)
-> m (NotifyLog m blk
      -> Tracer m TraceLeiosVoteState -> VoteState m blk)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AnnounceState m blk -> m (AnnounceState m blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnnounceState m blk
announceState'
    m (NotifyLog m blk
   -> Tracer m TraceLeiosVoteState -> VoteState m blk)
-> m (NotifyLog m blk)
-> m (Tracer m TraceLeiosVoteState -> VoteState m blk)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NotifyLog m blk -> m (NotifyLog m blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NotifyLog m blk
notifyLog
    m (Tracer m TraceLeiosVoteState -> VoteState m blk)
-> m (Tracer m TraceLeiosVoteState) -> m (VoteState m blk)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer m TraceLeiosVoteState -> m (Tracer m TraceLeiosVoteState)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracer m TraceLeiosVoteState
tracer'

-- | What the node's 'VoteState' traces, for each vote it adds or does not, so
-- these are frequent. What 'addVote' did with a vote is up to its caller to
-- trace.
data TraceLeiosVoteState
  = -- | The node starts to add a vote, and to check whether it should.
    TraceLeiosVoteAdding !LeiosVote
  | -- | The vote arrived before its window opened, so the node waits this long
    -- before adding it.
    TraceLeiosVoteAwaitingWindow !LeiosVote !NominalDiffTime
  | -- | The node validated a vote, its seat and signature, and has yet to add it.
    TraceLeiosVoteValidated !LeiosVote
  deriving Int -> TraceLeiosVoteState -> ShowS
[TraceLeiosVoteState] -> ShowS
TraceLeiosVoteState -> String
(Int -> TraceLeiosVoteState -> ShowS)
-> (TraceLeiosVoteState -> String)
-> ([TraceLeiosVoteState] -> ShowS)
-> Show TraceLeiosVoteState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceLeiosVoteState -> ShowS
showsPrec :: Int -> TraceLeiosVoteState -> ShowS
$cshow :: TraceLeiosVoteState -> String
show :: TraceLeiosVoteState -> String
$cshowList :: [TraceLeiosVoteState] -> ShowS
showList :: [TraceLeiosVoteState] -> ShowS
Show

-- | What 'addVote' did with a vote.
data AddVoteResult
  = -- | The node had it only after its deadline, or after it forgot its
    -- election.
    ArrivedTooLate
  | -- | We already saw a vote of its seat in its election.
    AlreadyKnown
  | -- | We did not relay the announcement it is for.
    NotAnnounced
  | -- | Its seat has no key in the committee, or its signature does not verify
    -- under it.
    VoteInvalid !InvalidVoteReason
  | -- | The node keeps the vote and relays it.
    Added
  deriving stock (AddVoteResult -> AddVoteResult -> Bool
(AddVoteResult -> AddVoteResult -> Bool)
-> (AddVoteResult -> AddVoteResult -> Bool) -> Eq AddVoteResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AddVoteResult -> AddVoteResult -> Bool
== :: AddVoteResult -> AddVoteResult -> Bool
$c/= :: AddVoteResult -> AddVoteResult -> Bool
/= :: AddVoteResult -> AddVoteResult -> Bool
Eq, Int -> AddVoteResult -> ShowS
[AddVoteResult] -> ShowS
AddVoteResult -> String
(Int -> AddVoteResult -> ShowS)
-> (AddVoteResult -> String)
-> ([AddVoteResult] -> ShowS)
-> Show AddVoteResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AddVoteResult -> ShowS
showsPrec :: Int -> AddVoteResult -> ShowS
$cshow :: AddVoteResult -> String
show :: AddVoteResult -> String
$cshowList :: [AddVoteResult] -> ShowS
showList :: [AddVoteResult] -> ShowS
Show)

-- | Add a vote, if it is the first valid vote of its seat in its election, for
-- an announcement the node relays, and the node has it by its deadline.
--
-- NOTE: This will wait until the vote's window is open.
--
-- The signature is verified between two transactions, so that a retry does
-- not repeat a BLS verification. As verifying takes time, 'recordVote' checks
-- again whether the node has seen or forgotten the vote. The relay log stops
-- relaying it after its deadline.
addVote ::
  (IOLike m, ConvertRawHash blk, GetHeader blk) =>
  VoteState m blk -> SystemTime m -> AcceptedVote -> m AddVoteResult
addVote :: forall (m :: * -> *) blk.
(IOLike m, ConvertRawHash blk, GetHeader blk) =>
VoteState m blk -> SystemTime m -> AcceptedVote -> m AddVoteResult
addVote VoteState m blk
st SystemTime m
systemTime AcceptedVote
accepted = do
  Tracer m TraceLeiosVoteState -> TraceLeiosVoteState -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith (VoteState m blk -> Tracer m TraceLeiosVoteState
forall (m :: * -> *) blk.
VoteState m blk -> Tracer m TraceLeiosVoteState
tracer VoteState m blk
st) (LeiosVote -> TraceLeiosVoteState
TraceLeiosVoteAdding LeiosVote
acceptedVote)
  received <- SystemTime m -> m RelativeTime
forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent SystemTime m
systemTime
  -- Wait for the window of a vote that 'checkLeiosVotes' accepted early.
  -- NOTE: 'checkLeiosVotes' just rejected votes earlier than the
  -- clock skew, so this waits at most 'InFutureCheck.ClockSkew'.
  let early = VoteWindow -> RelativeTime
voteFrom VoteWindow
voteWindow RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` RelativeTime
received
  when (early >= 0) $ do
    traceWith (tracer st) (TraceLeiosVoteAwaitingWindow acceptedVote early)
    threadDelay (nominalDelay early)
  seen <- atomically $ hasSeenVote st accepted
  -- NOTE: The client only checked that its peer announced it, but the node
  -- does not relay a third announcement of an election, nor one of a stale
  -- OCIN, so it must not relay their votes either.
  announced <-
    atomically $
      hasAnnouncement (announceState st) voteElectionSlot (voteAnnouncingRbHash acceptedVote)
  if
    | received > voteUntil voteWindow -> pure ArrivedTooLate
    | not announced -> pure NotAnnounced
    | seen -> pure AlreadyKnown
    -- NOTE: Verifying a signature is expensive, so this comes last.
    | Left reason <- validateVote voteCommittee acceptedVote -> pure (VoteInvalid reason)
    | otherwise -> do
        traceWith (tracer st) (TraceLeiosVoteValidated acceptedVote)
        atomically $ do
          recordVote st accepted >>= \case
            Left AddVoteResult
notAdded -> AddVoteResult -> STM m AddVoteResult
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AddVoteResult
notAdded
            Right () -> do
              STM m ()
relayVote
              AddVoteResult -> STM m AddVoteResult
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AddVoteResult
Added
 where
  relayVote :: STM m ()
relayVote =
    NotifyLog m blk -> Notification blk -> RelativeTime -> STM m ()
forall (m :: * -> *) blk.
IOLike m =>
NotifyLog m blk -> Notification blk -> RelativeTime -> STM m ()
appendNotifyLog
      (VoteState m blk -> NotifyLog m blk
forall (m :: * -> *) blk. VoteState m blk -> NotifyLog m blk
relayLog VoteState m blk
st)
      (LeiosVote -> Notification blk
forall blk. LeiosVote -> Notification blk
NotifyVote LeiosVote
acceptedVote)
      (VoteWindow -> RelativeTime
voteUntil VoteWindow
voteWindow)

  MkAcceptedVote
    { LeiosVote
acceptedVote :: LeiosVote
acceptedVote :: AcceptedVote -> LeiosVote
acceptedVote
    , SlotNo
voteElectionSlot :: SlotNo
voteElectionSlot :: AcceptedVote -> SlotNo
voteElectionSlot
    , LeiosCommittee
voteCommittee :: LeiosCommittee
voteCommittee :: AcceptedVote -> LeiosCommittee
voteCommittee
    , VoteWindow
voteWindow :: VoteWindow
voteWindow :: AcceptedVote -> VoteWindow
voteWindow
    } = AcceptedVote
accepted

-- | Whether the vote's seat has a key in the committee, and the signature
-- verifies under it, or why not.
validateVote :: LeiosCommittee -> LeiosVote -> Either InvalidVoteReason ()
validateVote :: LeiosCommittee -> LeiosVote -> Either InvalidVoteReason ()
validateVote LeiosCommittee
committee MkLeiosVote{RankingBlockHash
voteAnnouncingRbHash :: LeiosVote -> RankingBlockHash
voteAnnouncingRbHash :: RankingBlockHash
voteAnnouncingRbHash, LeiosSeatId
voteSeatId :: LeiosSeatId
voteSeatId :: LeiosVote -> LeiosSeatId
voteSeatId, LeiosSignature
voteSignature :: LeiosSignature
voteSignature :: LeiosVote -> LeiosSignature
voteSignature} =
  case LeiosCommittee -> LeiosSeatId -> Maybe LeiosSeat
resolveLeiosSeat LeiosCommittee
committee LeiosSeatId
voteSeatId of
    Just LeiosSeat{seatVKey :: LeiosSeat -> StrictMaybe LeiosVerificationKey
seatVKey = SJust LeiosVerificationKey
vk} ->
      (String -> InvalidVoteReason)
-> Either String () -> Either InvalidVoteReason ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> InvalidVoteReason
BadSignature (Text -> InvalidVoteReason)
-> (String -> Text) -> String -> InvalidVoteReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (Either String () -> Either InvalidVoteReason ())
-> Either String () -> Either InvalidVoteReason ()
forall a b. (a -> b) -> a -> b
$
        ContextDSIGN LeiosDSIGN
-> LeiosVerificationKey
-> RankingBlockHash
-> LeiosSignature
-> Either String ()
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v
-> VerKeyDSIGN v -> a -> SigDSIGN v -> Either String ()
forall a.
(Signable LeiosDSIGN a, HasCallStack) =>
ContextDSIGN LeiosDSIGN
-> LeiosVerificationKey -> a -> LeiosSignature -> Either String ()
verifyDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext LeiosVerificationKey
vk RankingBlockHash
voteAnnouncingRbHash LeiosSignature
voteSignature
    Just LeiosSeat{seatVKey :: LeiosSeat -> StrictMaybe LeiosVerificationKey
seatVKey = StrictMaybe LeiosVerificationKey
SNothing} -> InvalidVoteReason -> Either InvalidVoteReason ()
forall a b. a -> Either a b
Left InvalidVoteReason
SeatHasNoKey
    Maybe LeiosSeat
Nothing -> InvalidVoteReason -> Either InvalidVoteReason ()
forall a b. a -> Either a b
Left InvalidVoteReason
SeatNotResolvable

{-------------------------------------------------------------------------------
  The votes kept
-------------------------------------------------------------------------------}

-- | The first valid vote of each seat, per election slot, for every election
-- slot whose deadline had not passed when the votes were last pruned.
data Votes = MkVotes
  { Votes -> RelativeTime
votesPrunedAt :: !RelativeTime
  -- ^ When the votes were last pruned. The node may have forgotten whether it
  -- has a vote whose deadline is before this.
  , Votes -> Map SlotNo SlotVotes
votesBySlot :: !(Map SlotNo SlotVotes)
  }
  deriving stock (Votes -> Votes -> Bool
(Votes -> Votes -> Bool) -> (Votes -> Votes -> Bool) -> Eq Votes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Votes -> Votes -> Bool
== :: Votes -> Votes -> Bool
$c/= :: Votes -> Votes -> Bool
/= :: Votes -> Votes -> Bool
Eq, Int -> Votes -> ShowS
[Votes] -> ShowS
Votes -> String
(Int -> Votes -> ShowS)
-> (Votes -> String) -> ([Votes] -> ShowS) -> Show Votes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Votes -> ShowS
showsPrec :: Int -> Votes -> ShowS
$cshow :: Votes -> String
show :: Votes -> String
$cshowList :: [Votes] -> ShowS
showList :: [Votes] -> ShowS
Show, (forall x. Votes -> Rep Votes x)
-> (forall x. Rep Votes x -> Votes) -> Generic Votes
forall x. Rep Votes x -> Votes
forall x. Votes -> Rep Votes x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Votes -> Rep Votes x
from :: forall x. Votes -> Rep Votes x
$cto :: forall x. Rep Votes x -> Votes
to :: forall x. Rep Votes x -> Votes
Generic)
  deriving anyclass Context -> Votes -> IO (Maybe ThunkInfo)
Proxy Votes -> String
(Context -> Votes -> IO (Maybe ThunkInfo))
-> (Context -> Votes -> IO (Maybe ThunkInfo))
-> (Proxy Votes -> String)
-> NoThunks Votes
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Votes -> IO (Maybe ThunkInfo)
noThunks :: Context -> Votes -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Votes -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Votes -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Votes -> String
showTypeOf :: Proxy Votes -> String
NoThunks

-- | The votes of one election slot, and their deadline.
data SlotVotes = MkSlotVotes
  { SlotVotes -> RelativeTime
slotRelayUntil :: !RelativeTime
  , SlotVotes -> Map LeiosSeatId LeiosVote
slotVotes :: !(Map LeiosSeatId LeiosVote)
  }
  deriving stock (SlotVotes -> SlotVotes -> Bool
(SlotVotes -> SlotVotes -> Bool)
-> (SlotVotes -> SlotVotes -> Bool) -> Eq SlotVotes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SlotVotes -> SlotVotes -> Bool
== :: SlotVotes -> SlotVotes -> Bool
$c/= :: SlotVotes -> SlotVotes -> Bool
/= :: SlotVotes -> SlotVotes -> Bool
Eq, Int -> SlotVotes -> ShowS
[SlotVotes] -> ShowS
SlotVotes -> String
(Int -> SlotVotes -> ShowS)
-> (SlotVotes -> String)
-> ([SlotVotes] -> ShowS)
-> Show SlotVotes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SlotVotes -> ShowS
showsPrec :: Int -> SlotVotes -> ShowS
$cshow :: SlotVotes -> String
show :: SlotVotes -> String
$cshowList :: [SlotVotes] -> ShowS
showList :: [SlotVotes] -> ShowS
Show, (forall x. SlotVotes -> Rep SlotVotes x)
-> (forall x. Rep SlotVotes x -> SlotVotes) -> Generic SlotVotes
forall x. Rep SlotVotes x -> SlotVotes
forall x. SlotVotes -> Rep SlotVotes x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SlotVotes -> Rep SlotVotes x
from :: forall x. SlotVotes -> Rep SlotVotes x
$cto :: forall x. Rep SlotVotes x -> SlotVotes
to :: forall x. Rep SlotVotes x -> SlotVotes
Generic)
  deriving anyclass Context -> SlotVotes -> IO (Maybe ThunkInfo)
Proxy SlotVotes -> String
(Context -> SlotVotes -> IO (Maybe ThunkInfo))
-> (Context -> SlotVotes -> IO (Maybe ThunkInfo))
-> (Proxy SlotVotes -> String)
-> NoThunks SlotVotes
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> SlotVotes -> IO (Maybe ThunkInfo)
noThunks :: Context -> SlotVotes -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SlotVotes -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> SlotVotes -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy SlotVotes -> String
showTypeOf :: Proxy SlotVotes -> String
NoThunks

-- | Whether the node has a vote of this seat in this election.
hasSeenVote ::
  MonadSTM m =>
  VoteState m blk -> AcceptedVote -> STM m Bool
hasSeenVote :: forall (m :: * -> *) blk.
MonadSTM m =>
VoteState m blk -> AcceptedVote -> STM m Bool
hasSeenVote VoteState m blk
st AcceptedVote
accepted = do
  MkVotes{votesBySlot} <- StrictTVar m Votes -> STM m Votes
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (VoteState m blk -> StrictTVar m Votes
forall (m :: * -> *) blk. VoteState m blk -> StrictTVar m Votes
votes VoteState m blk
st)
  pure $
    maybe
      False
      (Map.member voteSeatId . slotVotes)
      (Map.lookup voteElectionSlot votesBySlot)
 where
  MkAcceptedVote
    { acceptedVote :: AcceptedVote -> LeiosVote
acceptedVote = MkLeiosVote{LeiosSeatId
voteSeatId :: LeiosVote -> LeiosSeatId
voteSeatId :: LeiosSeatId
voteSeatId}
    , SlotNo
voteElectionSlot :: AcceptedVote -> SlotNo
voteElectionSlot :: SlotNo
voteElectionSlot
    } = AcceptedVote
accepted

-- | The votes the node keeps, by election slot and seat.
currentVotes ::
  IOLike m =>
  VoteState m blk -> STM m (Map SlotNo (Map LeiosSeatId LeiosVote))
currentVotes :: forall (m :: * -> *) blk.
IOLike m =>
VoteState m blk -> STM m (Map SlotNo (Map LeiosSeatId LeiosVote))
currentVotes VoteState m blk
st = (SlotVotes -> Map LeiosSeatId LeiosVote)
-> Map SlotNo SlotVotes -> Map SlotNo (Map LeiosSeatId LeiosVote)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map SlotVotes -> Map LeiosSeatId LeiosVote
slotVotes (Map SlotNo SlotVotes -> Map SlotNo (Map LeiosSeatId LeiosVote))
-> (Votes -> Map SlotNo SlotVotes)
-> Votes
-> Map SlotNo (Map LeiosSeatId LeiosVote)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Votes -> Map SlotNo SlotVotes
votesBySlot (Votes -> Map SlotNo (Map LeiosSeatId LeiosVote))
-> STM m Votes -> STM m (Map SlotNo (Map LeiosSeatId LeiosVote))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m Votes -> STM m Votes
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (VoteState m blk -> StrictTVar m Votes
forall (m :: * -> *) blk. VoteState m blk -> StrictTVar m Votes
votes VoteState m blk
st)

-- | Keep a vote the node has neither seen nor forgotten, as it was pruned past
-- the vote's deadline already.
recordVote ::
  IOLike m =>
  VoteState m blk -> AcceptedVote -> STM m (Either AddVoteResult ())
recordVote :: forall (m :: * -> *) blk.
IOLike m =>
VoteState m blk -> AcceptedVote -> STM m (Either AddVoteResult ())
recordVote VoteState m blk
st MkAcceptedVote{LeiosVote
acceptedVote :: AcceptedVote -> LeiosVote
acceptedVote :: LeiosVote
acceptedVote, SlotNo
voteElectionSlot :: AcceptedVote -> SlotNo
voteElectionSlot :: SlotNo
voteElectionSlot, VoteWindow
voteWindow :: AcceptedVote -> VoteWindow
voteWindow :: VoteWindow
voteWindow} = do
  vs <- StrictTVar m Votes -> STM m Votes
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (VoteState m blk -> StrictTVar m Votes
forall (m :: * -> *) blk. VoteState m blk -> StrictTVar m Votes
votes VoteState m blk
st)
  let before = SlotNo -> Map SlotNo SlotVotes -> Maybe SlotVotes
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SlotNo
voteElectionSlot (Votes -> Map SlotNo SlotVotes
votesBySlot Votes
vs)
  if
    | voteUntil voteWindow < votesPrunedAt vs -> pure (Left ArrivedTooLate)
    | maybe False (Map.member (voteSeatId acceptedVote) . slotVotes) before -> pure (Left AlreadyKnown)
    | otherwise -> do
        writeTVar
          (votes st)
          vs{votesBySlot = Map.insertWith keepFirst voteElectionSlot slotVotes' (votesBySlot vs)}
        pure (Right ())
 where
  slotVotes' :: SlotVotes
slotVotes' =
    RelativeTime -> Map LeiosSeatId LeiosVote -> SlotVotes
MkSlotVotes
      (VoteWindow -> RelativeTime
voteUntil VoteWindow
voteWindow)
      (LeiosSeatId -> LeiosVote -> Map LeiosSeatId LeiosVote
forall k a. k -> a -> Map k a
Map.singleton (LeiosVote -> LeiosSeatId
voteSeatId LeiosVote
acceptedVote) LeiosVote
acceptedVote)

  keepFirst :: SlotVotes -> SlotVotes -> SlotVotes
keepFirst SlotVotes
new SlotVotes
old = SlotVotes
old{slotVotes = Map.union (slotVotes old) (slotVotes new)}

-- | Forget the votes of every election slot whose deadline has passed at the
-- given time.
--
-- 'recordVote' then finds any later copy of their votes 'ArrivedTooLate'.
pruneVotes ::
  IOLike m =>
  VoteState m blk -> RelativeTime -> STM m ()
pruneVotes :: forall (m :: * -> *) blk.
IOLike m =>
VoteState m blk -> RelativeTime -> STM m ()
pruneVotes VoteState m blk
st RelativeTime
now =
  StrictTVar m Votes -> (Votes -> Votes) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (VoteState m blk -> StrictTVar m Votes
forall (m :: * -> *) blk. VoteState m blk -> StrictTVar m Votes
votes VoteState m blk
st) ((Votes -> Votes) -> STM m ()) -> (Votes -> Votes) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \MkVotes{RelativeTime
votesPrunedAt :: Votes -> RelativeTime
votesPrunedAt :: RelativeTime
votesPrunedAt, Map SlotNo SlotVotes
votesBySlot :: Votes -> Map SlotNo SlotVotes
votesBySlot :: Map SlotNo SlotVotes
votesBySlot} ->
    RelativeTime -> Map SlotNo SlotVotes -> Votes
MkVotes
      (RelativeTime -> RelativeTime -> RelativeTime
forall a. Ord a => a -> a -> a
max RelativeTime
now RelativeTime
votesPrunedAt)
      ((SlotVotes -> Bool) -> Map SlotNo SlotVotes -> Map SlotNo SlotVotes
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((RelativeTime
now RelativeTime -> RelativeTime -> Bool
forall a. Ord a => a -> a -> Bool
<=) (RelativeTime -> Bool)
-> (SlotVotes -> RelativeTime) -> SlotVotes -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotVotes -> RelativeTime
slotRelayUntil) Map SlotNo SlotVotes
votesBySlot)

-- | Prune the votes every second; see 'pruneVotes'.
votePruner :: IOLike m => VoteState m blk -> SystemTime m -> m Void
votePruner :: forall (m :: * -> *) blk.
IOLike m =>
VoteState m blk -> SystemTime m -> m Void
votePruner VoteState m blk
st SystemTime m
systemTime = m () -> m Void
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Void) -> m () -> m Void
forall a b. (a -> b) -> a -> b
$ do
  now <- SystemTime m -> m RelativeTime
forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent SystemTime m
systemTime
  atomically $ pruneVotes st now
  threadDelay 1