{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

-- | Peras vote aggregation and certificate forging
--
-- This module implements the core voting logic for the Peras protocol, which
-- aggregates weighted votes on chain blocks and forges certificates when
-- quorum is reached.
--
-- = Overview
--
-- In Peras, validators vote on specific blocks during designated voting rounds.
-- Each vote carries a weight, and votes are aggregated by:
--
--   * __Round__: each vote belongs to a specific 'PerasRoundNo'
--   * __Target__: within a round, votes are cast for different block 'Point's
--
-- As votes arrive, the system tracks the total weight backing each candidate
-- block. When one target accumulates enough weight to exceed the configured
-- quorum threshold, a certificate is automatically forged for that block,
-- making it a winner for that round.
--
-- = State Machine
--
-- For every round being voted for, the aggregation follows a state machine:
--
-- 1. __Quorum not reached__: multiple block targets are candidates, each
--    accumulating votes and weight. All targets compete to reach quorum first.
--
-- 2. __Quorum reached__: once a target reaches quorum, it becomes the winner
--    and a certificate is forged. All other targets become losers and continue
--    tracking votes without affecting the outcome.
--
-- = Quorum Threshold and Multiple Winners
--
-- The quorum threshold is parameterized via 'PerasParams' inside
-- 'PerasEpochContext'. Depending on this configuration and the weight
-- distribution, it may be theoretically possible for multiple targets to exceed
-- the threshold within the same round.
--
-- This module treats multiple winners as an error condition and rejects votes
-- that would cause this, raising instead a 'RoundVoteStateLoserAboveQuorum'
-- exception. This indicates that either:
--   * The quorum threshold is misconfigured, or that
--   * We were extremely unlucky when randomly selecting the voting committee.
--
-- With a correct threshold configuration (e.g., > 3/4 of total weight + a small
-- safety margin to account for an unlucky local sortition when selecting
-- non-persistent voters during committee selection), multiple winners should be
-- impossible given honest weight distribution.
--
-- = Key Types
--
--   * 'PerasRoundVoteState': tracks all voting activity for a single round, and
--      its logically split between separate 'NoQuorum' and 'Quorum' types
--      representing the two states (1) and (2) described above, respectively.
--   * 'PerasTargetVoteState': tracks votes for one specific block target
--   * 'PerasVoteCollection': raw vote count and weight accumulation
--   * 'PerasTargetVoteStatus': type-level status (Candidate/Winner/Loser)
--   * 'UpdateRoundVoteStateError': errors from invalid state transitions
--
-- = Usage
--
-- The primary entry point is 'updatePerasRoundVoteStates', which adds a new
-- vote to the aggregate state. Pattern synonyms 'VoteGeneratedNewCert' and
-- 'VoteDidntGenerateNewCert' allow clients to observe when certificates are
-- freshly forged (as opposed to voting on an already-won target).
module Ouroboros.Consensus.Peras.Vote.Aggregation
  ( PerasRoundVoteState
  , getPerasRoundVoteStateRound
  , getPerasRoundVoteStateCertMaybe
  , getPerasRoundVoteStateMaxTargetedSlot
  , pattern VoteGeneratedNewCert
  , pattern VoteDidntGenerateNewCert
  , updatePerasRoundVoteStates
  , UpdateRoundVoteStateError (..)
  , PerasTargetVoteState
  , getPerasTargetVoteStateTotalWeight
  , getPerasTargetVoteStateBlock
  , PerasVoteCollectionWithQuorum (..)
  ) where

import Control.Exception (assert)
import Control.Monad.Class.MonadSTM (MonadSTM (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Functor.Compose (Compose (..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime (WithArrivalTime)
import Ouroboros.Consensus.Peras.Context
  ( PerasEpochContextNotFoundForRound
  , PerasEpochContextResolverHandle (..)
  , resolveRoundNo
  )

{-------------------------------------------------------------------------------
  Voting state for a given Peras round
-------------------------------------------------------------------------------}

-- | Current vote state for a given round
data PerasRoundVoteState blk = PerasRoundVoteState
  { forall blk. PerasRoundVoteState blk -> PerasRoundNo
prvsRoundNo :: !PerasRoundNo
  , forall blk. PerasRoundVoteState blk -> PerasEpochContext blk
prvsEpochContext :: !(PerasEpochContext blk)
  , forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState :: !(Either (NoQuorum blk) (Quorum blk))
  }

deriving instance
  ( StandardHash blk
  , Show (PerasVote blk)
  , Show (PerasCert blk)
  , Show (PerasVotingCommittee blk)
  ) =>
  Show (PerasRoundVoteState blk)
deriving instance
  ( StandardHash blk
  , Eq (PerasVote blk)
  , Eq (PerasCert blk)
  , Eq (PerasVotingCommittee blk)
  ) =>
  Eq (PerasRoundVoteState blk)
deriving instance
  ( StandardHash blk
  , NoThunks (PerasVote blk)
  , NoThunks (PerasCert blk)
  , NoThunks (PerasVotingCommittee blk)
  ) =>
  NoThunks (PerasRoundVoteState blk)
deriving instance
  Generic (PerasRoundVoteState blk)

-- | Current vote state when a quorum has not yet been reached
data NoQuorum blk = NoQuorum
  { forall blk.
NoQuorum blk
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Candidate))
  }

deriving instance
  ( StandardHash blk
  , Show (PerasVote blk)
  , Show (PerasCert blk)
  ) =>
  Show (NoQuorum blk)
deriving instance
  ( StandardHash blk
  , Eq (PerasVote blk)
  , Eq (PerasCert blk)
  ) =>
  Eq (NoQuorum blk)
deriving instance
  ( StandardHash blk
  , NoThunks (PerasVote blk)
  , NoThunks (PerasCert blk)
  ) =>
  NoThunks (NoQuorum blk)
deriving instance
  Generic (NoQuorum blk)

-- | Current vote state when a quorum has been reached
data Quorum blk = Quorum
  { forall blk. Quorum blk -> Word64
excessVotes :: !Word64
  , forall blk.
Quorum blk -> Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Loser))
  , forall blk. Quorum blk -> PerasTargetVoteState blk 'Winner
winnerState :: !(PerasTargetVoteState blk 'Winner)
  }

deriving instance
  ( StandardHash blk
  , Show (PerasVote blk)
  , Show (PerasCert blk)
  ) =>
  Show (Quorum blk)
deriving instance
  ( StandardHash blk
  , Eq (PerasVote blk)
  , Eq (PerasCert blk)
  ) =>
  Eq (Quorum blk)
deriving instance
  ( StandardHash blk
  , NoThunks (PerasVote blk)
  , NoThunks (PerasCert blk)
  ) =>
  NoThunks (Quorum blk)
deriving instance
  Generic (Quorum blk)

-- | Get the round number of a round vote state
getPerasRoundVoteStateRound :: PerasRoundVoteState blk -> PerasRoundNo
getPerasRoundVoteStateRound :: forall blk. PerasRoundVoteState blk -> PerasRoundNo
getPerasRoundVoteStateRound = PerasRoundVoteState blk -> PerasRoundNo
forall blk. PerasRoundVoteState blk -> PerasRoundNo
prvsRoundNo

-- | Get the certificate if quorum was reached for the given round
getPerasRoundVoteStateCertMaybe ::
  PerasRoundVoteState blk ->
  Maybe (ValidatedPerasCert blk)
getPerasRoundVoteStateCertMaybe :: forall blk.
PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
getPerasRoundVoteStateCertMaybe = \case
  PerasRoundVoteState
    { prvsState :: forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState =
      Right
        Quorum
          { winnerState :: forall blk. Quorum blk -> PerasTargetVoteState blk 'Winner
winnerState =
            PerasTargetVoteWinner PerasVoteCollection blk
_ ValidatedPerasCert blk
cert
          }
    } ->
      ValidatedPerasCert blk -> Maybe (ValidatedPerasCert blk)
forall a. a -> Maybe a
Just ValidatedPerasCert blk
cert
  PerasRoundVoteState blk
_ ->
    Maybe (ValidatedPerasCert blk)
forall a. Maybe a
Nothing

-- | Get the youngest (maximum) slot targeted by a vote in this round.
--
-- This is useful for garbage collection: a round voting data can be fully
-- collected only when its youngest targeted slot is strictly older than the
-- GC threshold.
getPerasRoundVoteStateMaxTargetedSlot ::
  PerasRoundVoteState blk ->
  WithOrigin SlotNo
getPerasRoundVoteStateMaxTargetedSlot :: forall blk. PerasRoundVoteState blk -> WithOrigin SlotNo
getPerasRoundVoteStateMaxTargetedSlot PerasRoundVoteState{Either (NoQuorum blk) (Quorum blk)
prvsState :: forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState :: Either (NoQuorum blk) (Quorum blk)
prvsState} =
  case Either (NoQuorum blk) (Quorum blk)
prvsState of
    Left NoQuorum{Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates :: forall blk.
NoQuorum blk
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates :: Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates} ->
      [WithOrigin SlotNo] -> WithOrigin SlotNo
forall {t}. Ord t => [WithOrigin t] -> WithOrigin t
maximumOrOrigin ([WithOrigin SlotNo] -> WithOrigin SlotNo)
-> [WithOrigin SlotNo] -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ (Point blk -> WithOrigin SlotNo)
-> [Point blk] -> [WithOrigin SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot ([Point blk] -> [WithOrigin SlotNo])
-> [Point blk] -> [WithOrigin SlotNo]
forall a b. (a -> b) -> a -> b
$ Map (Point blk) (PerasTargetVoteState blk 'Candidate)
-> [Point blk]
forall k a. Map k a -> [k]
Map.keys Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates
    Right Quorum{PerasTargetVoteState blk 'Winner
winnerState :: forall blk. Quorum blk -> PerasTargetVoteState blk 'Winner
winnerState :: PerasTargetVoteState blk 'Winner
winnerState, Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates :: forall blk.
Quorum blk -> Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates :: Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates} ->
      [WithOrigin SlotNo] -> WithOrigin SlotNo
forall {t}. Ord t => [WithOrigin t] -> WithOrigin t
maximumOrOrigin ([WithOrigin SlotNo] -> WithOrigin SlotNo)
-> [WithOrigin SlotNo] -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$
        Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (PerasTargetVoteState blk 'Winner -> Point blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> Point blk
getPerasTargetVoteStateBlock PerasTargetVoteState blk 'Winner
winnerState)
          WithOrigin SlotNo -> [WithOrigin SlotNo] -> [WithOrigin SlotNo]
forall a. a -> [a] -> [a]
: (Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point blk -> WithOrigin SlotNo)
-> [Point blk] -> [WithOrigin SlotNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Point blk) (PerasTargetVoteState blk 'Loser) -> [Point blk]
forall k a. Map k a -> [k]
Map.keys Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates)
 where
  maximumOrOrigin :: [WithOrigin t] -> WithOrigin t
maximumOrOrigin [] = WithOrigin t
forall t. WithOrigin t
Origin
  maximumOrOrigin [WithOrigin t]
xs = [WithOrigin t] -> WithOrigin t
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [WithOrigin t]
xs

-- | Create a fresh round vote state for the given round number
freshRoundVoteState ::
  MonadSTM m =>
  PerasRoundNo ->
  PerasEpochContextResolverHandle m blk ->
  STM m (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
freshRoundVoteState :: forall (m :: * -> *) blk.
MonadSTM m =>
PerasRoundNo
-> PerasEpochContextResolverHandle m blk
-> STM
     m
     (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
freshRoundVoteState PerasRoundNo
roundNo PerasEpochContextResolverHandle m blk
resolverHandle = do
  resolver <- PerasEpochContextResolverHandle m blk
-> STM m (PerasEpochContextResolver blk)
forall (m :: * -> *) blk.
PerasEpochContextResolverHandle m blk
-> STM m (PerasEpochContextResolver blk)
getPerasEpochContextResolver PerasEpochContextResolverHandle m blk
resolverHandle
  pure $
    bimap RoundVoteStateEpochContextNotFound mkFreshRoundVoteState $
      resolveRoundNo resolver roundNo
 where
  mkFreshRoundVoteState :: PerasEpochContext blk -> PerasRoundVoteState blk
mkFreshRoundVoteState PerasEpochContext blk
context =
    PerasRoundVoteState
      { prvsRoundNo :: PerasRoundNo
prvsRoundNo = PerasRoundNo
roundNo
      , prvsEpochContext :: PerasEpochContext blk
prvsEpochContext = PerasEpochContext blk
context
      , prvsState :: Either (NoQuorum blk) (Quorum blk)
prvsState =
          NoQuorum blk -> Either (NoQuorum blk) (Quorum blk)
forall a b. a -> Either a b
Left
            NoQuorum
              { candidateStates :: Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates =
                  Map (Point blk) (PerasTargetVoteState blk 'Candidate)
forall k a. Map k a
Map.empty
              }
      }

-- | Errors that may occur when updating the round vote state with a new vote
data UpdateRoundVoteStateError blk
  = RoundVoteStateLoserAboveQuorum
      (PerasTargetVoteState blk 'Winner)
      (PerasTargetVoteState blk 'Loser)
  | RoundVoteStateForgingCertError
      (PerasError blk)
  | RoundVoteStateEpochContextNotFound
      PerasEpochContextNotFoundForRound

-- | Add a vote to an existing round vote aggregate.
--
-- PRECONDITION: the vote's round must match the aggregate's round.
--
-- May fail if the state transition is invalid (e.g., a loser going above
-- quorum) or if forging the certificate fails.
updatePerasRoundVoteState ::
  forall blk.
  BlockSupportsPeras blk =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasRoundVoteState blk ->
  Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
updatePerasRoundVoteState :: forall blk.
BlockSupportsPeras blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
updatePerasRoundVoteState WithArrivalTime (ValidatedPerasVote blk)
vote PerasRoundVoteState blk
roundState =
  Bool
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote blk. IsPerasVote vote blk => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote PerasRoundNo -> PerasRoundNo -> Bool
forall a. Eq a => a -> a -> Bool
== PerasRoundVoteState blk -> PerasRoundNo
forall blk. PerasRoundVoteState blk -> PerasRoundNo
getPerasRoundVoteStateRound PerasRoundVoteState blk
roundState) (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
 -> Either
      (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a b. (a -> b) -> a -> b
$ do
    case PerasRoundVoteState blk
roundState of
      -- Quorum not yet reached
      state :: PerasRoundVoteState blk
state@PerasRoundVoteState
        { prvsState :: forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState =
          Left
            NoQuorum
              { Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates :: forall blk.
NoQuorum blk
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates :: Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates
              }
        } -> do
          let updateMaybeCandidateState :: Maybe (PerasTargetVoteState blk 'Candidate)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
updateMaybeCandidateState = \case
                Maybe (PerasTargetVoteState blk 'Candidate)
Nothing ->
                  PerasEpochContext blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
forall blk.
BlockSupportsPeras blk =>
PerasEpochContext blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
candidateOrWinnerVoteStateSingleton (PerasRoundVoteState blk -> PerasEpochContext blk
forall blk. PerasRoundVoteState blk -> PerasEpochContext blk
prvsEpochContext PerasRoundVoteState blk
roundState) WithArrivalTime (ValidatedPerasVote blk)
vote
                Just PerasTargetVoteState blk 'Candidate
oldCandidateState ->
                  PerasEpochContext blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Candidate
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
forall blk.
BlockSupportsPeras blk =>
PerasEpochContext blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Candidate
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
updateCandidateVoteState (PerasRoundVoteState blk -> PerasEpochContext blk
forall blk. PerasRoundVoteState blk -> PerasEpochContext blk
prvsEpochContext PerasRoundVoteState blk
roundState) WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Candidate
oldCandidateState
          candidateOrWinnerState <-
            Maybe (PerasTargetVoteState blk 'Candidate)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
updateMaybeCandidateState (Point blk
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
-> Maybe (PerasTargetVoteState blk 'Candidate)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (WithArrivalTime (ValidatedPerasVote blk) -> Point blk
forall vote blk. IsPerasVote vote blk => vote -> Point blk
getPerasVotePoint WithArrivalTime (ValidatedPerasVote blk)
vote) Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates)
          case candidateOrWinnerState of
            RemainedCandidate PerasTargetVoteState blk 'Candidate
newCandidateState -> do
              -- Quorum still not reached for this round
              let prvsCandidateStates' :: Map (Point blk) (PerasTargetVoteState blk 'Candidate)
prvsCandidateStates' =
                    Point blk
-> PerasTargetVoteState blk 'Candidate
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
                      (WithArrivalTime (ValidatedPerasVote blk) -> Point blk
forall vote blk. IsPerasVote vote blk => vote -> Point blk
getPerasVotePoint WithArrivalTime (ValidatedPerasVote blk)
vote)
                      PerasTargetVoteState blk 'Candidate
newCandidateState
                      Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates
              PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a. a -> Either (UpdateRoundVoteStateError blk) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasRoundVoteState blk
 -> Either
      (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a b. (a -> b) -> a -> b
$
                PerasRoundVoteState blk
state
                  { prvsState =
                      Left
                        NoQuorum
                          { candidateStates = prvsCandidateStates'
                          }
                  }
            BecameWinner PerasTargetVoteState blk 'Winner
winnerState -> do
              -- Quorum has been reached for the first time here for this round
              let winnerPoint :: Point blk
winnerPoint =
                    PerasVoteTarget blk -> Point blk
forall blk. PerasVoteTarget blk -> Point blk
pvtBlock (PerasVoteCollection blk -> PerasVoteTarget blk
forall blk. PerasVoteCollection blk -> PerasVoteTarget blk
pvcTarget (PerasTargetVoteState blk 'Winner -> PerasVoteCollection blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection PerasTargetVoteState blk 'Winner
winnerState))
                  loserStates :: Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates =
                    PerasTargetVoteState blk 'Candidate
-> PerasTargetVoteState blk 'Loser
forall blk.
PerasTargetVoteState blk 'Candidate
-> PerasTargetVoteState blk 'Loser
candidateToLoser (PerasTargetVoteState blk 'Candidate
 -> PerasTargetVoteState blk 'Loser)
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
-> Map (Point blk) (PerasTargetVoteState blk 'Loser)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point blk
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Point blk
winnerPoint Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates
              PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a. a -> Either (UpdateRoundVoteStateError blk) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasRoundVoteState blk
 -> Either
      (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a b. (a -> b) -> a -> b
$
                PerasRoundVoteState
                  { prvsRoundNo :: PerasRoundNo
prvsRoundNo =
                      PerasRoundVoteState blk -> PerasRoundNo
forall blk. PerasRoundVoteState blk -> PerasRoundNo
prvsRoundNo PerasRoundVoteState blk
roundState
                  , prvsEpochContext :: PerasEpochContext blk
prvsEpochContext = PerasRoundVoteState blk -> PerasEpochContext blk
forall blk. PerasRoundVoteState blk -> PerasEpochContext blk
prvsEpochContext PerasRoundVoteState blk
roundState
                  , prvsState :: Either (NoQuorum blk) (Quorum blk)
prvsState =
                      Quorum blk -> Either (NoQuorum blk) (Quorum blk)
forall a b. b -> Either a b
Right
                        Quorum
                          { excessVotes :: Word64
excessVotes = Word64
0
                          , loserStates :: Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates = Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates
                          , winnerState :: PerasTargetVoteState blk 'Winner
winnerState = PerasTargetVoteState blk 'Winner
winnerState
                          }
                  }

      -- Quorum already reached
      state :: PerasRoundVoteState blk
state@PerasRoundVoteState
        { prvsState :: forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState =
          Right
            Quorum
              { Word64
excessVotes :: forall blk. Quorum blk -> Word64
excessVotes :: Word64
excessVotes
              , PerasTargetVoteState blk 'Winner
winnerState :: forall blk. Quorum blk -> PerasTargetVoteState blk 'Winner
winnerState :: PerasTargetVoteState blk 'Winner
winnerState
              , Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates :: forall blk.
Quorum blk -> Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates :: Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates
              }
        } -> do
          let votePoint :: Point blk
votePoint =
                WithArrivalTime (ValidatedPerasVote blk) -> Point blk
forall vote blk. IsPerasVote vote blk => vote -> Point blk
getPerasVotePoint WithArrivalTime (ValidatedPerasVote blk)
vote
              winnerPoint :: Point blk
winnerPoint =
                PerasVoteTarget blk -> Point blk
forall blk. PerasVoteTarget blk -> Point blk
pvtBlock (PerasVoteCollection blk -> PerasVoteTarget blk
forall blk. PerasVoteCollection blk -> PerasVoteTarget blk
pvcTarget (PerasTargetVoteState blk 'Winner -> PerasVoteCollection blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection PerasTargetVoteState blk 'Winner
winnerState))
          if Point blk
votePoint Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
winnerPoint
            -- The vote ratifies the winner => update winner state
            then do
              let winnerState' :: PerasTargetVoteState blk 'Winner
winnerState' =
                    WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Winner
forall blk.
(StandardHash blk, IsPerasVote (PerasVote blk) blk) =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Winner
updateWinnerVoteState WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Winner
winnerState
              PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a. a -> Either (UpdateRoundVoteStateError blk) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasRoundVoteState blk
 -> Either
      (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a b. (a -> b) -> a -> b
$
                PerasRoundVoteState blk
state
                  { prvsState =
                      Right
                        Quorum
                          { excessVotes = excessVotes + 1
                          , winnerState = winnerState'
                          , loserStates = loserStates
                          }
                  }

            -- The vote is for a loser => update loser state
            else do
              let updateMaybeLoserVoteState :: Maybe (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
updateMaybeLoserVoteState = \case
                    Maybe (PerasTargetVoteState blk 'Loser)
Nothing ->
                      PerasEpochContext blk
-> PerasTargetVoteState blk 'Winner
-> WithArrivalTime (ValidatedPerasVote blk)
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall blk.
BlockSupportsPeras blk =>
PerasEpochContext blk
-> PerasTargetVoteState blk 'Winner
-> WithArrivalTime (ValidatedPerasVote blk)
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
loserVoteStateSingleton (PerasRoundVoteState blk -> PerasEpochContext blk
forall blk. PerasRoundVoteState blk -> PerasEpochContext blk
prvsEpochContext PerasRoundVoteState blk
roundState) PerasTargetVoteState blk 'Winner
winnerState WithArrivalTime (ValidatedPerasVote blk)
vote
                    Just PerasTargetVoteState blk 'Loser
oldLoserState ->
                      PerasEpochContext blk
-> PerasTargetVoteState blk 'Winner
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Loser
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall blk.
BlockSupportsPeras blk =>
PerasEpochContext blk
-> PerasTargetVoteState blk 'Winner
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Loser
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
updateLoserVoteState (PerasRoundVoteState blk -> PerasEpochContext blk
forall blk. PerasRoundVoteState blk -> PerasEpochContext blk
prvsEpochContext PerasRoundVoteState blk
roundState) PerasTargetVoteState blk 'Winner
winnerState WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Loser
oldLoserState

              loserStates' <-
                (Maybe (PerasTargetVoteState blk 'Loser)
 -> Either
      (UpdateRoundVoteStateError blk)
      (Maybe (PerasTargetVoteState blk 'Loser)))
-> Point blk
-> Map (Point blk) (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk)
     (Map (Point blk) (PerasTargetVoteState blk 'Loser))
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (\Maybe (PerasTargetVoteState blk 'Loser)
mState -> PerasTargetVoteState blk 'Loser
-> Maybe (PerasTargetVoteState blk 'Loser)
forall a. a -> Maybe a
Just (PerasTargetVoteState blk 'Loser
 -> Maybe (PerasTargetVoteState blk 'Loser))
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk)
     (Maybe (PerasTargetVoteState blk 'Loser))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
updateMaybeLoserVoteState Maybe (PerasTargetVoteState blk 'Loser)
mState) Point blk
votePoint Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates
              pure $
                state
                  { prvsState =
                      Right
                        Quorum
                          { excessVotes = excessVotes + 1
                          , winnerState = winnerState
                          , loserStates = loserStates'
                          }
                  }

-- | Updates the round vote states map with the given vote.
--
-- A new entry is created if necessary (i.e., if there is no existing state for
-- the vote's round).
--
-- May fail if the state transition is invalid (e.g., a loser going above
-- quorum) or if forging the certificate fails.
updatePerasRoundVoteStates ::
  forall m blk.
  (BlockSupportsPeras blk, MonadSTM m) =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasEpochContextResolverHandle m blk ->
  Map PerasRoundNo (PerasRoundVoteState blk) ->
  STM
    m
    ( Either
        (UpdateRoundVoteStateError blk)
        (PerasRoundVoteState blk, Map PerasRoundNo (PerasRoundVoteState blk))
    )
updatePerasRoundVoteStates :: forall (m :: * -> *) blk.
(BlockSupportsPeras blk, MonadSTM m) =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasEpochContextResolverHandle m blk
-> Map PerasRoundNo (PerasRoundVoteState blk)
-> STM
     m
     (Either
        (UpdateRoundVoteStateError blk)
        (PerasRoundVoteState blk,
         Map PerasRoundNo (PerasRoundVoteState blk)))
updatePerasRoundVoteStates WithArrivalTime (ValidatedPerasVote blk)
vote PerasEpochContextResolverHandle m blk
epochContextResolverHandle =
  (Maybe (PerasRoundVoteState blk)
 -> STM
      m
      (Either
         (UpdateRoundVoteStateError blk)
         (PerasRoundVoteState blk, PerasRoundVoteState blk)))
-> PerasRoundNo
-> Map PerasRoundNo (PerasRoundVoteState blk)
-> STM
     m
     (Either
        (UpdateRoundVoteStateError blk)
        (PerasRoundVoteState blk,
         Map PerasRoundNo (PerasRoundVoteState blk)))
forall k a e.
Ord k =>
(Maybe a -> STM m (Either e (a, a)))
-> k -> Map k a -> STM m (Either e (a, Map k a))
alterMapAndReturnUpdatedValue
    Maybe (PerasRoundVoteState blk)
-> STM
     m
     (Either
        (UpdateRoundVoteStateError blk)
        (PerasRoundVoteState blk, PerasRoundVoteState blk))
updateMaybePerasRoundVoteState
    (WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote blk. IsPerasVote vote blk => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote)
 where
  -- We use the Functor instance of `Compose (STM m) (Compose (Either e) ((,) s))` ≅
  -- `λt. STM m (Either e (s, t))` in `Map.alterF`. That way, we can return both the
  -- updated map and the updated leaf in one pass, and still handle errors.
  alterMapAndReturnUpdatedValue ::
    Ord k =>
    (Maybe a -> STM m (Either e (a, a))) ->
    k ->
    Map k a ->
    STM m (Either e (a, Map k a))
  alterMapAndReturnUpdatedValue :: forall k a e.
Ord k =>
(Maybe a -> STM m (Either e (a, a)))
-> k -> Map k a -> STM m (Either e (a, Map k a))
alterMapAndReturnUpdatedValue Maybe a -> STM m (Either e (a, a))
f k
k =
    Compose (STM m) (Either e) (a, Map k a)
-> STM m (Either e (a, Map k a))
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (STM m) (Either e) (a, Map k a)
 -> STM m (Either e (a, Map k a)))
-> (Map k a -> Compose (STM m) (Either e) (a, Map k a))
-> Map k a
-> STM m (Either e (a, Map k a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose (Compose (STM m) (Either e)) ((,) a) (Map k a)
-> Compose (STM m) (Either e) (a, Map k a)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (Compose (STM m) (Either e)) ((,) a) (Map k a)
 -> Compose (STM m) (Either e) (a, Map k a))
-> (Map k a
    -> Compose (Compose (STM m) (Either e)) ((,) a) (Map k a))
-> Map k a
-> Compose (STM m) (Either e) (a, Map k a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Compose (Compose (STM m) (Either e)) ((,) a) (Maybe a))
-> k
-> Map k a
-> Compose (Compose (STM m) (Either e)) ((,) a) (Map k a)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF ((a -> Maybe a)
-> Compose (Compose (STM m) (Either e)) ((,) a) a
-> Compose (Compose (STM m) (Either e)) ((,) a) (Maybe a)
forall a b.
(a -> b)
-> Compose (Compose (STM m) (Either e)) ((,) a) a
-> Compose (Compose (STM m) (Either e)) ((,) a) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Compose (Compose (STM m) (Either e)) ((,) a) a
 -> Compose (Compose (STM m) (Either e)) ((,) a) (Maybe a))
-> (Maybe a -> Compose (Compose (STM m) (Either e)) ((,) a) a)
-> Maybe a
-> Compose (Compose (STM m) (Either e)) ((,) a) (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Compose (STM m) (Either e) (a, a)
-> Compose (Compose (STM m) (Either e)) ((,) a) a
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Compose (STM m) (Either e) (a, a)
 -> Compose (Compose (STM m) (Either e)) ((,) a) a)
-> (Maybe a -> Compose (STM m) (Either e) (a, a))
-> Maybe a
-> Compose (Compose (STM m) (Either e)) ((,) a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM m (Either e (a, a)) -> Compose (STM m) (Either e) (a, a)
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (STM m (Either e (a, a)) -> Compose (STM m) (Either e) (a, a))
-> (Maybe a -> STM m (Either e (a, a)))
-> Maybe a
-> Compose (STM m) (Either e) (a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> STM m (Either e (a, a))
f)) k
k

  -- If there is no existing state for the vote's round, create a fresh one.
  existingOrFreshRoundVoteState ::
    Maybe (PerasRoundVoteState blk) ->
    STM m (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
  existingOrFreshRoundVoteState :: Maybe (PerasRoundVoteState blk)
-> STM
     m
     (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
existingOrFreshRoundVoteState = \case
    Maybe (PerasRoundVoteState blk)
Nothing -> PerasRoundNo
-> PerasEpochContextResolverHandle m blk
-> STM
     m
     (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
forall (m :: * -> *) blk.
MonadSTM m =>
PerasRoundNo
-> PerasEpochContextResolverHandle m blk
-> STM
     m
     (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
freshRoundVoteState (WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote blk. IsPerasVote vote blk => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote) PerasEpochContextResolverHandle m blk
epochContextResolverHandle
    Just PerasRoundVoteState blk
roundState -> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
-> STM
     m
     (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a b. b -> Either a b
Right PerasRoundVoteState blk
roundState)

  -- Update the round state, creating a fresh one if necessary, and returning
  -- the updated state.
  updateMaybePerasRoundVoteState ::
    Maybe (PerasRoundVoteState blk) ->
    STM
      m
      ( Either
          (UpdateRoundVoteStateError blk)
          (PerasRoundVoteState blk, PerasRoundVoteState blk)
      )
  updateMaybePerasRoundVoteState :: Maybe (PerasRoundVoteState blk)
-> STM
     m
     (Either
        (UpdateRoundVoteStateError blk)
        (PerasRoundVoteState blk, PerasRoundVoteState blk))
updateMaybePerasRoundVoteState Maybe (PerasRoundVoteState blk)
mRoundState = do
    Maybe (PerasRoundVoteState blk)
-> STM
     m
     (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
existingOrFreshRoundVoteState Maybe (PerasRoundVoteState blk)
mRoundState STM
  m
  (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
-> (Either
      (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
    -> STM
         m
         (Either
            (UpdateRoundVoteStateError blk)
            (PerasRoundVoteState blk, PerasRoundVoteState blk)))
-> STM
     m
     (Either
        (UpdateRoundVoteStateError blk)
        (PerasRoundVoteState blk, PerasRoundVoteState blk))
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left UpdateRoundVoteStateError blk
err -> Either
  (UpdateRoundVoteStateError blk)
  (PerasRoundVoteState blk, PerasRoundVoteState blk)
-> STM
     m
     (Either
        (UpdateRoundVoteStateError blk)
        (PerasRoundVoteState blk, PerasRoundVoteState blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRoundVoteStateError blk
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasRoundVoteState blk, PerasRoundVoteState blk)
forall a b. a -> Either a b
Left UpdateRoundVoteStateError blk
err)
      Right PerasRoundVoteState blk
roundState -> do
        case WithArrivalTime (ValidatedPerasVote blk)
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall blk.
BlockSupportsPeras blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
updatePerasRoundVoteState WithArrivalTime (ValidatedPerasVote blk)
vote PerasRoundVoteState blk
roundState of
          Left UpdateRoundVoteStateError blk
err -> Either
  (UpdateRoundVoteStateError blk)
  (PerasRoundVoteState blk, PerasRoundVoteState blk)
-> STM
     m
     (Either
        (UpdateRoundVoteStateError blk)
        (PerasRoundVoteState blk, PerasRoundVoteState blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRoundVoteStateError blk
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasRoundVoteState blk, PerasRoundVoteState blk)
forall a b. a -> Either a b
Left UpdateRoundVoteStateError blk
err)
          Right PerasRoundVoteState blk
newRoundState -> Either
  (UpdateRoundVoteStateError blk)
  (PerasRoundVoteState blk, PerasRoundVoteState blk)
-> STM
     m
     (Either
        (UpdateRoundVoteStateError blk)
        (PerasRoundVoteState blk, PerasRoundVoteState blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PerasRoundVoteState blk, PerasRoundVoteState blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasRoundVoteState blk, PerasRoundVoteState blk)
forall a b. b -> Either a b
Right (PerasRoundVoteState blk
newRoundState, PerasRoundVoteState blk
newRoundState))

{-------------------------------------------------------------------------------
  Peras round vote state pattern synonyms
-------------------------------------------------------------------------------}

-- These pattern synonyms hide internal details of the round vote state, while
-- allowing the client to observe when a certificate has just been forged.

-- | Matches a round vote state where a certificate has just been forged
pattern VoteGeneratedNewCert ::
  ValidatedPerasCert blk ->
  PerasRoundVoteState blk
pattern $mVoteGeneratedNewCert :: forall {r} {blk}.
PerasRoundVoteState blk
-> (ValidatedPerasCert blk -> r) -> ((# #) -> r) -> r
VoteGeneratedNewCert cert <-
  (voteGeneratedCert -> Just cert)

-- | Matches a round vote state where a certificate has either not yet been
-- forged, or was forged by a previous vote
pattern VoteDidntGenerateNewCert ::
  PerasRoundVoteState blk
pattern $mVoteDidntGenerateNewCert :: forall {r} {blk}.
PerasRoundVoteState blk -> ((# #) -> r) -> ((# #) -> r) -> r
VoteDidntGenerateNewCert <-
  (voteGeneratedCert -> Nothing)

{-# COMPLETE VoteGeneratedNewCert, VoteDidntGenerateNewCert #-}

-- | Helper for the above pattern synonyms
voteGeneratedCert :: PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
voteGeneratedCert :: forall blk.
PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
voteGeneratedCert = \case
  PerasRoundVoteState
    { prvsState :: forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState =
      Right
        Quorum
          { excessVotes :: forall blk. Quorum blk -> Word64
excessVotes = Word64
0 -- just reached quorum
          , winnerState :: forall blk. Quorum blk -> PerasTargetVoteState blk 'Winner
winnerState = PerasTargetVoteWinner PerasVoteCollection blk
_ ValidatedPerasCert blk
cert
          }
    } ->
      ValidatedPerasCert blk -> Maybe (ValidatedPerasCert blk)
forall a. a -> Maybe a
Just ValidatedPerasCert blk
cert
  PerasRoundVoteState blk
_ ->
    Maybe (ValidatedPerasCert blk)
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Peras target vote status
-------------------------------------------------------------------------------}

-- | Indicate the current status of the target w.r.t the voting process
data PerasTargetVoteStatus
  = Candidate
  | Winner
  | Loser
  deriving stock (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
(PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> Eq PerasTargetVoteStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
== :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
$c/= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
/= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
Eq, Eq PerasTargetVoteStatus
Eq PerasTargetVoteStatus =>
(PerasTargetVoteStatus -> PerasTargetVoteStatus -> Ordering)
-> (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> (PerasTargetVoteStatus
    -> PerasTargetVoteStatus -> PerasTargetVoteStatus)
-> (PerasTargetVoteStatus
    -> PerasTargetVoteStatus -> PerasTargetVoteStatus)
-> Ord PerasTargetVoteStatus
PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
PerasTargetVoteStatus -> PerasTargetVoteStatus -> Ordering
PerasTargetVoteStatus
-> PerasTargetVoteStatus -> PerasTargetVoteStatus
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Ordering
compare :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Ordering
$c< :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
< :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
$c<= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
<= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
$c> :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
> :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
$c>= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
>= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
$cmax :: PerasTargetVoteStatus
-> PerasTargetVoteStatus -> PerasTargetVoteStatus
max :: PerasTargetVoteStatus
-> PerasTargetVoteStatus -> PerasTargetVoteStatus
$cmin :: PerasTargetVoteStatus
-> PerasTargetVoteStatus -> PerasTargetVoteStatus
min :: PerasTargetVoteStatus
-> PerasTargetVoteStatus -> PerasTargetVoteStatus
Ord, Int -> PerasTargetVoteStatus -> ShowS
[PerasTargetVoteStatus] -> ShowS
PerasTargetVoteStatus -> String
(Int -> PerasTargetVoteStatus -> ShowS)
-> (PerasTargetVoteStatus -> String)
-> ([PerasTargetVoteStatus] -> ShowS)
-> Show PerasTargetVoteStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PerasTargetVoteStatus -> ShowS
showsPrec :: Int -> PerasTargetVoteStatus -> ShowS
$cshow :: PerasTargetVoteStatus -> String
show :: PerasTargetVoteStatus -> String
$cshowList :: [PerasTargetVoteStatus] -> ShowS
showList :: [PerasTargetVoteStatus] -> ShowS
Show, (forall x. PerasTargetVoteStatus -> Rep PerasTargetVoteStatus x)
-> (forall x. Rep PerasTargetVoteStatus x -> PerasTargetVoteStatus)
-> Generic PerasTargetVoteStatus
forall x. Rep PerasTargetVoteStatus x -> PerasTargetVoteStatus
forall x. PerasTargetVoteStatus -> Rep PerasTargetVoteStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PerasTargetVoteStatus -> Rep PerasTargetVoteStatus x
from :: forall x. PerasTargetVoteStatus -> Rep PerasTargetVoteStatus x
$cto :: forall x. Rep PerasTargetVoteStatus x -> PerasTargetVoteStatus
to :: forall x. Rep PerasTargetVoteStatus x -> PerasTargetVoteStatus
Generic)
  deriving anyclass Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo)
Proxy PerasTargetVoteStatus -> String
(Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo))
-> (Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo))
-> (Proxy PerasTargetVoteStatus -> String)
-> NoThunks PerasTargetVoteStatus
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PerasTargetVoteStatus -> String
showTypeOf :: Proxy PerasTargetVoteStatus -> String
NoThunks

-- | Voting state for a given target.
--
-- We indicate at type level the status of the target w.r.t the voting process.
data PerasTargetVoteState blk (status :: PerasTargetVoteStatus) where
  PerasTargetVoteCandidate ::
    !(PerasVoteCollection blk) ->
    PerasTargetVoteState blk 'Candidate
  PerasTargetVoteLoser ::
    !(PerasVoteCollection blk) ->
    PerasTargetVoteState blk 'Loser
  PerasTargetVoteWinner ::
    !(PerasVoteCollection blk) ->
    !(ValidatedPerasCert blk) ->
    PerasTargetVoteState blk 'Winner

deriving stock instance
  ( Eq (PerasVoteCollection blk)
  , Eq (ValidatedPerasCert blk)
  ) =>
  Eq (PerasTargetVoteState blk status)

deriving stock instance
  ( Ord (PerasVoteCollection blk)
  , Ord (ValidatedPerasCert blk)
  ) =>
  Ord (PerasTargetVoteState blk status)

deriving stock instance
  ( Show (PerasVoteCollection blk)
  , Show (ValidatedPerasCert blk)
  ) =>
  Show (PerasTargetVoteState blk status)

instance
  ( NoThunks (PerasVoteCollection blk)
  , NoThunks (ValidatedPerasCert blk)
  ) =>
  NoThunks (PerasTargetVoteState blk status)
  where
  -- avoid the Generic-based default
  showTypeOf :: Proxy (PerasTargetVoteState blk status) -> String
showTypeOf Proxy (PerasTargetVoteState blk status)
_ = String
"PerasTargetVoteState"

  -- we can just delegate wNoThunks to our custom noThunks
  wNoThunks :: Context -> PerasTargetVoteState blk status -> IO (Maybe ThunkInfo)
wNoThunks = Context -> PerasTargetVoteState blk status -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks

  noThunks :: Context -> PerasTargetVoteState blk status -> IO (Maybe ThunkInfo)
noThunks Context
ctx (PerasTargetVoteCandidate PerasVoteCollection blk
voteCollection) =
    Context -> PerasVoteCollection blk -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx PerasVoteCollection blk
voteCollection
  noThunks Context
ctx (PerasTargetVoteLoser PerasVoteCollection blk
voteCollection) =
    Context -> PerasVoteCollection blk -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx PerasVoteCollection blk
voteCollection
  noThunks Context
ctx (PerasTargetVoteWinner PerasVoteCollection blk
voteCollection ValidatedPerasCert blk
cert) =
    Context
-> (PerasVoteCollection blk, ValidatedPerasCert blk)
-> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx (PerasVoteCollection blk
voteCollection, ValidatedPerasCert blk
cert)

-- | Extract the total weight from a target vote state
getPerasTargetVoteStateTotalWeight :: PerasTargetVoteState blk status -> VoteWeight
getPerasTargetVoteStateTotalWeight :: forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> VoteWeight
getPerasTargetVoteStateTotalWeight = PerasVoteCollection blk -> VoteWeight
forall blk. PerasVoteCollection blk -> VoteWeight
pvcTotalWeight (PerasVoteCollection blk -> VoteWeight)
-> (PerasTargetVoteState blk status -> PerasVoteCollection blk)
-> PerasTargetVoteState blk status
-> VoteWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasTargetVoteState blk status -> PerasVoteCollection blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection

-- | Extract the block point from a target vote state
getPerasTargetVoteStateBlock :: PerasTargetVoteState blk status -> Point blk
getPerasTargetVoteStateBlock :: forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> Point blk
getPerasTargetVoteStateBlock = PerasVoteTarget blk -> Point blk
forall blk. PerasVoteTarget blk -> Point blk
pvtBlock (PerasVoteTarget blk -> Point blk)
-> (PerasTargetVoteState blk status -> PerasVoteTarget blk)
-> PerasTargetVoteState blk status
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasVoteCollection blk -> PerasVoteTarget blk
forall blk. PerasVoteCollection blk -> PerasVoteTarget blk
pvcTarget (PerasVoteCollection blk -> PerasVoteTarget blk)
-> (PerasTargetVoteState blk status -> PerasVoteCollection blk)
-> PerasTargetVoteState blk status
-> PerasVoteTarget blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasTargetVoteState blk status -> PerasVoteCollection blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection

-- | Extract the underlying vote voteCollection from a target vote state
ptvsVoteCollection :: PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection :: forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection = \case
  PerasTargetVoteCandidate PerasVoteCollection blk
voteCollection -> PerasVoteCollection blk
voteCollection
  PerasTargetVoteLoser PerasVoteCollection blk
voteCollection -> PerasVoteCollection blk
voteCollection
  PerasTargetVoteWinner PerasVoteCollection blk
voteCollection ValidatedPerasCert blk
_ -> PerasVoteCollection blk
voteCollection

candidateOrWinnerVoteStateSingleton ::
  BlockSupportsPeras blk =>
  PerasEpochContext blk ->
  WithArrivalTime (ValidatedPerasVote blk) ->
  Either
    (UpdateRoundVoteStateError blk)
    (PerasVoteStateCandidateOrWinner blk)
candidateOrWinnerVoteStateSingleton :: forall blk.
BlockSupportsPeras blk =>
PerasEpochContext blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
candidateOrWinnerVoteStateSingleton PerasEpochContext blk
epochContext WithArrivalTime (ValidatedPerasVote blk)
vote =
  let voteCollection :: PerasVoteCollection blk
voteCollection = WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteCollection blk
forall blk.
IsPerasVote (PerasVote blk) blk =>
WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteCollection blk
perasVoteCollectionSingleton WithArrivalTime (ValidatedPerasVote blk)
vote
   in case PerasParams blk
-> PerasVoteCollection blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
forall blk.
PerasParams blk
-> PerasVoteCollection blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
perasVoteCollectionCheckQuorum (PerasEpochContext blk -> PerasParams blk
forall blk. PerasEpochContext blk -> PerasParams blk
pecParams PerasEpochContext blk
epochContext) PerasVoteCollection blk
voteCollection of
        Just PerasVoteCollectionWithQuorum blk
votesWithQuorum -> do
          cert <- PerasEpochContext blk
-> PerasVoteCollectionWithQuorum blk
-> Either (PerasError blk) (ValidatedPerasCert blk)
forall blk.
BlockSupportsPeras blk =>
PerasEpochContext blk
-> PerasVoteCollectionWithQuorum blk
-> Either (PerasError blk) (ValidatedPerasCert blk)
forgePerasCert PerasEpochContext blk
epochContext PerasVoteCollectionWithQuorum blk
votesWithQuorum Either (PerasError blk) (ValidatedPerasCert blk)
-> (PerasError blk -> UpdateRoundVoteStateError blk)
-> Either (UpdateRoundVoteStateError blk) (ValidatedPerasCert blk)
forall e a e'. Either e a -> (e -> e') -> Either e' a
`onErr` PerasError blk -> UpdateRoundVoteStateError blk
forall blk. PerasError blk -> UpdateRoundVoteStateError blk
RoundVoteStateForgingCertError
          pure $ BecameWinner $ PerasTargetVoteWinner voteCollection cert
        Maybe (PerasVoteCollectionWithQuorum blk)
Nothing ->
          PerasVoteStateCandidateOrWinner blk
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
forall a. a -> Either (UpdateRoundVoteStateError blk) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasVoteStateCandidateOrWinner blk
 -> Either
      (UpdateRoundVoteStateError blk)
      (PerasVoteStateCandidateOrWinner blk))
-> PerasVoteStateCandidateOrWinner blk
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
forall a b. (a -> b) -> a -> b
$ PerasTargetVoteState blk 'Candidate
-> PerasVoteStateCandidateOrWinner blk
forall blk.
PerasTargetVoteState blk 'Candidate
-> PerasVoteStateCandidateOrWinner blk
RemainedCandidate (PerasTargetVoteState blk 'Candidate
 -> PerasVoteStateCandidateOrWinner blk)
-> PerasTargetVoteState blk 'Candidate
-> PerasVoteStateCandidateOrWinner blk
forall a b. (a -> b) -> a -> b
$ PerasVoteCollection blk -> PerasTargetVoteState blk 'Candidate
forall blk.
PerasVoteCollection blk -> PerasTargetVoteState blk 'Candidate
PerasTargetVoteCandidate PerasVoteCollection blk
voteCollection

loserVoteStateSingleton ::
  BlockSupportsPeras blk =>
  PerasEpochContext blk ->
  PerasTargetVoteState blk 'Winner ->
  WithArrivalTime (ValidatedPerasVote blk) ->
  Either (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
loserVoteStateSingleton :: forall blk.
BlockSupportsPeras blk =>
PerasEpochContext blk
-> PerasTargetVoteState blk 'Winner
-> WithArrivalTime (ValidatedPerasVote blk)
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
loserVoteStateSingleton PerasEpochContext blk
epochContext PerasTargetVoteState blk 'Winner
winnerState WithArrivalTime (ValidatedPerasVote blk)
vote =
  let voteCollection :: PerasVoteCollection blk
voteCollection = WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteCollection blk
forall blk.
IsPerasVote (PerasVote blk) blk =>
WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteCollection blk
perasVoteCollectionSingleton WithArrivalTime (ValidatedPerasVote blk)
vote
   in case PerasParams blk
-> PerasVoteCollection blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
forall blk.
PerasParams blk
-> PerasVoteCollection blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
perasVoteCollectionCheckQuorum (PerasEpochContext blk -> PerasParams blk
forall blk. PerasEpochContext blk -> PerasParams blk
pecParams PerasEpochContext blk
epochContext) PerasVoteCollection blk
voteCollection of
        Just PerasVoteCollectionWithQuorum blk
_ ->
          UpdateRoundVoteStateError blk
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall a b. a -> Either a b
Left (UpdateRoundVoteStateError blk
 -> Either
      (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser))
-> UpdateRoundVoteStateError blk
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall a b. (a -> b) -> a -> b
$ PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Loser -> UpdateRoundVoteStateError blk
forall blk.
PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Loser -> UpdateRoundVoteStateError blk
RoundVoteStateLoserAboveQuorum PerasTargetVoteState blk 'Winner
winnerState (PerasVoteCollection blk -> PerasTargetVoteState blk 'Loser
forall blk.
PerasVoteCollection blk -> PerasTargetVoteState blk 'Loser
PerasTargetVoteLoser PerasVoteCollection blk
voteCollection)
        Maybe (PerasVoteCollectionWithQuorum blk)
Nothing ->
          PerasTargetVoteState blk 'Loser
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall a b. b -> Either a b
Right (PerasTargetVoteState blk 'Loser
 -> Either
      (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser))
-> PerasTargetVoteState blk 'Loser
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall a b. (a -> b) -> a -> b
$ PerasVoteCollection blk -> PerasTargetVoteState blk 'Loser
forall blk.
PerasVoteCollection blk -> PerasTargetVoteState blk 'Loser
PerasTargetVoteLoser PerasVoteCollection blk
voteCollection

-- | Convert a 'Candidate' state to a 'Loser' state.
--
-- This function is called on all candidates (except the winner) once a winner
-- is elected.
candidateToLoser ::
  PerasTargetVoteState blk 'Candidate ->
  PerasTargetVoteState blk 'Loser
candidateToLoser :: forall blk.
PerasTargetVoteState blk 'Candidate
-> PerasTargetVoteState blk 'Loser
candidateToLoser (PerasTargetVoteCandidate PerasVoteCollection blk
voteCollection) =
  PerasVoteCollection blk -> PerasTargetVoteState blk 'Loser
forall blk.
PerasVoteCollection blk -> PerasTargetVoteState blk 'Loser
PerasTargetVoteLoser PerasVoteCollection blk
voteCollection

-- | Subtype of 'PerasTargetVoteState' to indicate whether the target remains a
-- candidate or has been elected winner
data PerasVoteStateCandidateOrWinner blk
  = RemainedCandidate (PerasTargetVoteState blk 'Candidate)
  | BecameWinner (PerasTargetVoteState blk 'Winner)

-- | Add a vote to an existing target vote state if it isn't already present.
--
-- May fail if the candidate is elected winner but forging the certificate fails.
updateCandidateVoteState ::
  BlockSupportsPeras blk =>
  PerasEpochContext blk ->
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasTargetVoteState blk 'Candidate ->
  Either
    (UpdateRoundVoteStateError blk)
    (PerasVoteStateCandidateOrWinner blk)
updateCandidateVoteState :: forall blk.
BlockSupportsPeras blk =>
PerasEpochContext blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Candidate
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
updateCandidateVoteState PerasEpochContext blk
epochContext WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Candidate
oldState =
  let
    newVoteCollection :: PerasVoteCollection blk
newVoteCollection = WithArrivalTime (ValidatedPerasVote blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
forall blk.
(StandardHash blk, IsPerasVote (PerasVote blk) blk) =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
perasVoteCollectionAddVote WithArrivalTime (ValidatedPerasVote blk)
vote (PerasTargetVoteState blk 'Candidate -> PerasVoteCollection blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection PerasTargetVoteState blk 'Candidate
oldState)
   in
    case PerasParams blk
-> PerasVoteCollection blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
forall blk.
PerasParams blk
-> PerasVoteCollection blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
perasVoteCollectionCheckQuorum (PerasEpochContext blk -> PerasParams blk
forall blk. PerasEpochContext blk -> PerasParams blk
pecParams PerasEpochContext blk
epochContext) PerasVoteCollection blk
newVoteCollection of
      Just PerasVoteCollectionWithQuorum blk
votesWithQuorum -> do
        cert <- PerasEpochContext blk
-> PerasVoteCollectionWithQuorum blk
-> Either (PerasError blk) (ValidatedPerasCert blk)
forall blk.
BlockSupportsPeras blk =>
PerasEpochContext blk
-> PerasVoteCollectionWithQuorum blk
-> Either (PerasError blk) (ValidatedPerasCert blk)
forgePerasCert PerasEpochContext blk
epochContext PerasVoteCollectionWithQuorum blk
votesWithQuorum Either (PerasError blk) (ValidatedPerasCert blk)
-> (PerasError blk -> UpdateRoundVoteStateError blk)
-> Either (UpdateRoundVoteStateError blk) (ValidatedPerasCert blk)
forall e a e'. Either e a -> (e -> e') -> Either e' a
`onErr` PerasError blk -> UpdateRoundVoteStateError blk
forall blk. PerasError blk -> UpdateRoundVoteStateError blk
RoundVoteStateForgingCertError
        pure $ BecameWinner (PerasTargetVoteWinner newVoteCollection cert)
      Maybe (PerasVoteCollectionWithQuorum blk)
Nothing -> do
        PerasVoteStateCandidateOrWinner blk
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
forall a. a -> Either (UpdateRoundVoteStateError blk) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasVoteStateCandidateOrWinner blk
 -> Either
      (UpdateRoundVoteStateError blk)
      (PerasVoteStateCandidateOrWinner blk))
-> PerasVoteStateCandidateOrWinner blk
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
forall a b. (a -> b) -> a -> b
$ PerasTargetVoteState blk 'Candidate
-> PerasVoteStateCandidateOrWinner blk
forall blk.
PerasTargetVoteState blk 'Candidate
-> PerasVoteStateCandidateOrWinner blk
RemainedCandidate (PerasVoteCollection blk -> PerasTargetVoteState blk 'Candidate
forall blk.
PerasVoteCollection blk -> PerasTargetVoteState blk 'Candidate
PerasTargetVoteCandidate PerasVoteCollection blk
newVoteCollection)

-- | Add a vote to an existing target vote state if it isn't already present.
--
-- PRECONDITION: the vote's target must match the underlying vote collection's target.
--
-- May fail if the loser goes above quorum by adding the vote.
updateLoserVoteState ::
  BlockSupportsPeras blk =>
  PerasEpochContext blk ->
  PerasTargetVoteState blk 'Winner ->
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasTargetVoteState blk 'Loser ->
  Either (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
updateLoserVoteState :: forall blk.
BlockSupportsPeras blk =>
PerasEpochContext blk
-> PerasTargetVoteState blk 'Winner
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Loser
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
updateLoserVoteState PerasEpochContext blk
epochContext PerasTargetVoteState blk 'Winner
winnerState WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Loser
oldState =
  Bool
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
IsPerasVote vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote PerasVoteTarget blk -> PerasVoteTarget blk -> Bool
forall a. Eq a => a -> a -> Bool
== PerasVoteCollection blk -> PerasVoteTarget blk
forall blk. PerasVoteCollection blk -> PerasVoteTarget blk
pvcTarget (PerasTargetVoteState blk 'Loser -> PerasVoteCollection blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection PerasTargetVoteState blk 'Loser
oldState)) (Either
   (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
 -> Either
      (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser))
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall a b. (a -> b) -> a -> b
$ do
    let newVoteCollection :: PerasVoteCollection blk
newVoteCollection = WithArrivalTime (ValidatedPerasVote blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
forall blk.
(StandardHash blk, IsPerasVote (PerasVote blk) blk) =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
perasVoteCollectionAddVote WithArrivalTime (ValidatedPerasVote blk)
vote (PerasTargetVoteState blk 'Loser -> PerasVoteCollection blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection PerasTargetVoteState blk 'Loser
oldState)
     in case PerasParams blk
-> PerasVoteCollection blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
forall blk.
PerasParams blk
-> PerasVoteCollection blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
perasVoteCollectionCheckQuorum (PerasEpochContext blk -> PerasParams blk
forall blk. PerasEpochContext blk -> PerasParams blk
pecParams PerasEpochContext blk
epochContext) PerasVoteCollection blk
newVoteCollection of
          Just PerasVoteCollectionWithQuorum blk
_ ->
            UpdateRoundVoteStateError blk
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall a b. a -> Either a b
Left (UpdateRoundVoteStateError blk
 -> Either
      (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser))
-> UpdateRoundVoteStateError blk
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall a b. (a -> b) -> a -> b
$ PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Loser -> UpdateRoundVoteStateError blk
forall blk.
PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Loser -> UpdateRoundVoteStateError blk
RoundVoteStateLoserAboveQuorum PerasTargetVoteState blk 'Winner
winnerState (PerasVoteCollection blk -> PerasTargetVoteState blk 'Loser
forall blk.
PerasVoteCollection blk -> PerasTargetVoteState blk 'Loser
PerasTargetVoteLoser PerasVoteCollection blk
newVoteCollection)
          Maybe (PerasVoteCollectionWithQuorum blk)
Nothing ->
            PerasTargetVoteState blk 'Loser
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall a b. b -> Either a b
Right (PerasTargetVoteState blk 'Loser
 -> Either
      (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser))
-> PerasTargetVoteState blk 'Loser
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall a b. (a -> b) -> a -> b
$ PerasVoteCollection blk -> PerasTargetVoteState blk 'Loser
forall blk.
PerasVoteCollection blk -> PerasTargetVoteState blk 'Loser
PerasTargetVoteLoser PerasVoteCollection blk
newVoteCollection

-- | Add a vote to an existing target vote state if it isn't already present.
--
-- PRECONDITION: the vote's target must match the underlying vote collection's target.
updateWinnerVoteState ::
  ( StandardHash blk
  , IsPerasVote (PerasVote blk) blk
  ) =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasTargetVoteState blk 'Winner ->
  PerasTargetVoteState blk 'Winner
updateWinnerVoteState :: forall blk.
(StandardHash blk, IsPerasVote (PerasVote blk) blk) =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Winner
updateWinnerVoteState WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Winner
oldState =
  Bool
-> PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Winner
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
IsPerasVote vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote PerasVoteTarget blk -> PerasVoteTarget blk -> Bool
forall a. Eq a => a -> a -> Bool
== PerasVoteCollection blk -> PerasVoteTarget blk
forall blk. PerasVoteCollection blk -> PerasVoteTarget blk
pvcTarget (PerasTargetVoteState blk 'Winner -> PerasVoteCollection blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection PerasTargetVoteState blk 'Winner
oldState)) (PerasTargetVoteState blk 'Winner
 -> PerasTargetVoteState blk 'Winner)
-> PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Winner
forall a b. (a -> b) -> a -> b
$ do
    let newVoteCollection :: PerasVoteCollection blk
newVoteCollection = WithArrivalTime (ValidatedPerasVote blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
forall blk.
(StandardHash blk, IsPerasVote (PerasVote blk) blk) =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
perasVoteCollectionAddVote WithArrivalTime (ValidatedPerasVote blk)
vote (PerasTargetVoteState blk 'Winner -> PerasVoteCollection blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteCollection blk
ptvsVoteCollection PerasTargetVoteState blk 'Winner
oldState)
        (PerasTargetVoteWinner PerasVoteCollection blk
_ ValidatedPerasCert blk
cert) = PerasTargetVoteState blk 'Winner
oldState
     in PerasVoteCollection blk
-> ValidatedPerasCert blk -> PerasTargetVoteState blk 'Winner
forall blk.
PerasVoteCollection blk
-> ValidatedPerasCert blk -> PerasTargetVoteState blk 'Winner
PerasTargetVoteWinner PerasVoteCollection blk
newVoteCollection ValidatedPerasCert blk
cert

{-------------------------------------------------------------------------------
  Helpers
-------------------------------------------------------------------------------}

-- | Apply a function to the error part of an Either
onErr :: Either e a -> (e -> e') -> Either e' a
onErr :: forall e a e'. Either e a -> (e -> e') -> Either e' a
onErr (Left e
err) e -> e'
f = e' -> Either e' a
forall a b. a -> Either a b
Left (e -> e'
f e
err)
onErr (Right a
val) e -> e'
_ = a -> Either e' a
forall a b. b -> Either a b
Right a
val