{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Block.SupportsPeras
  ( -- * Voting committee types for Peras
    PerasVotingCommittee
  , PerasVotingCommitteeError
  , PerasVotingCommitteeInput

    -- * Epoch-dependent context for Peras
  , PerasEpochContext (..)

    -- * BlockSupportsPeras class
  , BlockSupportsPeras (..)
  , defaultForgePerasVoteIfEligible
  , defaultVerifyPerasVote
  , defaultForgePerasCert
  , defaultVerifyPerasCert

    -- * Validated types
  , ValidatedPerasVote (..)
  , ValidatedPerasCert (..)

    -- * Peras error types
  , IsPerasError (..)

    -- * Types and functions related to Peras vote collection and quorum checking
  , PerasVoteCollection
    ( pvcTarget
    , pvcVotes
    , pvcTotalWeight
    )
  , perasVoteCollectionSingleton
  , perasVoteCollectionAddVote
  , unsafePerasVoteCollection
  , PerasVoteCollectionWithQuorum
    ( forgetQuorum
    )
  , unsafeAssumeQuorum
  , perasVoteCollectionCheckQuorum
  , toUniqueVotesWithSameTarget

    -- * Helpers
  , weightAboveThreshold

    -- * Convenience re-exports
  , module Ouroboros.Consensus.Peras.Cert.Class
  , module Ouroboros.Consensus.Peras.Params
  , module Ouroboros.Consensus.Peras.Types
  , module Ouroboros.Consensus.Peras.Void
  , module Ouroboros.Consensus.Peras.Vote.Class
  ) where

import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeListLenOf, encodeListLen)
import Control.Exception (assert)
import Control.Exception.Base (Exception)
import Control.Monad.Error.Class (MonadError (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Containers.NonEmpty (HasNonEmpty (..))
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.NonEmpty as NEMap
import Data.Map.Strict (Map)
import Data.Traversable (for)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block.Abstract (Point, StandardHash)
import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..))
import Ouroboros.Consensus.Committee.Class
  ( CryptoSupportsVotingCommittee (..)
  , UniqueVotesWithSameTarget
  , VotingCommittee
  , unsafeUniqueVotesWithSameTarget
  )
import qualified Ouroboros.Consensus.Committee.Class as Committee
import Ouroboros.Consensus.Committee.Crypto (ElectionId, PrivateKey, VoteCandidate)
import Ouroboros.Consensus.Committee.Types (PoolId (..))
import Ouroboros.Consensus.Peras.Cert.Class
import Ouroboros.Consensus.Peras.Params
import Ouroboros.Consensus.Peras.Types
import Ouroboros.Consensus.Peras.Void
import Ouroboros.Consensus.Peras.Vote.Class
import Ouroboros.Consensus.Peras.Voting.Adapter

-- * Voting committee types for Peras

-- | Voting committee for Peras indexed by block type
type PerasVotingCommittee blk =
  VotingCommittee
    (PerasCrypto blk)
    (PerasVotingCommitteeScheme blk)

-- | Error type for Peras voting committee errors
type PerasVotingCommitteeError blk =
  VotingCommitteeError
    (PerasCrypto blk)
    (PerasVotingCommitteeScheme blk)

-- | Input needed to build a Peras voting committee
type PerasVotingCommitteeInput blk =
  VotingCommitteeInput
    (PerasCrypto blk)
    (PerasVotingCommitteeScheme blk)

-- * Epoch-dependent context for Peras

-- | Epoch-dependent context used for forging and validation of objects.
data PerasEpochContext blk
  = PerasEpochContext
  { forall blk. PerasEpochContext blk -> PerasVotingCommittee blk
pecCommittee :: PerasVotingCommittee blk
  , forall blk. PerasEpochContext blk -> PerasParams blk
pecParams :: PerasParams blk
  }

instance
  ( Typeable blk
  , FromCBOR (PerasVotingCommittee blk)
  ) =>
  FromCBOR (PerasEpochContext blk)
  where
  fromCBOR :: forall s. Decoder s (PerasEpochContext blk)
fromCBOR = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
    pecCommittee <- Decoder s (PerasVotingCommittee blk)
forall s. Decoder s (PerasVotingCommittee blk)
forall a s. FromCBOR a => Decoder s a
fromCBOR
    pecParams <- fromCBOR
    pure
      PerasEpochContext
        { pecCommittee
        , pecParams
        }

instance
  ( Typeable blk
  , ToCBOR (PerasVotingCommittee blk)
  ) =>
  ToCBOR (PerasEpochContext blk)
  where
  toCBOR :: PerasEpochContext blk -> Encoding
toCBOR
    PerasEpochContext
      { PerasVotingCommittee blk
pecCommittee :: forall blk. PerasEpochContext blk -> PerasVotingCommittee blk
pecCommittee :: PerasVotingCommittee blk
pecCommittee
      , PerasParams blk
pecParams :: forall blk. PerasEpochContext blk -> PerasParams blk
pecParams :: PerasParams blk
pecParams
      } =
      Word -> Encoding
encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasVotingCommittee blk -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PerasVotingCommittee blk
pecCommittee
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasParams blk -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PerasParams blk
pecParams

deriving instance
  Show (PerasVotingCommittee blk) =>
  Show (PerasEpochContext blk)
deriving instance
  Eq (PerasVotingCommittee blk) =>
  Eq (PerasEpochContext blk)
deriving instance
  NoThunks (PerasVotingCommittee blk) =>
  NoThunks (PerasEpochContext blk)
deriving instance
  Generic (PerasEpochContext blk)

-- * BlockSupportsPeras class

