{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Ouroboros.Storage.PerasVoteDB.Model
  ( PerasVoteDbModelError (..)
  , VoteEntry (..)
  , Model (..)
  , initModel
  , openDB
  , closeDB
  , addVote
  , getVoteIds
  , getVotesAfter
  , getForgedCertForRound
  , garbageCollect
  ) where

import Control.Exception (assert)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Set.NonEmpty as NESet
import Data.TreeDiff (ToExpr (..), defaultExprViaShow)
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block (SlotNo, WithOrigin (..), pointSlot)
import Ouroboros.Consensus.Block.Abstract (StandardHash)
import Ouroboros.Consensus.Block.SupportsPeras
  ( BlockSupportsPeras (..)
  , IsPerasCert (..)
  , IsPerasVote (..)
  , PerasParams
  , PerasRoundNo
  , PerasSeatIndex
  , PerasVoteId (..)
  , PerasVoteTarget (..)
  , ValidatedPerasCert (..)
  , ValidatedPerasVote (..)
  , VoteWeight (..)
  , getPerasCertPoint
  , perasWeight
  , weightAboveThreshold
  )
import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..))
import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..))
import Ouroboros.Consensus.Storage.PerasVoteDB.API
  ( AddPerasVoteResult (..)
  , PerasVoteTicketNo
  , zeroPerasVoteTicketNo
  )

data VoteEntry blk = VoteEntry
  { forall blk. VoteEntry blk -> PerasVoteTicketNo
veTicketNo :: PerasVoteTicketNo
  -- ^ The ticket number assigned to this vote
  , forall blk. VoteEntry blk -> PerasSeatIndex
veVoter :: PerasSeatIndex
  -- ^ The seat index of the voter
  , forall blk.
VoteEntry blk -> WithArrivalTime (ValidatedPerasVote blk)
veVote :: WithArrivalTime (ValidatedPerasVote blk)
  -- ^ The vote itself
  }

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

data PerasVoteDbModelError = MultipleWinnersInRound PerasRoundNo
  deriving (Int -> PerasVoteDbModelError -> ShowS
[PerasVoteDbModelError] -> ShowS
PerasVoteDbModelError -> String
(Int -> PerasVoteDbModelError -> ShowS)
-> (PerasVoteDbModelError -> String)
-> ([PerasVoteDbModelError] -> ShowS)
-> Show PerasVoteDbModelError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PerasVoteDbModelError -> ShowS
showsPrec :: Int -> PerasVoteDbModelError -> ShowS
$cshow :: PerasVoteDbModelError -> String
show :: PerasVoteDbModelError -> String
$cshowList :: [PerasVoteDbModelError] -> ShowS
showList :: [PerasVoteDbModelError] -> ShowS
Show, (forall x. PerasVoteDbModelError -> Rep PerasVoteDbModelError x)
-> (forall x. Rep PerasVoteDbModelError x -> PerasVoteDbModelError)
-> Generic PerasVoteDbModelError
forall x. Rep PerasVoteDbModelError x -> PerasVoteDbModelError
forall x. PerasVoteDbModelError -> Rep PerasVoteDbModelError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PerasVoteDbModelError -> Rep PerasVoteDbModelError x
from :: forall x. PerasVoteDbModelError -> Rep PerasVoteDbModelError x
$cto :: forall x. Rep PerasVoteDbModelError x -> PerasVoteDbModelError
to :: forall x. Rep PerasVoteDbModelError x -> PerasVoteDbModelError
Generic)

data Model blk = Model
  { forall blk. Model blk -> Bool
open :: Bool
  -- ^ Is the database open?
  , forall blk. Model blk -> PerasParams blk
params :: PerasParams blk
  -- ^ Configuration parameters
  , forall blk. Model blk -> PerasVoteTicketNo
lastTicketNo :: PerasVoteTicketNo
  -- ^ The last issued ticket number
  , forall blk.
Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
votes :: Map (PerasVoteTarget blk) (Set (VoteEntry blk))
  -- ^ Collection of votes indexed by target (round number, boosted block)
  , forall blk. Model blk -> Map PerasRoundNo (ValidatedPerasCert blk)
certs :: Map PerasRoundNo (ValidatedPerasCert blk)
  -- ^ Forged certificates indexed by round number
  }

-- deriving (Show, Generic)

