{-# LANGUAGE DeriveGeneric #-}

module Test.Ouroboros.Storage.PerasVoteDB.Model
  ( PerasVoteDbModelError (..)
  , 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
  ( HasPerasVoteBlock (..)
  , HasPerasVoteRound (..)
  , PerasCert (..)
  , PerasCfg
  , PerasParams (..)
  , PerasRoundNo
  , PerasVoteId (..)
  , PerasVoteStake (..)
  , PerasVoteTarget (..)
  , PerasVoterId
  , ValidatedPerasCert (..)
  , ValidatedPerasVote
  , getPerasCertBoostedBlock
  , getPerasVoteStake
  , getPerasVoteVoterId
  , stakeAboveThreshold
  )
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
  ( WithArrivalTime (..)
  )
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 -> PerasVoterId
veVoter :: PerasVoterId
  -- ^ 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
params :: PerasParams
  -- ^ 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 :: PerasCfg blk -> Model blk
initModel :: forall blk. PerasCfg blk -> Model blk
initModel PerasCfg blk
cfg =
  Model
    { open :: Bool
open = Bool
False
    , params :: PerasParams
params = PerasParams
PerasCfg blk
cfg
    , 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 blk ->
  Model blk ->
  Bool
hasVote :: forall blk. PerasVoteId blk -> Model blk -> Bool
hasVote PerasVoteId blk
voteId Model blk
model =
  PerasVoteId blk -> Set (PerasVoteId blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PerasVoteId blk
voteId Set (PerasVoteId blk)
forall {blk}. Set (PerasVoteId blk)
voteIds
 where
  voteIds :: Set (PerasVoteId blk)
voteIds =
    [Set (PerasVoteId blk)] -> Set (PerasVoteId blk)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set (PerasVoteId blk)] -> Set (PerasVoteId blk))
-> [Set (PerasVoteId blk)] -> Set (PerasVoteId blk)
forall a b. (a -> b) -> a -> b
$
      [ (VoteEntry blk -> PerasVoteId blk)
-> Set (VoteEntry blk) -> Set (PerasVoteId blk)
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
                , pviVoterId :: PerasVoterId
pviVoterId = VoteEntry blk -> PerasVoterId
forall blk. VoteEntry blk -> PerasVoterId
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.
HasPerasCertBoostedBlock cert blk =>
cert -> Point blk
getPerasCertBoostedBlock ValidatedPerasCert blk
freshCert Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
/= ValidatedPerasCert blk -> Point blk
forall cert blk.
HasPerasCertBoostedBlock cert blk =>
cert -> Point blk
getPerasCertBoostedBlock 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. HasPerasVoteRound vote => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote
  votedBlock :: Point blk
votedBlock =
    WithArrivalTime (ValidatedPerasVote blk) -> Point blk
forall vote blk. HasPerasVoteBlock vote blk => vote -> Point blk
getPerasVoteBlock WithArrivalTime (ValidatedPerasVote blk)
vote
  voter :: PerasVoterId
voter =
    WithArrivalTime (ValidatedPerasVote blk) -> PerasVoterId
forall vote. HasPerasVoteVoterId vote => vote -> PerasVoterId
getPerasVoteVoterId 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 blk
voteId =
    PerasVoteId{pviRoundNo :: PerasRoundNo
pviRoundNo = PerasRoundNo
roundNo, pviVoterId :: PerasVoterId
pviVoterId = PerasVoterId
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 :: PerasVoterId
veVoter = PerasVoterId
voter, veVote :: WithArrivalTime (ValidatedPerasVote blk)
veVote = WithArrivalTime (ValidatedPerasVote blk)
vote}
  -- Has this voter already voted in this round?
  voterAlreadyVotedInRound :: Bool
voterAlreadyVotedInRound =
    PerasVoteId blk -> Model blk -> Bool
forall blk. PerasVoteId blk -> Model blk -> Bool
hasVote PerasVoteId blk
forall {blk}. PerasVoteId blk
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) -> PerasVoteStake
getTotalStake =
    Rational -> PerasVoteStake
PerasVoteStake
      (Rational -> PerasVoteStake)
-> (Set (VoteEntry blk) -> Rational)
-> Set (VoteEntry blk)
-> PerasVoteStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Rational] -> Rational
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
      ([Rational] -> Rational)
-> (Set (VoteEntry blk) -> [Rational])
-> Set (VoteEntry blk)
-> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VoteEntry blk -> Rational) -> [VoteEntry blk] -> [Rational]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( PerasVoteStake -> Rational
unPerasVoteStake
            (PerasVoteStake -> Rational)
-> (VoteEntry blk -> PerasVoteStake) -> VoteEntry blk -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasVote blk -> PerasVoteStake
forall vote. HasPerasVoteStake vote => vote -> PerasVoteStake
getPerasVoteStake
            (ValidatedPerasVote blk -> PerasVoteStake)
-> (VoteEntry blk -> ValidatedPerasVote blk)
-> VoteEntry blk
-> PerasVoteStake
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] -> [Rational])
-> (Set (VoteEntry blk) -> [VoteEntry blk])
-> Set (VoteEntry blk)
-> [Rational]
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 :: PerasVoteStake
existingVotesStake =
    Set (VoteEntry blk) -> PerasVoteStake
