{-# 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 GHC.Generics (Generic)
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)

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 ::
  PerasRoundNo ->
  Model blk ->
  Model blk
garbageCollect :: forall blk. PerasRoundNo -> Model blk -> Model blk
garbageCollect PerasRoundNo
roundNo Model blk
model =
  Model blk
model
    { votes =
        Map.filterWithKey
          (\PerasVoteTarget blk
voteTarget Set (VoteEntry blk)
_ -> PerasVoteTarget blk -> PerasRoundNo
forall blk. PerasVoteTarget blk -> PerasRoundNo
pvtRoundNo PerasVoteTarget blk
voteTarget PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
>= PerasRoundNo
roundNo)
          (votes model)
    , certs =
        Map.filterWithKey
          (\PerasRoundNo
r ValidatedPerasCert blk
_ -> PerasRoundNo
r PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
>= PerasRoundNo
roundNo)
          (certs model)
    }