deriving instance
  ( StandardHash blk
  , Show (PerasVote blk)
  , Show (PerasCert blk)
  ) =>
  Show (Model blk)
deriving instance Generic (Model blk)

instance
  ( StandardHash blk
  , Show (PerasVote blk)
  , Show (PerasCert blk)
  ) =>
  ToExpr (Model blk)
  where
  toExpr :: Model blk -> Expr
toExpr = Model blk -> Expr
forall a. Show a => a -> Expr
defaultExprViaShow

initModel :: PerasParams blk -> Model blk
initModel :: forall blk. PerasParams blk -> Model blk
initModel PerasParams blk
perasParams =
  Model
    { open :: Bool
open = Bool
False
    , params :: PerasParams blk
params = PerasParams blk
perasParams
    , lastTicketNo :: PerasVoteTicketNo
lastTicketNo = PerasVoteTicketNo
zeroPerasVoteTicketNo
    , votes :: Map (PerasVoteTarget blk) (Set (VoteEntry blk))
votes = Map (PerasVoteTarget blk) (Set (VoteEntry blk))
forall k a. Map k a
Map.empty
    , certs :: Map PerasRoundNo (ValidatedPerasCert blk)
certs = Map PerasRoundNo (ValidatedPerasCert blk)
forall k a. Map k a
Map.empty
    }

-- | Check whether a given voter has already voted in a given round
--
-- NOTE: while this is an innefficient traversal, it allows the model to be as
-- trivial as possible. The actual PerasVoteDB implementation uses a separate
-- collection to track this information efficienty, at the cost of added
-- complexity.
hasVote ::
  PerasVoteId ->
  Model blk ->
  Bool
hasVote :: forall blk. PerasVoteId -> Model blk -> Bool
hasVote PerasVoteId
voteId Model blk
model =
  PerasVoteId -> Set PerasVoteId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PerasVoteId
voteId Set PerasVoteId
voteIds
 where
  voteIds :: Set PerasVoteId
voteIds =
    [Set PerasVoteId] -> Set PerasVoteId
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set PerasVoteId] -> Set PerasVoteId)
-> [Set PerasVoteId] -> Set PerasVoteId
forall a b. (a -> b) -> a -> b
$
      [ (VoteEntry blk -> PerasVoteId)
-> Set (VoteEntry blk) -> Set PerasVoteId
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map
          ( \VoteEntry blk
ve ->
              PerasVoteId
                { pviRoundNo :: PerasRoundNo
pviRoundNo = PerasVoteTarget blk -> PerasRoundNo
forall blk. PerasVoteTarget blk -> PerasRoundNo
pvtRoundNo PerasVoteTarget blk
voteTarget
                , pviSeatIndex :: PerasSeatIndex
pviSeatIndex = VoteEntry blk -> PerasSeatIndex
forall blk. VoteEntry blk -> PerasSeatIndex
veVoter VoteEntry blk
ve
                }
          )
          Set (VoteEntry blk)
votesForTarget
      | (PerasVoteTarget blk
voteTarget, Set (VoteEntry blk)
votesForTarget) <- Map (PerasVoteTarget blk) (Set (VoteEntry blk))
-> [(PerasVoteTarget blk, Set (VoteEntry blk))]
forall k a. Map k a -> [(k, a)]
Map.toList (Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
forall blk.
Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
votes Model blk
model)
      ]

openDB ::
  Model blk ->
  Model blk
openDB :: forall blk. Model blk -> Model blk
openDB Model blk
model =
  Model blk
model
    { open = True
    }

closeDB ::
  Model blk ->
  Model blk
closeDB :: forall blk. Model blk -> Model blk
closeDB Model blk
model =
  Model blk
model
    { open = False
    , lastTicketNo = zeroPerasVoteTicketNo
    , votes = Map.empty
    , certs = Map.empty
    }

addVote ::
  ( StandardHash blk
  , Ord (PerasVote blk)
  , PerasCert blk ~ MockPerasCert blk
  , IsPerasVote (PerasVote blk) blk
  , IsPerasCert (PerasCert blk) blk
  ) =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  Model blk ->
  ( Either PerasVoteDbModelError (AddPerasVoteResult blk)
  , Model blk
  )
addVote :: forall blk.
(StandardHash blk, Ord (PerasVote blk),
 PerasCert blk ~ MockPerasCert blk, IsPerasVote (PerasVote blk) blk,
 IsPerasCert (PerasCert blk) blk) =>