forall {blk}. Set (VoteEntry blk) -> PerasVoteStake
getTotalStake Set (VoteEntry blk)
existingVotes
  -- Total stake represented by the extended set of votes
  extendedVotesStake :: PerasVoteStake
extendedVotesStake =
    Set (VoteEntry blk) -> PerasVoteStake
forall {blk}. Set (VoteEntry blk) -> PerasVoteStake
getTotalStake Set (VoteEntry blk)
extendedVotes
  -- Did we already have a quorum before adding this new vote?
  hadQuorum :: Bool
hadQuorum =
    PerasParams -> PerasVoteStake -> Bool
stakeAboveThreshold (Model blk -> PerasParams
forall blk. Model blk -> PerasParams
params Model blk
model) PerasVoteStake
existingVotesStake
  -- Did we reach the quorum threshold with this new vote?
  reachedQuorum :: Bool
reachedQuorum =
    PerasParams -> PerasVoteStake -> Bool
stakeAboveThreshold (Model blk -> PerasParams
forall blk. Model blk -> PerasParams
params Model blk
model) PerasVoteStake
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. HasPerasVoteRound vote => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote
            , pcCertBoostedBlock :: Point blk
pcCertBoostedBlock = WithArrivalTime (ValidatedPerasVote blk) -> Point blk
forall vote blk. HasPerasVoteBlock vote blk => vote -> Point blk
getPerasVoteBlock WithArrivalTime (ValidatedPerasVote blk)
vote
            }
      , vpcCertBoost :: PerasWeight
vpcCertBoost = PerasParams -> PerasWeight
perasWeight (Model blk -> PerasParams
forall blk. Model blk -> PerasParams
params Model blk
model)
      }

getVoteIds ::
  Model blk ->
  Set (PerasVoteId blk)
getVoteIds :: forall blk. Model blk -> Set (PerasVoteId blk)
getVoteIds Model blk
model =
  [Set (PerasVoteId blk)] -> Set (PerasVoteId blk)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set (PerasVoteId blk)] -> Set (PerasVoteId blk))
-> [Set (PerasVoteId blk)] -> Set (PerasVoteId blk)
forall a b. (a -> b) -> a -> b
$
    [ (VoteEntry blk -> PerasVoteId blk)
-> Set (VoteEntry blk) -> Set (PerasVoteId blk)
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
              , pviVoterId :: PerasVoterId
pviVoterId = VoteEntry blk -> PerasVoterId
forall blk. VoteEntry blk -> PerasVoterId
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)
      ]