class
  ( -- Basic block constraints
    StandardHash blk
  , Typeable blk
  , -- PerasVote constraints
    Typeable (PerasVote blk)
  , Show (PerasVote blk)
  , Eq (PerasVote blk)
  , NoThunks (PerasVote blk)
  , IsPerasVote (PerasVote blk) blk
  , Typeable (BoostedBlock (PerasVote blk))
  , Show (BoostedBlock (PerasVote blk))
  , Eq (BoostedBlock (PerasVote blk))
  , NoThunks (BoostedBlock (PerasVote blk))
  , -- PerasCert constraints
    Typeable (PerasCert blk)
  , Show (PerasCert blk)
  , Eq (PerasCert blk)
  , NoThunks (PerasCert blk)
  , IsPerasCert (PerasCert blk) blk
  , Typeable (BoostedBlock (PerasCert blk))
  , Show (BoostedBlock (PerasCert blk))
  , Eq (BoostedBlock (PerasCert blk))
  , NoThunks (BoostedBlock (PerasCert blk))
  , -- PerasError constraints
    Typeable (PerasError blk)
  , Show (PerasError blk)
  , Eq (PerasError blk)
  , NoThunks (PerasError blk)
  , IsPerasError (PerasError blk) blk
  , Exception (PerasError blk)
  , -- PerasVotingCommittee constraints
    Typeable (PerasVotingCommittee blk)
  , Show (PerasVotingCommittee blk)
  , Eq (PerasVotingCommittee blk)
  , NoThunks (PerasVotingCommittee blk)
  , -- PerasEpochContext constraints
    Typeable (PerasEpochContext blk)
  , Show (PerasEpochContext blk)
  , Eq (PerasEpochContext blk)
  , NoThunks (PerasEpochContext blk)
  , -- Compatiblity with committee/crypto
    Show (PerasCrypto blk)
  , Eq (PerasCrypto blk)
  , Typeable (PerasCrypto blk)
  , NoThunks (PerasCrypto blk)
  , Show (PerasVotingCommitteeScheme blk)
  , Eq (PerasVotingCommitteeScheme blk)
  , Typeable (PerasVotingCommitteeScheme blk)
  , NoThunks (PerasVotingCommitteeScheme blk)
  , ElectionId (PerasCrypto blk) ~ PerasRoundNo
  , VoteCandidate (PerasCrypto blk) ~ BoostedBlock (PerasVote blk)
  , VoteCandidate (PerasCrypto blk) ~ BoostedBlock (PerasCert blk)
  ) =>
  BlockSupportsPeras blk
  where
  -- | The concrete Peras vote type for this block type.
  type PerasVote blk = (vote :: Type) | vote -> blk

  -- | The concrete Peras certificate type for this block type.
  type PerasCert blk = (cert :: Type) | cert -> blk

  -- | The concrete Peras error type for this block type.
  type PerasError blk = (err :: Type) | err -> blk

  -- | The crypto scheme used for Peras votes and certificates.
  --
  -- Used to dispatch a block type to a its corresponding voting crypto scheme.
  type PerasCrypto blk :: Type

  -- | The voting committee scheme used for Peras.
  --
  -- Used to dispatch a block type to a its corresponding voting committee scheme.
  type PerasVotingCommitteeScheme blk :: Type

  -- | Forge a Peras vote if the given pool is eligible to vote in the given round.
  forgePerasVoteIfEligible ::
    PerasEpochContext blk ->
    PoolId ->
    PrivateKey (PerasCrypto blk) ->
    PerasRoundNo ->
    Point blk ->
    Either (PerasError blk) (Maybe (ValidatedPerasVote blk))

  -- | Verify a Peras vote and return its weight if valid.
  verifyPerasVote ::
    PerasEpochContext blk ->
    PerasVote blk ->
    Either (PerasError blk) (ValidatedPerasVote blk)

  -- | Forge a Peras certificate from a collection of votes reaching quorum.
  forgePerasCert ::
    PerasEpochContext blk ->
    PerasVoteCollectionWithQuorum blk ->
    Either (PerasError blk) (ValidatedPerasCert blk)

  -- | Verify a Peras certificate and return its boost if valid.
  verifyPerasCert ::
    PerasEpochContext blk ->
    PerasCert blk ->
    Either (PerasError blk) (ValidatedPerasCert blk)

  -- | Extract a Peras certificate optionally stored in a block.
  --
  -- Returns 'Nothing' if the block does not contain a Peras certificate, or
  -- if the block is from an era that does not support Peras certificates.
  getPerasCertInBlock ::
    blk ->
    Either (PerasError blk) (Maybe (PerasCert blk))

-- | Forge a Peras vote if the given pool is eligible to vote in the given round.
defaultForgePerasVoteIfEligible ::
  forall blk.
  ( BlockSupportsPeras blk
  , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
  , PerasVoteCompatibleWithVotingCommittee
      (PerasVote blk)
      (PerasCrypto blk)
      (PerasVotingCommitteeScheme blk)
  ) =>
  PerasEpochContext blk ->
  PoolId ->
  PrivateKey (PerasCrypto blk) ->
  PerasRoundNo ->
  Point blk ->
  Either (PerasError blk) (Maybe (ValidatedPerasVote blk))
defaultForgePerasVoteIfEligible :: forall blk.
(BlockSupportsPeras blk,
 CryptoSupportsVotingCommittee
   (PerasCrypto blk) (PerasVotingCommitteeScheme blk),
 PerasVoteCompatibleWithVotingCommittee
   (PerasVote blk)
   (PerasCrypto blk)
   (PerasVotingCommitteeScheme blk)) =>
PerasEpochContext blk
-> PoolId
-> PrivateKey (PerasCrypto blk)
-> PerasRoundNo
-> Point blk
-> Either (PerasError blk) (Maybe (ValidatedPerasVote blk))
defaultForgePerasVoteIfEligible PerasEpochContext blk
context PoolId
ourId PrivateKey (PerasCrypto blk)
ourPrivateKey PerasRoundNo
roundNo Point blk
point = do
  let committee :: PerasVotingCommittee blk