WithArrivalTime (ValidatedPerasVote blk)
-> Model blk
-> (Either PerasVoteDbModelError (AddPerasVoteResult blk),
    Model blk)
addVote WithArrivalTime (ValidatedPerasVote blk)
vote Model blk
model
  -- The ID of a vote is a pair (seatIndex, roundNo). So checking if the voter has
  -- already voted in this round means checking if the pair (seatIndex, roundNo)
  -- is already present in the model i.e. if the vote is already in the model.
  -- In which case, we can ignore it.
  --
  -- NOTE: this is under the assumption that a voter doesn't cast two different
  -- votes for the same round (that is, with the same ID but different body).
  | Bool
voterAlreadyVotedInRound =
      ( AddPerasVoteResult blk
-> Either PerasVoteDbModelError (AddPerasVoteResult blk)
forall a b. b -> Either a b
Right (AddPerasVoteResult blk
 -> Either PerasVoteDbModelError (AddPerasVoteResult blk))
-> AddPerasVoteResult blk
-> Either PerasVoteDbModelError (AddPerasVoteResult blk)
forall a b. (a -> b) -> a -> b
$
          AddPerasVoteResult blk
forall blk. AddPerasVoteResult blk
PerasVoteAlreadyInDB
      , Model blk
model
      )
  -- A quorum was reached, but there is another cert already boosting a different
  -- block in this round => integrity violation (shouldn't happen in practice)
  | Bool
reachedQuorum
  , Just ValidatedPerasCert blk
existingCert <- Maybe (ValidatedPerasCert blk)
certAtRound
  , ValidatedPerasCert blk -> Point blk
forall cert blk. IsPerasCert cert blk => cert -> Point blk
getPerasCertPoint ValidatedPerasCert blk
freshCert Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
/= ValidatedPerasCert blk -> Point blk
forall cert blk. IsPerasCert cert blk => cert -> Point blk
getPerasCertPoint ValidatedPerasCert blk
existingCert =
      ( PerasVoteDbModelError
-> Either PerasVoteDbModelError (AddPerasVoteResult blk)
forall a b. a -> Either a b
Left (PerasVoteDbModelError
 -> Either PerasVoteDbModelError (AddPerasVoteResult blk))
-> PerasVoteDbModelError
-> Either PerasVoteDbModelError (AddPerasVoteResult blk)
forall a b. (a -> b) -> a -> b
$
          PerasRoundNo -> PerasVoteDbModelError
MultipleWinnersInRound PerasRoundNo
roundNo
      , Model blk
model
      )
  -- A quorum was reached for the first time (when there is no existing
  -- certificate for the given round) => causing a new cert to be generated
  | Bool
reachedQuorum
  , Maybe (ValidatedPerasCert blk)
Nothing <- Maybe (ValidatedPerasCert blk)
certAtRound =
      -- Also ensure that we didn't already have a quorum before adding this
      -- vote in a more direct way: the weight represented by the existing votes
      -- must be below the threshold.
      Bool
-> (Either PerasVoteDbModelError (AddPerasVoteResult blk),
    Model blk)
-> (Either PerasVoteDbModelError (AddPerasVoteResult blk),
    Model blk)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not Bool
hadQuorum) ((Either PerasVoteDbModelError (AddPerasVoteResult blk), Model blk)
 -> (Either PerasVoteDbModelError (AddPerasVoteResult blk),
     Model blk))
-> (Either PerasVoteDbModelError (AddPerasVoteResult blk),
    Model blk)
-> (Either PerasVoteDbModelError (AddPerasVoteResult blk),
    Model blk)
forall a b. (a -> b) -> a -> b
$
        ( AddPerasVoteResult blk
-> Either PerasVoteDbModelError (AddPerasVoteResult blk)
forall a b. b -> Either a b
Right (AddPerasVoteResult blk
 -> Either PerasVoteDbModelError (AddPerasVoteResult blk))
-> AddPerasVoteResult blk
-> Either PerasVoteDbModelError (AddPerasVoteResult blk)
forall a b. (a -> b) -> a -> b
$
            ValidatedPerasCert blk -> AddPerasVoteResult blk
forall blk. ValidatedPerasCert blk -> AddPerasVoteResult blk
AddedPerasVoteAndGeneratedNewCert ValidatedPerasCert blk
freshCert
        , Model blk
model
            { votes =
                Map.insert voteTarget extendedVotes (votes model)
            , certs =
                Map.insert roundNo freshCert (certs model)
            , lastTicketNo =
                nextTicketNo
            }
        )
  -- Otherwise, just add the vote without generating a new cert
  | Bool
