{-# LANGUAGE DeriveGeneric #-}

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 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
  ( IsPerasVote (..)
  , PerasCert' (..)
  , PerasParams (..)
  , PerasRoundNo
  , PerasVoteId (..)
  , PerasVoteTarget (..)
  , ValidatedPerasCert (..)
  , ValidatedPerasVote (..)
  , VoteWeight (..)
  , getPerasCertPoint
  , weightAboveThreshold
  )
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
  ( WithArrivalTime (..)
  )
import Ouroboros.Consensus.Peras.Types (PerasSeatIndex)
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 voter ID
  , forall blk.
VoteEntry blk -> WithArrivalTime (ValidatedPerasVote blk)
veVote :: WithArrivalTime (ValidatedPerasVote blk)
  -- ^ The vote itself
  }
  deriving (Int -> VoteEntry blk -> ShowS
[VoteEntry blk] -> ShowS
VoteEntry blk -> String
(Int -> VoteEntry blk -> ShowS)
-> (VoteEntry blk -> String)
-> ([VoteEntry blk] -> ShowS)
-> Show (VoteEntry blk)
forall blk. StandardHash blk => Int -> VoteEntry blk -> ShowS
forall blk. StandardHash blk => [VoteEntry blk] -> ShowS
forall blk. StandardHash blk => VoteEntry blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> VoteEntry blk -> ShowS
showsPrec :: Int -> VoteEntry blk -> ShowS
$cshow :: forall blk. StandardHash blk => VoteEntry blk -> String
show :: VoteEntry blk -> String
$cshowList :: forall blk. StandardHash blk => [VoteEntry blk] -> ShowS
showList :: [VoteEntry blk] -> ShowS
Show, VoteEntry blk -> VoteEntry blk -> Bool
(VoteEntry blk -> VoteEntry blk -> Bool)
-> (VoteEntry blk -> VoteEntry blk -> Bool) -> Eq (VoteEntry blk)
forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> Bool
== :: VoteEntry blk -> VoteEntry blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> Bool
/= :: VoteEntry blk -> VoteEntry blk -> Bool
Eq, Eq (VoteEntry blk)
Eq (VoteEntry blk) =>
(VoteEntry blk -> VoteEntry blk -> Ordering)
-> (VoteEntry blk -> VoteEntry blk -> Bool)
-> (VoteEntry blk -> VoteEntry blk -> Bool)
-> (VoteEntry blk -> VoteEntry blk -> Bool)
-> (VoteEntry blk -> VoteEntry blk -> Bool)
-> (VoteEntry blk -> VoteEntry blk -> VoteEntry blk)
-> (VoteEntry blk -> VoteEntry blk -> VoteEntry blk)
-> Ord (VoteEntry blk)
VoteEntry blk -> VoteEntry blk -> Bool
VoteEntry blk -> VoteEntry blk -> Ordering
VoteEntry blk -> VoteEntry blk -> VoteEntry blk
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
forall blk. StandardHash blk => Eq (VoteEntry blk)
forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> Bool
forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> Ordering
forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> VoteEntry blk
$ccompare :: forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> Ordering
compare :: VoteEntry blk -> VoteEntry blk -> Ordering
$c< :: forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> Bool
< :: VoteEntry blk -> VoteEntry blk -> Bool
$c<= :: forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> Bool
<= :: VoteEntry blk -> VoteEntry blk -> Bool
$c> :: forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> Bool
> :: VoteEntry blk -> VoteEntry blk -> Bool
$c>= :: forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> Bool
>= :: VoteEntry blk -> VoteEntry blk -> Bool
$cmax :: forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> VoteEntry blk
max :: VoteEntry blk -> VoteEntry blk -> VoteEntry blk
$cmin :: forall blk.
StandardHash blk =>
VoteEntry blk -> VoteEntry blk -> VoteEntry blk
min :: VoteEntry blk -> VoteEntry blk -> VoteEntry blk
Ord, (forall x. VoteEntry blk -> Rep (VoteEntry blk) x)
-> (forall x. Rep (VoteEntry blk) x -> VoteEntry blk)
-> Generic (VoteEntry blk)
forall x. Rep (VoteEntry blk) x -> VoteEntry blk
forall x. VoteEntry blk -> Rep (VoteEntry blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (VoteEntry blk) x -> VoteEntry blk
forall blk x. VoteEntry blk -> Rep (VoteEntry blk) x
$cfrom :: forall blk x. VoteEntry blk -> Rep (VoteEntry blk) x
from :: forall x. VoteEntry blk -> Rep (VoteEntry blk) x
$cto :: forall blk x. Rep (VoteEntry blk) x -> VoteEntry blk
to :: forall x. Rep (VoteEntry blk) x -> VoteEntry blk
Generic)

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 (Int -> Model blk -> ShowS
[Model blk] -> ShowS
Model blk -> String
(Int -> Model blk -> ShowS)
-> (Model blk -> String)
-> ([Model blk] -> ShowS)
-> Show (Model blk)
forall blk. StandardHash blk => Int -> Model blk -> ShowS
forall blk. StandardHash blk => [Model blk] -> ShowS
forall blk. StandardHash blk => Model blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> Model blk -> ShowS
showsPrec :: Int -> Model blk -> ShowS
$cshow :: forall blk. StandardHash blk => Model blk -> String
show :: Model blk -> String
$cshowList :: forall blk. StandardHash blk => [Model blk] -> ShowS
showList :: [Model blk] -> ShowS
Show, (forall x. Model blk -> Rep (Model blk) x)
-> (forall x. Rep (Model blk) x -> Model blk)
-> Generic (Model blk)
forall x. Rep (Model blk) x -> Model blk
forall x. Model blk -> Rep (Model blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (Model blk) x -> Model blk
forall blk x. Model blk -> Rep (Model blk) x
$cfrom :: forall blk x. Model blk -> Rep (Model blk) x
from :: forall x. Model blk -> Rep (Model blk) x
$cto :: forall blk x. Rep (Model blk) x -> Model blk
to :: forall x. Rep (Model blk) x -> Model blk
Generic)

instance StandardHash 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 =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  Model blk ->
  ( Either PerasVoteDbModelError (AddPerasVoteResult blk)
  , Model blk
  )
addVote :: forall blk.
StandardHash 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 (voterId, roundNo). So checking if the voter has
  -- already voted in this round means checking if the pair (voterId, 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 stake 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 :: BoostedBlock (WithArrivalTime (ValidatedPerasVote blk))
votedBlock =
    WithArrivalTime (ValidatedPerasVote blk)
-> BoostedBlock (WithArrivalTime (ValidatedPerasVote blk))
forall vote blk. IsPerasVote vote blk => vote -> BoostedBlock vote
getPerasVoteBlock 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
  -- Get the total stake of a set of votes
  getTotalStake :: Set (VoteEntry blk) -> VoteWeight
getTotalStake =
    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 stake represented by the existing votes
  existingVotesStake :: VoteWeight
existingVotesStake =
    Set (VoteEntry blk) -> VoteWeight
forall {blk}. Set (VoteEntry blk) -> VoteWeight
getTotalStake Set (VoteEntry blk)
existingVotes
  -- Total stake represented by the extended set of votes
  extendedVotesStake :: VoteWeight
extendedVotesStake =
    Set (VoteEntry blk) -> VoteWeight
forall {blk}. Set (VoteEntry blk) -> VoteWeight
getTotalStake 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
existingVotesStake
  -- 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
extendedVotesStake
  -- 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 =
          PerasCert
            { pcCertRound :: PerasRoundNo
pcCertRound = WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote blk. IsPerasVote vote blk => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote
            , pcCertBoostedBlock :: Point blk
pcCertBoostedBlock = WithArrivalTime (ValidatedPerasVote blk)
-> BoostedBlock (WithArrivalTime (ValidatedPerasVote blk))
forall vote blk. IsPerasVote vote blk => vote -> BoostedBlock vote
getPerasVoteBlock WithArrivalTime (ValidatedPerasVote blk)
vote
            }
      , 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)
      ]