committee = PerasEpochContext blk -> PerasVotingCommittee blk
forall blk. PerasEpochContext blk -> PerasVotingCommittee blk
pecCommittee PerasEpochContext blk
context
  mbWitness <-
    (VotingCommitteeError
   (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
 -> PerasError blk)
-> (Maybe
      (EligibilityWitness
         (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
    -> Maybe
         (EligibilityWitness
            (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
-> Either
     (VotingCommitteeError
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
     (Maybe
        (EligibilityWitness
           (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
-> Either
     (PerasError blk)
     (Maybe
        (EligibilityWitness
           (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap VotingCommitteeError
  (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
-> PerasError blk
forall err blk.
IsPerasError err blk =>
PerasVotingCommitteeError blk -> err
injectVotingCommitteeError Maybe
  (EligibilityWitness
     (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> Maybe
     (EligibilityWitness
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall a. a -> a
id (Either
   (VotingCommitteeError
      (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
   (Maybe
      (EligibilityWitness
         (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
 -> Either
      (PerasError blk)
      (Maybe
         (EligibilityWitness
            (PerasCrypto blk) (PerasVotingCommitteeScheme blk))))
-> Either
     (VotingCommitteeError
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
     (Maybe
        (EligibilityWitness
           (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
-> Either
     (PerasError blk)
     (Maybe
        (EligibilityWitness
           (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
forall a b. (a -> b) -> a -> b
$
      PerasVotingCommittee blk
-> PoolId
-> PrivateKey (PerasCrypto blk)
-> ElectionId (PerasCrypto blk)
-> Either
     (VotingCommitteeError
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
     (Maybe
        (EligibilityWitness
           (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> PoolId
-> PrivateKey crypto
-> ElectionId crypto
-> Either
     (VotingCommitteeError crypto committee)
     (Maybe (EligibilityWitness crypto committee))
Committee.checkShouldVote PerasVotingCommittee blk
committee PoolId
ourId PrivateKey (PerasCrypto blk)
ourPrivateKey ElectionId (PerasCrypto blk)
PerasRoundNo
roundNo
  for mbWitness $ \EligibilityWitness
  (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
witness -> do
    let voteWeight :: VoteWeight
voteWeight = PerasVotingCommittee blk
-> EligibilityWitness
     (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
-> VoteWeight
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> EligibilityWitness crypto committee -> VoteWeight
eligiblePartyVoteWeight PerasVotingCommittee blk
committee EligibilityWitness
  (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
witness
    let boostedBlock :: BoostedBlock (PerasCert blk)
boostedBlock = Point blk -> BoostedBlock (PerasCert blk)
forall boostedBlock blk.
BoostedBlockCompatibleWithPoint boostedBlock blk =>
Point blk -> boostedBlock
pointToBoostedBlock Point blk
point
    let abstractVote :: Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
abstractVote = EligibilityWitness
  (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
-> PrivateKey (PerasCrypto blk)
-> ElectionId (PerasCrypto blk)
-> VoteCandidate (PerasCrypto blk)
-> Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
EligibilityWitness crypto committee
-> PrivateKey crypto
-> ElectionId crypto
-> VoteCandidate crypto
-> Vote crypto committee
Committee.forgeVote EligibilityWitness
  (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
witness PrivateKey (PerasCrypto blk)
ourPrivateKey ElectionId (PerasCrypto blk)
PerasRoundNo
roundNo VoteCandidate (PerasCrypto blk)
BoostedBlock (PerasCert blk)
boostedBlock
    concreteVote <-
      (PerasConversionError -> PerasError blk)
-> (PerasVote blk -> PerasVote blk)
-> Either PerasConversionError (PerasVote blk)
-> Either (PerasError blk) (PerasVote blk)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap PerasConversionError -> PerasError blk
forall err blk. IsPerasError err blk => PerasConversionError -> err
injectConversionError PerasVote blk -> PerasVote blk
forall a. a -> a
id (Either PerasConversionError (PerasVote blk)
 -> Either (PerasError blk) (PerasVote blk))
-> Either PerasConversionError (PerasVote blk)
-> Either (PerasError blk) (PerasVote blk)
forall a b. (a -> b) -> a -> b
$
        forall vote crypto committee.
PerasVoteCompatibleWithVotingCommittee vote crypto committee =>
Vote crypto committee -> Either PerasConversionError vote
toPerasVote @(PerasVote blk) Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
abstractVote
    pure $
      ValidatedPerasVote
        { vpvVote = concreteVote
        , vpvVoteWeight = voteWeight
        }

-- | Verify a Peras vote and return its weight if valid.
defaultVerifyPerasVote ::
  forall blk.
  ( BlockSupportsPeras blk
  , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
  , PerasVoteCompatibleWithVotingCommittee
      (PerasVote blk)
      (PerasCrypto blk)
      (PerasVotingCommitteeScheme blk)
  ) =>
  PerasEpochContext blk ->
  PerasVote blk ->
  Either (PerasError blk) (ValidatedPerasVote blk)
defaultVerifyPerasVote :: forall blk.
(BlockSupportsPeras blk,
 CryptoSupportsVotingCommittee
   (PerasCrypto blk) (PerasVotingCommitteeScheme blk),
 PerasVoteCompatibleWithVotingCommittee
   (PerasVote blk)
   (PerasCrypto blk)
   (PerasVotingCommitteeScheme blk)) =>
PerasEpochContext blk
-> PerasVote blk
-> Either (PerasError blk) (ValidatedPerasVote blk)
defaultVerifyPerasVote PerasEpochContext blk
context PerasVote blk
vote = do
  let committee :: PerasVotingCommittee blk
committee = PerasEpochContext blk -> PerasVotingCommittee blk
forall blk. PerasEpochContext blk -> PerasVotingCommittee blk
pecCommittee PerasEpochContext blk
context
  -- NOTE: checking that the voted point is not from the future w.r.t. the
  -- starting slot of the 'PerasRoundNo' will have to be done at the HFC level
  -- since here we don't have 'PerasRoundNo' -> 'SlotNo' resolution device.
  abstractVote <-
    (PerasConversionError -> PerasError blk)
-> (Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
    -> Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> Either
     PerasConversionError
     (Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> Either
     (PerasError blk)
     (Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap PerasConversionError -> PerasError blk
forall err blk. IsPerasError err blk => PerasConversionError -> err
injectConversionError Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
-> Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
forall a. a -> a
id (Either
   PerasConversionError
   (Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
 -> Either
      (PerasError blk)
      (Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
-> Either
     PerasConversionError
     (Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> Either
     (PerasError blk)
     (Vote (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall a b. (a -> b) -> a -> b
$
      forall vote crypto committee.
PerasVoteCompatibleWithVotingCommittee vote crypto committee =>
vote -> Either PerasConversionError (Vote crypto committee)
fromPerasVote @(PerasVote blk) PerasVote blk
vote
  witness <-
    bimap injectVotingCommitteeError id $
      Committee.verifyVote committee abstractVote
  let voteWeight = PerasVotingCommittee blk
-> EligibilityWitness
     (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
-> VoteWeight
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> EligibilityWitness crypto committee -> VoteWeight
eligiblePartyVoteWeight PerasVotingCommittee blk
committee EligibilityWitness
  (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
witness
  pure
    ValidatedPerasVote
      { vpvVote = vote
      , vpvVoteWeight = voteWeight
      }

-- | Forge a Peras certificate from a collection of votes reaching quorum.
defaultForgePerasCert ::
  forall blk.
  ( BlockSupportsPeras blk
  , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
  , PerasVoteCompatibleWithVotingCommittee
      (PerasVote blk)
      (PerasCrypto blk)
      (PerasVotingCommitteeScheme blk)
  , PerasCertCompatibleWithVotingCommittee
      (PerasCert blk)
      (PerasCrypto blk)
      (PerasVotingCommitteeScheme blk)
  ) =>
  PerasEpochContext blk ->
  PerasVoteCollectionWithQuorum blk ->
  Either (PerasError blk) (ValidatedPerasCert blk)
defaultForgePerasCert :: forall blk.
(BlockSupportsPeras blk,
 CryptoSupportsVotingCommittee
   (PerasCrypto blk) (PerasVotingCommitteeScheme blk),
 PerasVoteCompatibleWithVotingCommittee
   (PerasVote blk) (PerasCrypto blk) (PerasVotingCommitteeScheme blk),
 PerasCertCompatibleWithVotingCommittee
   (PerasCert blk)
   (PerasCrypto blk)
   (PerasVotingCommitteeScheme blk)) =>
PerasEpochContext blk
-> PerasVoteCollectionWithQuorum blk
-> Either (PerasError blk) (ValidatedPerasCert blk)
defaultForgePerasCert PerasEpochContext blk
context PerasVoteCollectionWithQuorum blk
voteCollection = do
  let params :: PerasParams blk
params = PerasEpochContext blk -> PerasParams blk
forall blk. PerasEpochContext blk -> PerasParams blk
pecParams PerasEpochContext blk
context
  abstractVoteCollection <-
    (PerasConversionError -> PerasError blk)
-> (UniqueVotesWithSameTarget
      (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
    -> UniqueVotesWithSameTarget
         (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> Either
     (PerasError blk)
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap PerasConversionError -> PerasError blk
forall err blk. IsPerasError err blk => PerasConversionError -> err
injectConversionError UniqueVotesWithSameTarget
  (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
-> UniqueVotesWithSameTarget
     (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
forall a. a -> a
id (Either
   PerasConversionError
   (UniqueVotesWithSameTarget
      (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
 -> Either
      (PerasError blk)
      (UniqueVotesWithSameTarget
         (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> Either
     (PerasError blk)
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall a b. (a -> b) -> a -> b
$
      PerasVoteCollectionWithQuorum blk
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall vote blk crypto committee.
(vote ~ PerasVote blk, crypto ~ PerasCrypto blk,
 committee ~ PerasVotingCommitteeScheme blk,
 ElectionId crypto ~ PerasRoundNo,
 CryptoSupportsVotingCommittee crypto committee,
 PerasVoteCompatibleWithVotingCommittee vote crypto committee,
 Eq (VoteCandidate crypto)) =>
PerasVoteCollectionWithQuorum blk
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
toUniqueVotesWithSameTarget PerasVoteCollectionWithQuorum blk
voteCollection
  abstractCert <-
    bimap injectVotingCommitteeError id $
      Committee.forgeCert abstractVoteCollection
  concreteCert <-
    bimap injectConversionError id $
      toPerasCert abstractCert
  pure
    ValidatedPerasCert
      { vpcCert = concreteCert
      , vpcCertBoost = perasWeight params
      }

-- | Verify a Peras certificate and return its boost if valid.
defaultVerifyPerasCert ::
  forall blk.
  ( BlockSupportsPeras blk
  , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
  , PerasCertCompatibleWithVotingCommittee
      (PerasCert blk)
      (PerasCrypto blk)
      (PerasVotingCommitteeScheme blk)
  ) =>
  PerasEpochContext blk ->
  PerasCert blk ->
  Either (PerasError blk) (ValidatedPerasCert blk)
defaultVerifyPerasCert :: forall blk.
(BlockSupportsPeras blk,
 CryptoSupportsVotingCommittee
   (PerasCrypto blk) (PerasVotingCommitteeScheme blk),
 PerasCertCompatibleWithVotingCommittee
   (PerasCert blk)
   (PerasCrypto blk)
   (PerasVotingCommitteeScheme blk)) =>
PerasEpochContext blk
-> PerasCert blk
-> Either (PerasError blk) (ValidatedPerasCert blk)
defaultVerifyPerasCert PerasEpochContext blk
context PerasCert blk
cert = do
  let committee :: PerasVotingCommittee blk
committee = PerasEpochContext blk -> PerasVotingCommittee blk
forall blk. PerasEpochContext blk -> PerasVotingCommittee blk
pecCommittee PerasEpochContext blk
context
  let params :: PerasParams blk
params = PerasEpochContext blk -> PerasParams blk
forall blk. PerasEpochContext blk -> PerasParams blk
pecParams PerasEpochContext blk
context
  -- NOTE: checking that the voted point is not from the future w.r.t. the
  -- starting slot of the 'PerasRoundNo' will have to be done at the HFC level
  -- since here we don't have 'PerasRoundNo' -> 'SlotNo' resolution device.
  abstractCert <-
    (PerasConversionError -> PerasError blk)
-> (Cert (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
    -> Cert (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> Either
     PerasConversionError
     (Cert (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> Either
     (PerasError blk)
     (Cert (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap PerasConversionError -> PerasError blk
forall err blk. IsPerasError err blk => PerasConversionError -> err
injectConversionError Cert (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
-> Cert (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
forall a. a -> a
id (Either
   PerasConversionError
   (Cert (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
 -> Either
      (PerasError blk)
      (Cert (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
-> Either
     PerasConversionError
     (Cert (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> Either
     (PerasError blk)
     (Cert (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall a b. (a -> b) -> a -> b
$
      forall cert crypto committee.
PerasCertCompatibleWithVotingCommittee cert crypto committee =>
cert -> Either PerasConversionError (Cert crypto committee)
fromPerasCert @(PerasCert blk) PerasCert blk
cert
  witnesses <-
    bimap injectVotingCommitteeError id $
      Committee.verifyCert committee abstractCert
  let totalVoteWeight = NonEmpty VoteWeight -> VoteWeight
forall a. Num a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (PerasVotingCommittee blk
-> EligibilityWitness
     (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
-> VoteWeight
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> EligibilityWitness crypto committee -> VoteWeight
eligiblePartyVoteWeight PerasVotingCommittee blk
committee (EligibilityWitness
   (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
 -> VoteWeight)
-> NonEmpty
     (EligibilityWitness
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
-> NonEmpty VoteWeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty
  (EligibilityWitness
     (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
witnesses)
  if weightAboveThreshold params totalVoteWeight
    then
      pure
        ValidatedPerasCert
          { vpcCert = cert
          , vpcCertBoost = perasWeight params
          }
    else
      throwError (injectQuorumNotReachedError totalVoteWeight)

-- * Validated types

data ValidatedPerasVote blk
  = ValidatedPerasVote
  { forall blk. ValidatedPerasVote blk -> PerasVote blk
vpvVote :: !(PerasVote blk)
  , forall blk. ValidatedPerasVote blk -> VoteWeight
vpvVoteWeight :: !VoteWeight
  }

deriving instance Show (PerasVote blk) => Show (ValidatedPerasVote blk)
deriving instance Eq (PerasVote blk) => Eq (ValidatedPerasVote blk)
deriving instance Ord (PerasVote blk) => Ord (ValidatedPerasVote blk)
deriving instance NoThunks (PerasVote blk) => NoThunks (ValidatedPerasVote blk)
deriving instance Generic (ValidatedPerasVote blk)

data ValidatedPerasCert blk
  = ValidatedPerasCert
  { forall blk. ValidatedPerasCert blk -> PerasCert blk
vpcCert :: !(PerasCert blk)
  , forall blk. ValidatedPerasCert blk -> PerasWeight
vpcCertBoost :: !PerasWeight
  }

type instance BoostedBlock (ValidatedPerasVote blk) = BoostedBlock (PerasVote blk)

instance
  ( IsPerasVote (PerasVote blk) blk
  , BoostedBlockCompatibleWithPoint (BoostedBlock (PerasVote blk)) blk
  ) =>
  IsPerasVote (ValidatedPerasVote blk) blk
  where
  getPerasVoteRound :: ValidatedPerasVote blk -> PerasRoundNo
getPerasVoteRound = PerasVote blk -> PerasRoundNo
forall vote blk. IsPerasVote vote blk => vote -> PerasRoundNo
getPerasVoteRound (PerasVote blk -> PerasRoundNo)
-> (ValidatedPerasVote blk -> PerasVote blk)
-> ValidatedPerasVote blk
-> PerasRoundNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasVote blk -> PerasVote blk
forall blk. ValidatedPerasVote blk -> PerasVote blk
vpvVote
  getPerasVoteBlock :: ValidatedPerasVote blk -> BoostedBlock (ValidatedPerasVote blk)
getPerasVoteBlock = PerasVote blk -> BoostedBlock (PerasVote blk)
forall vote blk. IsPerasVote vote blk => vote -> BoostedBlock vote
getPerasVoteBlock (PerasVote blk -> BoostedBlock (PerasVote blk))
-> (ValidatedPerasVote blk -> PerasVote blk)
-> ValidatedPerasVote blk
-> BoostedBlock (PerasVote blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasVote blk -> PerasVote blk
forall blk. ValidatedPerasVote blk -> PerasVote blk
vpvVote
  getPerasVoteSeatIndex :: ValidatedPerasVote blk -> PerasSeatIndex
getPerasVoteSeatIndex = PerasVote blk -> PerasSeatIndex
forall vote blk. IsPerasVote vote blk => vote -> PerasSeatIndex
getPerasVoteSeatIndex (PerasVote blk -> PerasSeatIndex)
-> (ValidatedPerasVote blk -> PerasVote blk)
-> ValidatedPerasVote blk
-> PerasSeatIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasVote blk -> PerasVote blk
forall blk. ValidatedPerasVote blk -> PerasVote blk
vpvVote

deriving instance Show (PerasCert blk) => Show (ValidatedPerasCert blk)
deriving instance Eq (PerasCert blk) => Eq (ValidatedPerasCert blk)
deriving instance Ord (PerasCert blk) => Ord (ValidatedPerasCert blk)
deriving instance NoThunks (PerasCert blk) => NoThunks (ValidatedPerasCert blk)
deriving instance Generic (ValidatedPerasCert blk)

type instance BoostedBlock (ValidatedPerasCert blk) = BoostedBlock (PerasCert blk)

instance
  ( IsPerasCert (PerasCert blk) blk
  , BoostedBlockCompatibleWithPoint (BoostedBlock (PerasCert blk)) blk
  ) =>
  IsPerasCert (ValidatedPerasCert blk) blk
  where
  getPerasCertRound :: ValidatedPerasCert blk -> PerasRoundNo
getPerasCertRound = PerasCert blk -> PerasRoundNo
forall cert blk. IsPerasCert cert blk => cert -> PerasRoundNo
getPerasCertRound (PerasCert blk -> PerasRoundNo)
-> (ValidatedPerasCert blk -> PerasCert blk)
-> ValidatedPerasCert blk
-> PerasRoundNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasCert blk -> PerasCert blk
forall blk. ValidatedPerasCert blk -> PerasCert blk
vpcCert
  getPerasCertBlock :: ValidatedPerasCert blk -> BoostedBlock (ValidatedPerasCert blk)
getPerasCertBlock = PerasCert blk -> BoostedBlock (PerasCert blk)
forall cert blk. IsPerasCert cert blk => cert -> BoostedBlock cert
getPerasCertBlock (PerasCert blk -> BoostedBlock (PerasCert blk))
-> (ValidatedPerasCert blk -> PerasCert blk)
-> ValidatedPerasCert blk
-> BoostedBlock (PerasCert blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasCert blk -> PerasCert blk
forall blk. ValidatedPerasCert blk -> PerasCert blk
vpcCert

-- * Peras error types

-- | Error types that support injecting certain types of Peras errors
class IsPerasError err blk | err -> blk where
  injectVotingCommitteeError :: PerasVotingCommitteeError blk -> err
  injectConversionError :: PerasConversionError -> err
  injectQuorumNotReachedError :: VoteWeight -> err

instance IsPerasError (VoidPerasError blk) blk where
  injectVotingCommitteeError :: PerasVotingCommitteeError blk -> VoidPerasError blk
injectVotingCommitteeError PerasVotingCommitteeError blk
_ =
    String -> VoidPerasError blk
forall a. HasCallStack => String -> a
error String
"injectVotingCommitteeError: VoidPerasError cannot be inhabited"
  injectConversionError :: PerasConversionError -> VoidPerasError blk
injectConversionError PerasConversionError
_ =
    String -> VoidPerasError blk
forall a. HasCallStack => String -> a
error String
"injectConversionError: VoidPerasError cannot be inhabited"
  injectQuorumNotReachedError :: VoteWeight -> VoidPerasError blk
injectQuorumNotReachedError VoteWeight
_ =
    String -> VoidPerasError blk
forall a. HasCallStack => String -> a
error String
"injectQuorumNotReachedError: VoidPerasError cannot be inhabited"

-- * Types and functions related to Peras vote collection and quorum checking

-- | Collection of Peras votes for a given target.
--
-- NOTE: votes in this collection are uniquely identified by their vote ID.
data PerasVoteCollection blk
  = PerasVoteCollection
  { forall blk. PerasVoteCollection blk -> PerasVoteTarget blk
pvcTarget :: !(PerasVoteTarget blk)
  -- ^ The target of the votes in this collection
  , forall blk.
PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes :: !(NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))))
  -- ^ Votes received for this target, indexed by vote ID
  , forall blk. PerasVoteCollection blk -> VoteWeight
pvcTotalWeight :: !VoteWeight
  -- ^ Total weight of the votes received for this target
  }

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

-- | Construct a 'PerasVoteCollection' with a single vote.
perasVoteCollectionSingleton ::
  IsPerasVote (PerasVote blk) blk =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasVoteCollection blk
perasVoteCollectionSingleton :: forall blk.
IsPerasVote (PerasVote blk) blk =>
WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteCollection blk
perasVoteCollectionSingleton WithArrivalTime (ValidatedPerasVote blk)
vote =
  PerasVoteCollection
    { pvcTarget :: PerasVoteTarget blk
pvcTarget = WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
IsPerasVote vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote
    , pvcVotes :: NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes = PerasVoteId
-> WithArrivalTime (ValidatedPerasVote blk)
-> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
forall k a. k -> a -> NEMap k a
NEMap.singleton (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteId
forall vote blk. IsPerasVote vote blk => vote -> PerasVoteId
getPerasVoteId WithArrivalTime (ValidatedPerasVote blk)
vote) WithArrivalTime (ValidatedPerasVote blk)
vote
    , pvcTotalWeight :: VoteWeight
pvcTotalWeight = ValidatedPerasVote blk -> VoteWeight
forall blk. ValidatedPerasVote blk -> VoteWeight
vpvVoteWeight (WithArrivalTime (ValidatedPerasVote blk) -> ValidatedPerasVote blk
forall a. WithArrivalTime a -> a
forgetArrivalTime WithArrivalTime (ValidatedPerasVote blk)
vote)
    }

-- | Add a vote to an existing vote collection if it isn't already present, and
-- update the total weight accordingly.
--
-- PRECONDITION: the vote's target must match the collection's target.
perasVoteCollectionAddVote ::
  ( StandardHash blk
  , IsPerasVote (PerasVote blk) blk
  ) =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasVoteCollection blk ->
  PerasVoteCollection blk
perasVoteCollectionAddVote :: forall blk.
(StandardHash blk, IsPerasVote (PerasVote blk) blk) =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
perasVoteCollectionAddVote WithArrivalTime (ValidatedPerasVote blk)
vote PerasVoteCollection blk
pvc =
  Bool -> PerasVoteCollection blk -> PerasVoteCollection blk
forall a. HasCallStack => 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 PerasVoteCollection blk
pvc) (PerasVoteCollection blk -> PerasVoteCollection blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
forall a b. (a -> b) -> a -> b
$
    PerasVoteCollection blk
pvc
      { pvcVotes = pvcVotes'
      , pvcTotalWeight = pvcTotalWeight'
      }
 where
  swapVote :: WithArrivalTime (ValidatedPerasVote blk)
-> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> (Maybe (WithArrivalTime (ValidatedPerasVote blk)),
    NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
swapVote =
    (PerasVoteId
 -> WithArrivalTime (ValidatedPerasVote blk)
 -> WithArrivalTime (ValidatedPerasVote blk)
 -> WithArrivalTime (ValidatedPerasVote blk))
-> PerasVoteId
-> WithArrivalTime (ValidatedPerasVote blk)
-> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> (Maybe (WithArrivalTime (ValidatedPerasVote blk)),
    NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> NEMap k a -> (Maybe a, NEMap k a)
NEMap.insertLookupWithKey
      (\PerasVoteId
_k WithArrivalTime (ValidatedPerasVote blk)
old WithArrivalTime (ValidatedPerasVote blk)
_new -> WithArrivalTime (ValidatedPerasVote blk)
old)
      (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteId
forall vote blk. IsPerasVote vote blk => vote -> PerasVoteId
getPerasVoteId WithArrivalTime (ValidatedPerasVote blk)
vote)

  (NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
pvcVotes', VoteWeight
pvcTotalWeight')
    -- key WAS NOT present → vote inserted and weight updated
    | (Maybe (WithArrivalTime (ValidatedPerasVote blk))
Nothing, NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
votes') <- WithArrivalTime (ValidatedPerasVote blk)
-> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> (Maybe (WithArrivalTime (ValidatedPerasVote blk)),
    NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
swapVote WithArrivalTime (ValidatedPerasVote blk)
vote (PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
forall blk.
PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes PerasVoteCollection blk
pvc) =
        ( NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
votes'
        , PerasVoteCollection blk -> VoteWeight
forall blk. PerasVoteCollection blk -> VoteWeight
pvcTotalWeight PerasVoteCollection blk
pvc VoteWeight -> VoteWeight -> VoteWeight
forall a. Num a => a -> a -> a
+ ValidatedPerasVote blk -> VoteWeight
forall blk. ValidatedPerasVote blk -> VoteWeight
vpvVoteWeight (WithArrivalTime (ValidatedPerasVote blk) -> ValidatedPerasVote blk
forall a. WithArrivalTime a -> a
forgetArrivalTime WithArrivalTime (ValidatedPerasVote blk)
vote)
        )
    -- key WAS already present → votes and weight unchanged
    | Bool
otherwise =
        ( PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
forall blk.
PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes PerasVoteCollection blk
pvc
        , PerasVoteCollection blk -> VoteWeight
forall blk. PerasVoteCollection blk -> VoteWeight
pvcTotalWeight PerasVoteCollection blk
pvc
        )

-- | Unsafe constructor for 'PerasVoteCollection'.
--
-- The only recorded use at the moment is in the HFC implementation, to turn an
-- existing 'PerasVoteCollection' for the HardForkBlock into a
-- 'PerasVoteCollection' of a concrete era.
unsafePerasVoteCollection ::
  ( IsPerasVote (PerasVote blk) blk
  , StandardHash blk
  ) =>
  (NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))) ->
  PerasVoteCollection blk
unsafePerasVoteCollection :: forall blk.
(IsPerasVote (PerasVote blk) blk, StandardHash blk) =>
NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
-> PerasVoteCollection blk
unsafePerasVoteCollection NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
votes =
  -- NOTE: no need to check for ID uniqueness since the votes are stored in a
  -- map keyed by vote ID.
  Bool -> PerasVoteCollection blk -> PerasVoteCollection blk
forall a. HasCallStack => Bool -> a -> a
assert
    ( (WithArrivalTime (ValidatedPerasVote blk) -> Bool)
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
        (\WithArrivalTime (ValidatedPerasVote blk)
vote -> 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
== PerasVoteTarget blk
firstVoteTarget)
        (NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
forall k a. NEMap k a -> NonEmpty a
NEMap.elems NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
votes)
    )
    (PerasVoteCollection blk -> PerasVoteCollection blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
forall a b. (a -> b) -> a -> b
$ PerasVoteCollection
      { pvcTarget :: PerasVoteTarget blk
pvcTarget = PerasVoteTarget blk
firstVoteTarget
      , pvcVotes :: NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes = NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
votes
      , pvcTotalWeight :: VoteWeight
pvcTotalWeight = VoteWeight
totalWeight
      }
 where
  ((PerasVoteId
_, WithArrivalTime (ValidatedPerasVote blk)
firstVote) :| [(PerasVoteId, WithArrivalTime (ValidatedPerasVote blk))]
_) = NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty (PerasVoteId, WithArrivalTime (ValidatedPerasVote blk))
forall k a. NEMap k a -> NonEmpty (k, a)
NEMap.toList NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
votes
  firstVoteTarget :: PerasVoteTarget blk
firstVoteTarget = WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
IsPerasVote vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
firstVote
  totalWeight :: VoteWeight
totalWeight = NonEmpty VoteWeight -> VoteWeight
forall a. Num a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (ValidatedPerasVote blk -> VoteWeight
forall blk. ValidatedPerasVote blk -> VoteWeight
vpvVoteWeight (ValidatedPerasVote blk -> VoteWeight)
-> (WithArrivalTime (ValidatedPerasVote blk)
    -> ValidatedPerasVote blk)
-> WithArrivalTime (ValidatedPerasVote blk)
-> VoteWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithArrivalTime (ValidatedPerasVote blk) -> ValidatedPerasVote blk
forall a. WithArrivalTime a -> a
forgetArrivalTime (WithArrivalTime (ValidatedPerasVote blk) -> VoteWeight)
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty VoteWeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
forall k a. NEMap k a -> NonEmpty a
NEMap.elems NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
votes)

-- | A collection of Peras votes for a given target that has reached quorum
newtype PerasVoteCollectionWithQuorum blk
  = PerasVoteCollectionWithQuorum
  { forall blk.
PerasVoteCollectionWithQuorum blk -> PerasVoteCollection blk
forgetQuorum :: PerasVoteCollection blk
  }

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

-- | Transforms a 'PerasVoteCollection' into a 'PerasVoteCollectionWithQuorum'
-- without actually checking the quorum condition.
--
-- NOTE: the only recorded use at the moment is in the HFC implementation, to
-- turn an existing 'PerasVoteCollectionWithQuorum' for the HardForkBlock into
-- a 'PerasVoteCollectionWithQuorum' of a concrete era.
unsafeAssumeQuorum ::
  PerasVoteCollection blk ->
  PerasVoteCollectionWithQuorum blk
unsafeAssumeQuorum :: forall blk.
PerasVoteCollection blk -> PerasVoteCollectionWithQuorum blk
unsafeAssumeQuorum =
  PerasVoteCollection blk -> PerasVoteCollectionWithQuorum blk
forall blk.
PerasVoteCollection blk -> PerasVoteCollectionWithQuorum blk
PerasVoteCollectionWithQuorum

-- | Smart constructor for 'PerasVoteCollectionWithQuorum'
perasVoteCollectionCheckQuorum ::
  PerasParams blk ->
  PerasVoteCollection blk ->
  Maybe (PerasVoteCollectionWithQuorum blk)
perasVoteCollectionCheckQuorum :: forall blk.
PerasParams blk
-> PerasVoteCollection blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
perasVoteCollectionCheckQuorum PerasParams blk
params PerasVoteCollection blk
pvc =
  case PerasParams blk -> VoteWeight -> Bool
forall blk. PerasParams blk -> VoteWeight -> Bool
weightAboveThreshold PerasParams blk
params (PerasVoteCollection blk -> VoteWeight
forall blk. PerasVoteCollection blk -> VoteWeight
pvcTotalWeight PerasVoteCollection blk
pvc) of
    Bool
True -> PerasVoteCollectionWithQuorum blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
forall a. a -> Maybe a
Just (PerasVoteCollection blk -> PerasVoteCollectionWithQuorum blk
forall blk.
PerasVoteCollection blk -> PerasVoteCollectionWithQuorum blk
PerasVoteCollectionWithQuorum PerasVoteCollection blk
pvc)
    Bool
False -> Maybe (PerasVoteCollectionWithQuorum blk)
forall a. Maybe a
Nothing

-- | Convert a collection of Peras votes that has reached quorum into the
-- corresponding abstract representation of votes used by the voting committee
-- to forge certificates.
--
-- 'UniqueVotesWithSameTarget' and 'PerasVoteCollection' enforce the same
-- invariants, which are:
-- - The collection is not empty
-- - All votes have the same target
-- - All votes have a unique vote ID (or unique seat index, which is equivalent
--   assuming they also have the same target, see second point)
-- In addition to that, 'PerasVoteCollectionWithQuorum' guarantees that the
-- total weight of the votes is above the threshold.
toUniqueVotesWithSameTarget ::
  ( vote ~ PerasVote blk
  , crypto ~ PerasCrypto blk
  , committee ~ PerasVotingCommitteeScheme blk
  , ElectionId crypto ~ PerasRoundNo
  , CryptoSupportsVotingCommittee crypto committee
  , PerasVoteCompatibleWithVotingCommittee vote crypto committee
  , Eq (VoteCandidate crypto)
  ) =>
  PerasVoteCollectionWithQuorum blk ->
  Either
    PerasConversionError
    (UniqueVotesWithSameTarget (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
toUniqueVotesWithSameTarget :: forall vote blk crypto committee.
(vote ~ PerasVote blk, crypto ~ PerasCrypto blk,
 committee ~ PerasVotingCommitteeScheme blk,
 ElectionId crypto ~ PerasRoundNo,
 CryptoSupportsVotingCommittee crypto committee,
 PerasVoteCompatibleWithVotingCommittee vote crypto committee,
 Eq (VoteCandidate crypto)) =>
PerasVoteCollectionWithQuorum blk
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
toUniqueVotesWithSameTarget (PerasVoteCollectionWithQuorum PerasVoteCollection blk
pvc) = do
  (NonEmpty (Vote crypto committee)
 -> UniqueVotesWithSameTarget crypto committee)
-> Either PerasConversionError (NonEmpty (Vote crypto committee))
-> Either
     PerasConversionError (UniqueVotesWithSameTarget crypto committee)
forall a b.
(a -> b)
-> Either PerasConversionError a -> Either PerasConversionError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Vote crypto committee)
-> UniqueVotesWithSameTarget crypto committee
NE [Vote crypto committee]
-> UniqueVotesWithSameTarget crypto committee
forall crypto committee.
(CryptoSupportsVotingCommittee crypto committee,
 Eq (ElectionId crypto), Eq (VoteCandidate crypto)) =>
NE [Vote crypto committee]
-> UniqueVotesWithSameTarget crypto committee
unsafeUniqueVotesWithSameTarget -- Skip redundant checks in production
    (Either PerasConversionError (NonEmpty (Vote crypto committee))
 -> Either
      PerasConversionError
      (UniqueVotesWithSameTarget
         (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
-> (PerasVoteCollection blk
    -> Either PerasConversionError (NonEmpty (Vote crypto committee)))
-> PerasVoteCollection blk
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PerasVote blk
 -> Either PerasConversionError (Vote crypto committee))
-> NonEmpty (PerasVote blk)
-> Either PerasConversionError (NonEmpty (Vote crypto committee))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse PerasVote blk
-> Either PerasConversionError (Vote crypto committee)
forall vote crypto committee.
PerasVoteCompatibleWithVotingCommittee vote crypto committee =>
vote -> Either PerasConversionError (Vote crypto committee)
fromPerasVote
    (NonEmpty (PerasVote blk)
 -> Either PerasConversionError (NonEmpty (Vote crypto committee)))
-> (PerasVoteCollection blk -> NonEmpty (PerasVote blk))
-> PerasVoteCollection blk
-> Either PerasConversionError (NonEmpty (Vote crypto committee))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithArrivalTime (ValidatedPerasVote blk) -> PerasVote blk)
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty (PerasVote blk)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValidatedPerasVote blk -> PerasVote blk
forall blk. ValidatedPerasVote blk -> PerasVote blk
vpvVote (ValidatedPerasVote blk -> PerasVote blk)
-> (WithArrivalTime (ValidatedPerasVote blk)
    -> ValidatedPerasVote blk)
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasVote blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithArrivalTime (ValidatedPerasVote blk) -> ValidatedPerasVote blk
forall a. WithArrivalTime a -> a
forgetArrivalTime)
    (NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
 -> NonEmpty (PerasVote blk))
-> (PerasVoteCollection blk
    -> NonEmpty (WithArrivalTime (ValidatedPerasVote blk)))
-> PerasVoteCollection blk
-> NonEmpty (PerasVote blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
forall k a. NEMap k a -> NonEmpty a
NEMap.elems
    (NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
 -> NonEmpty (WithArrivalTime (ValidatedPerasVote blk)))
-> (PerasVoteCollection blk
    -> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
-> PerasVoteCollection blk
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasVoteCollection blk
-> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
forall blk.
PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes
    (PerasVoteCollection blk
 -> Either
      PerasConversionError
      (UniqueVotesWithSameTarget
         (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
-> PerasVoteCollection blk
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall a b. (a -> b) -> a -> b
$ PerasVoteCollection blk
pvc

-- * Helpers

-- | Check whether a given vote weight is above the quorum threshold.
--
-- NOTE: this function assumes that the 'VoteWeight' and the quorum
-- threshold used in 'PerasParams' are expressed in the same units. That is,
-- both are either absolute or relative (normalized) values. Under the current
-- current implementation of 'PerasParams', this function only makes sense when
-- both values are relative (normalized) values.
weightAboveThreshold :: PerasParams blk -> VoteWeight -> Bool
weightAboveThreshold :: forall blk. PerasParams blk -> VoteWeight -> Bool
weightAboveThreshold PerasParams blk
params VoteWeight
voteWeight =
  Ratio Integer
weight Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Ratio Integer
quorumThreshold Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
+ Ratio Integer
safetyMargin
 where
  weight :: Ratio Integer
weight =
    VoteWeight -> Ratio Integer
unVoteWeight VoteWeight
voteWeight
  quorumThreshold :: Ratio Integer
quorumThreshold =
    PerasQuorumWeightThreshold -> Ratio Integer
unPerasQuorumWeightThreshold
      (PerasParams blk -> PerasQuorumWeightThreshold
forall blk. PerasParams blk -> PerasQuorumWeightThreshold
perasQuorumWeightThreshold PerasParams blk
params)
  safetyMargin :: Ratio Integer
safetyMargin =
    PerasQuorumWeightThresholdSafetyMargin -> Ratio Integer
unPerasQuorumWeightThresholdSafetyMargin
      (PerasParams blk -> PerasQuorumWeightThresholdSafetyMargin
forall blk.
PerasParams blk -> PerasQuorumWeightThresholdSafetyMargin
perasQuorumWeightThresholdSafetyMargin PerasParams blk
params)