otherwise =
      ( AddPerasVoteResult blk
-> Either PerasVoteDbModelError (AddPerasVoteResult blk)
forall a b. b -> Either a b
Right (AddPerasVoteResult blk
 -> Either PerasVoteDbModelError (AddPerasVoteResult blk))
-> AddPerasVoteResult blk
-> Either PerasVoteDbModelError (AddPerasVoteResult blk)
forall a b. (a -> b) -> a -> b
$
          AddPerasVoteResult blk
forall blk. AddPerasVoteResult blk
AddedPerasVoteButDidntGenerateNewCert
      , Model blk
model
          { votes =
              Map.insert voteTarget extendedVotes (votes model)
          , lastTicketNo =
              nextTicketNo
          }
      )
 where
  -- Extract relevant information from the vote
  roundNo :: PerasRoundNo
roundNo =
    WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote blk. IsPerasVote vote blk => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote
  votedBlock :: Point blk
votedBlock =
    WithArrivalTime (ValidatedPerasVote blk) -> Point blk
forall vote blk. IsPerasVote vote blk => vote -> Point blk
getPerasVotePoint WithArrivalTime (ValidatedPerasVote blk)
vote
  voter :: PerasSeatIndex
voter =
    WithArrivalTime (ValidatedPerasVote blk) -> PerasSeatIndex
forall vote blk. IsPerasVote vote blk => vote -> PerasSeatIndex
getPerasVoteSeatIndex WithArrivalTime (ValidatedPerasVote blk)
vote
  -- Compute the next ticket number associated to this vote.
  -- NOTE: This is a 64-bit counter, so there's no practical risk of overflow.
  nextTicketNo :: PerasVoteTicketNo
nextTicketNo =
    PerasVoteTicketNo -> PerasVoteTicketNo
forall a. Enum a => a -> a
succ (Model blk -> PerasVoteTicketNo
forall blk. Model blk -> PerasVoteTicketNo
lastTicketNo Model blk
model)
  -- Prepare various data structures needed to update the model
  voteId :: PerasVoteId
voteId =
    PerasVoteId{pviRoundNo :: PerasRoundNo
pviRoundNo = PerasRoundNo
roundNo, pviSeatIndex :: PerasSeatIndex
pviSeatIndex = PerasSeatIndex
voter}
  voteTarget :: PerasVoteTarget blk
voteTarget =
    PerasVoteTarget{pvtRoundNo :: PerasRoundNo
pvtRoundNo = PerasRoundNo
roundNo, pvtBlock :: Point blk
pvtBlock = Point blk
votedBlock}
  voteEntry :: VoteEntry blk
voteEntry =
    VoteEntry{veTicketNo :: PerasVoteTicketNo
veTicketNo = PerasVoteTicketNo
nextTicketNo, veVoter :: PerasSeatIndex
veVoter = PerasSeatIndex
voter, veVote :: WithArrivalTime (ValidatedPerasVote blk)
veVote = WithArrivalTime (ValidatedPerasVote blk)
vote}
  -- Has this voter already voted in this round?
  voterAlreadyVotedInRound :: Bool
voterAlreadyVotedInRound =
    PerasVoteId -> Model blk -> Bool
forall blk. PerasVoteId -> Model blk -> Bool
hasVote PerasVoteId
voteId Model blk
model
  -- The existing votes for this round and block
  existingVotes :: Set (VoteEntry blk)
existingVotes =
    Set (VoteEntry blk)
-> PerasVoteTarget blk
-> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
-> Set (VoteEntry blk)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set (VoteEntry blk)
forall a. Set a
Set.empty PerasVoteTarget blk
voteTarget (Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
forall blk.
Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
votes Model blk
model)
  -- The extended set of votes including the new one
  extendedVotes :: Set (VoteEntry blk)
extendedVotes =
    VoteEntry blk -> Set (VoteEntry blk) -> Set (VoteEntry blk)
forall a. Ord a => a -> Set a -> Set a
Set.insert VoteEntry blk
voteEntry Set (VoteEntry blk)
existingVotes
  -- The extended set of voters including the new one
  extendedVoters :: NESet PerasSeatIndex
extendedVoters =
    Set PerasSeatIndex -> NESet PerasSeatIndex
forall a. Set a -> NESet a
NESet.unsafeFromSet -- Safe due to insert below
      (Set PerasSeatIndex -> NESet PerasSeatIndex)
-> (Set (VoteEntry blk) -> Set PerasSeatIndex)
-> Set (VoteEntry blk)
-> NESet PerasSeatIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasSeatIndex -> Set PerasSeatIndex -> Set PerasSeatIndex
forall a. Ord a => a -> Set a -> Set a
Set.insert PerasSeatIndex
voter
      (Set PerasSeatIndex -> Set PerasSeatIndex)
-> (Set (VoteEntry blk) -> Set PerasSeatIndex)
-> Set (VoteEntry blk)
-> Set PerasSeatIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VoteEntry blk -> PerasSeatIndex)
-> Set (VoteEntry blk) -> Set PerasSeatIndex
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map VoteEntry blk -> PerasSeatIndex
forall blk. VoteEntry blk -> PerasSeatIndex
veVoter
      (Set (VoteEntry blk) -> NESet PerasSeatIndex)
-> Set (VoteEntry blk) -> NESet PerasSeatIndex
forall a b. (a -> b) -> a -> b
$ Set (VoteEntry blk)
existingVotes
  -- Get the total weight of a set of votes
  getTotalWeight :: Set (VoteEntry blk) -> VoteWeight
getTotalWeight =
    Ratio Integer -> VoteWeight
VoteWeight
      (Ratio Integer -> VoteWeight)
-> (Set (VoteEntry blk) -> Ratio Integer)
-> Set (VoteEntry blk)
-> VoteWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ratio Integer] -> Ratio Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
      ([Ratio Integer] -> Ratio Integer)
-> (Set (VoteEntry blk) -> [Ratio Integer])
-> Set (VoteEntry blk)
-> Ratio Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VoteEntry blk -> Ratio Integer)
-> [VoteEntry blk] -> [Ratio Integer]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( VoteWeight -> Ratio Integer
unVoteWeight
            (VoteWeight -> Ratio Integer)
-> (VoteEntry blk -> VoteWeight) -> VoteEntry blk -> Ratio Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasVote blk -> VoteWeight
forall blk. ValidatedPerasVote blk -> VoteWeight
vpvVoteWeight
            (ValidatedPerasVote blk -> VoteWeight)
-> (VoteEntry blk -> ValidatedPerasVote blk)
-> VoteEntry 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)
 -> ValidatedPerasVote blk)
-> (VoteEntry blk -> WithArrivalTime (ValidatedPerasVote blk))
-> VoteEntry blk
-> ValidatedPerasVote blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VoteEntry blk -> WithArrivalTime (ValidatedPerasVote blk)
forall blk.
VoteEntry blk -> WithArrivalTime (ValidatedPerasVote blk)
veVote
        )
      ([VoteEntry blk] -> [Ratio Integer])
-> (Set (VoteEntry blk) -> [VoteEntry blk])
-> Set (VoteEntry blk)
-> [Ratio Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (VoteEntry blk) -> [VoteEntry blk]
forall a. Set a -> [a]
Set.toList
  -- Total weight represented by the existing votes
  existingVotesWeight :: VoteWeight
existingVotesWeight =
    Set (VoteEntry blk) -> VoteWeight
forall {blk}. Set (VoteEntry blk) -> VoteWeight
getTotalWeight Set (VoteEntry blk)
existingVotes
  -- Total weight represented by the extended set of votes
  extendedVotesWeight :: VoteWeight
extendedVotesWeight =
    Set (VoteEntry blk) -> VoteWeight
forall {blk}. Set (VoteEntry blk) -> VoteWeight
getTotalWeight Set (VoteEntry blk)
extendedVotes
  -- Did we already have a quorum before adding this new vote?
  hadQuorum :: Bool
hadQuorum =
    PerasParams blk -> VoteWeight -> Bool
forall blk. PerasParams blk -> VoteWeight -> Bool
weightAboveThreshold (Model blk -> PerasParams blk
forall blk. Model blk -> PerasParams blk
params Model blk
model) VoteWeight
existingVotesWeight
  -- Did we reach the quorum threshold with this new vote?
  reachedQuorum :: Bool
reachedQuorum =
    PerasParams blk -> VoteWeight -> Bool
forall blk. PerasParams blk -> VoteWeight -> Bool
weightAboveThreshold (Model blk -> PerasParams blk
forall blk. Model blk -> PerasParams blk
params Model blk
model) VoteWeight
extendedVotesWeight
  -- The existing certificate (if any) for this round
  certAtRound :: Maybe (ValidatedPerasCert blk)
certAtRound =
    PerasRoundNo
-> Map PerasRoundNo (ValidatedPerasCert blk)
-> Maybe (ValidatedPerasCert blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PerasRoundNo
roundNo (Model blk -> Map PerasRoundNo (ValidatedPerasCert blk)
forall blk. Model blk -> Map PerasRoundNo (ValidatedPerasCert blk)
certs Model blk
model)
  -- The fresh certificate that would be generated if a quorum is reached
  freshCert :: ValidatedPerasCert blk
freshCert =
    ValidatedPerasCert
      { vpcCert :: PerasCert blk
vpcCert =
          MockPerasCert
            { mockCertRound :: PerasRoundNo
mockCertRound = PerasRoundNo
roundNo
            , mockCertBlock :: Point blk
mockCertBlock = Point blk
votedBlock
            , mockCertVoters :: NE (Set PerasSeatIndex)
mockCertVoters = NESet PerasSeatIndex
NE (Set PerasSeatIndex)
extendedVoters
            }
      , vpcCertBoost :: PerasWeight
vpcCertBoost = PerasParams blk -> PerasWeight
forall blk. PerasParams blk -> PerasWeight
perasWeight (Model blk -> PerasParams blk
forall blk. Model blk -> PerasParams blk
params Model blk
model)
      }

getVoteIds ::
  Model blk ->
  Set PerasVoteId
getVoteIds :: forall blk. Model blk -> Set PerasVoteId
getVoteIds Model blk
model =
  [Set PerasVoteId] -> Set PerasVoteId
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set PerasVoteId] -> Set PerasVoteId)
-> [Set PerasVoteId] -> Set PerasVoteId
forall a b. (a -> b) -> a -> b
$
    [ (VoteEntry blk -> PerasVoteId)
-> Set (VoteEntry blk) -> Set PerasVoteId
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map
        ( \VoteEntry blk
ve ->
            PerasVoteId
              { pviRoundNo :: PerasRoundNo
pviRoundNo = PerasVoteTarget blk -> PerasRoundNo
forall blk. PerasVoteTarget blk -> PerasRoundNo
pvtRoundNo PerasVoteTarget blk
voteTarget
              , pviSeatIndex :: PerasSeatIndex
pviSeatIndex = VoteEntry blk -> PerasSeatIndex
forall blk. VoteEntry blk -> PerasSeatIndex
veVoter VoteEntry blk
ve
              }
        )
        Set (VoteEntry blk)
votesForTarget
    | (PerasVoteTarget blk
voteTarget, Set (VoteEntry blk)
votesForTarget) <- Map (PerasVoteTarget blk) (Set (VoteEntry blk))
-> [(PerasVoteTarget blk, Set (VoteEntry blk))]
forall k a. Map k a -> [(k, a)]
Map.toList (Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
forall blk.
Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
votes Model blk
model)
    ]

getVotesAfter ::
  PerasVoteTicketNo ->
  Model blk ->
  Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
getVotesAfter :: forall blk.
PerasVoteTicketNo
-> Model blk
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
getVotesAfter PerasVoteTicketNo
ticketNo Model blk
model =
  [(PerasVoteTicketNo, WithArrivalTime (ValidatedPerasVote blk))]
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (VoteEntry blk -> PerasVoteTicketNo
forall blk. VoteEntry blk -> PerasVoteTicketNo
veTicketNo VoteEntry blk
ve, VoteEntry blk -> WithArrivalTime (ValidatedPerasVote blk)
forall blk.
VoteEntry blk -> WithArrivalTime (ValidatedPerasVote blk)
veVote VoteEntry blk
ve)
    | Set (VoteEntry blk)
votesForTarget <- Map (PerasVoteTarget blk) (Set (VoteEntry blk))
-> [Set (VoteEntry blk)]
forall k a. Map k a -> [a]
Map.elems (Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
forall blk.
Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
votes Model blk
model)
    , VoteEntry blk
ve <- Set (VoteEntry blk) -> [VoteEntry blk]
forall a. Set a -> [a]
Set.toList Set (VoteEntry blk)
votesForTarget
    , VoteEntry blk -> PerasVoteTicketNo
forall blk. VoteEntry blk -> PerasVoteTicketNo
veTicketNo VoteEntry blk
ve PerasVoteTicketNo -> PerasVoteTicketNo -> Bool
forall a. Ord a => a -> a -> Bool
> PerasVoteTicketNo
ticketNo
    ]

getForgedCertForRound ::
  PerasRoundNo ->
  Model blk ->
  Maybe (ValidatedPerasCert blk)
getForgedCertForRound :: forall blk.
PerasRoundNo -> Model blk -> Maybe (ValidatedPerasCert blk)
getForgedCertForRound PerasRoundNo
roundNo Model blk
model =
  PerasRoundNo
-> Map PerasRoundNo (ValidatedPerasCert blk)
-> Maybe (ValidatedPerasCert blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PerasRoundNo
roundNo (Model blk -> Map PerasRoundNo (ValidatedPerasCert blk)
forall blk. Model blk -> Map PerasRoundNo (ValidatedPerasCert blk)
certs Model blk
model)

garbageCollect ::
  SlotNo ->
  Model blk ->
  Model blk
garbageCollect :: forall blk. SlotNo -> Model blk -> Model blk
garbageCollect SlotNo
slotNo Model blk
model =
  Model blk
model
    { votes =
        Map.filterWithKey
          (\PerasVoteTarget blk
voteTarget Set (VoteEntry blk)
_ -> Bool -> Bool
not (PerasRoundNo -> Set PerasRoundNo -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (PerasVoteTarget blk -> PerasRoundNo
forall blk. PerasVoteTarget blk -> PerasRoundNo
pvtRoundNo PerasVoteTarget blk
voteTarget) Set PerasRoundNo
roundsToDelete))
          (votes model)
    , certs =
        Map.filterWithKey
          (\PerasRoundNo
roundNo ValidatedPerasCert blk
_ -> Bool -> Bool
not (PerasRoundNo -> Set PerasRoundNo -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PerasRoundNo
roundNo Set PerasRoundNo
roundsToDelete))
          (certs model)
    }
 where
  -- A round is deleted when ALL of its vote targets point to blocks strictly
  -- older than the GC threshold, i.e. when even its youngest target is old.
  roundsToDelete :: Set PerasRoundNo
roundsToDelete =
    Map PerasRoundNo (WithOrigin SlotNo) -> Set PerasRoundNo
forall k a. Map k a -> Set k
Map.keysSet (Map PerasRoundNo (WithOrigin SlotNo) -> Set PerasRoundNo)
-> Map PerasRoundNo (WithOrigin SlotNo) -> Set PerasRoundNo
forall a b. (a -> b) -> a -> b
$
      (WithOrigin SlotNo -> Bool)
-> Map PerasRoundNo (WithOrigin SlotNo)
-> Map PerasRoundNo (WithOrigin SlotNo)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slotNo) Map PerasRoundNo (WithOrigin SlotNo)
youngestSlotByRound

  -- The youngest target slot across all vote targets for a given round.
  youngestSlotByRound :: Map PerasRoundNo (WithOrigin SlotNo)
youngestSlotByRound =
    (WithOrigin SlotNo -> WithOrigin SlotNo -> WithOrigin SlotNo)
-> [(PerasRoundNo, WithOrigin SlotNo)]
-> Map PerasRoundNo (WithOrigin SlotNo)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
      WithOrigin SlotNo -> WithOrigin SlotNo -> WithOrigin SlotNo
forall a. Ord a => a -> a -> a
max
      [ (PerasVoteTarget blk -> PerasRoundNo
forall blk. PerasVoteTarget blk -> PerasRoundNo
pvtRoundNo PerasVoteTarget blk
vt, Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (PerasVoteTarget blk -> Point blk
forall blk. PerasVoteTarget blk -> Point blk
pvtBlock PerasVoteTarget blk
vt))
      | PerasVoteTarget blk
vt <- Map (PerasVoteTarget blk) (Set (VoteEntry blk))
-> [PerasVoteTarget blk]
forall k a. Map k a -> [k]
Map.keys (Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
forall blk.
Model blk -> Map (PerasVoteTarget blk) (Set (VoteEntry blk))
votes Model blk
model)
      ]