{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

-- | Pure Peras voting rules
--
-- This module implements some machinery to abstract away the impure inputs
-- needed to evaluate the Peras voting rules in a pure fashion.
--
-- NOTE: most of the code in this module returns values over 'PerasEnabled' to
-- reflect the fact that some of the computations performed here require
-- querying a hard fork summary to map timestamps and slot numbers to their
-- corresponding Peras round numbers. This may not be possible if Peras was not
-- enabled at the relevant points in time, and such a case should be handled
-- appropriately by the caller.
module Ouroboros.Consensus.Peras.Voting.View
  ( PerasQryException (..)
  , PerasQry
  , runPerasQry
  , perasRoundStart
  , perasChainAtCandidateBlock
  , LatestCertSeenView (..)
  , LatestCertOnChainView (..)
  , PerasVotingView (..)
  , mkPerasVotingView
  )
where

import Cardano.Slotting.Slot (WithOrigin)
import Control.Exception (Exception)
import Control.Monad.Except (ExceptT, MonadError (..), runExceptT)
import Control.Monad.Reader (MonadReader (..), Reader, runReader)
import Ouroboros.Consensus.Block.Abstract
  ( GetHeader (..)
  , Header
  , SlotNo (..)
  , castPoint
  )
import Ouroboros.Consensus.Block.SupportsPeras
  ( HasPerasCertRound (..)
  , PerasRoundNo (..)
  , ValidatedPerasCert
  , getPerasCertBoostedBlock
  , getPerasCertRound
  )
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
  ( WithArrivalTime (..)
  )
import Ouroboros.Consensus.HardFork.History.EraParams
  ( pattern NoPerasEnabled
  , pattern PerasEnabled
  )
import qualified Ouroboros.Consensus.HardFork.History.Qry as HF
import qualified Ouroboros.Consensus.HardFork.History.Summary as HF
import Ouroboros.Consensus.Peras.Params
  ( PerasBlockMinSlots (..)
  , PerasParams (..)
  )
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF

{-------------------------------------------------------------------------------
  Voting helpers based on a hard fork summary
-------------------------------------------------------------------------------}

-- | Exceptions thrown when querying Peras-related historical information
data PerasQryException
  = -- | The hard fork summary does not cover the needed point in time.
    PerasQryExceptionPastHorizon HF.PastHorizonException
  | -- | Peras is not enabled at the needed point in time.
    PerasQryExceptionPerasDisabled
  deriving (Int -> PerasQryException -> ShowS
[PerasQryException] -> ShowS
PerasQryException -> String
(Int -> PerasQryException -> ShowS)
-> (PerasQryException -> String)
-> ([PerasQryException] -> ShowS)
-> Show PerasQryException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PerasQryException -> ShowS
showsPrec :: Int -> PerasQryException -> ShowS
$cshow :: PerasQryException -> String
show :: PerasQryException -> String
$cshowList :: [PerasQryException] -> ShowS
showList :: [PerasQryException] -> ShowS
Show, Show PerasQryException
Typeable PerasQryException
(Typeable PerasQryException, Show PerasQryException) =>
(PerasQryException -> SomeException)
-> (SomeException -> Maybe PerasQryException)
-> (PerasQryException -> String)
-> (PerasQryException -> Bool)
-> Exception PerasQryException
SomeException -> Maybe PerasQryException
PerasQryException -> Bool
PerasQryException -> String
PerasQryException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: PerasQryException -> SomeException
toException :: PerasQryException -> SomeException
$cfromException :: SomeException -> Maybe PerasQryException
fromException :: SomeException -> Maybe PerasQryException
$cdisplayException :: PerasQryException -> String
displayException :: PerasQryException -> String
$cbacktraceDesired :: PerasQryException -> Bool
backtraceDesired :: PerasQryException -> Bool
Exception)

-- | Monad for querying Peras-related information from a hard fork summary.
--
-- This covers two possible error cases:
-- 1. the hard fork summary does not cover the needed point in time, or
-- 2. Peras is not enabled at the needed point in time.
newtype PerasQry xs a
  = PerasQry (ExceptT PerasQryException (Reader (HF.Summary xs)) a)
  deriving newtype ((forall a b. (a -> b) -> PerasQry xs a -> PerasQry xs b)
-> (forall a b. a -> PerasQry xs b -> PerasQry xs a)
-> Functor (PerasQry xs)
forall (xs :: [*]) a b. a -> PerasQry xs b -> PerasQry xs a
forall (xs :: [*]) a b. (a -> b) -> PerasQry xs a -> PerasQry xs b
forall a b. a -> PerasQry xs b -> PerasQry xs a
forall a b. (a -> b) -> PerasQry xs a -> PerasQry xs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (xs :: [*]) a b. (a -> b) -> PerasQry xs a -> PerasQry xs b
fmap :: forall a b. (a -> b) -> PerasQry xs a -> PerasQry xs b
$c<$ :: forall (xs :: [*]) a b. a -> PerasQry xs b -> PerasQry xs a
<$ :: forall a b. a -> PerasQry xs b -> PerasQry xs a
Functor, Functor (PerasQry xs)
Functor (PerasQry xs) =>
(forall a. a -> PerasQry xs a)
-> (forall a b.
    PerasQry xs (a -> b) -> PerasQry xs a -> PerasQry xs b)
-> (forall a b c.
    (a -> b -> c) -> PerasQry xs a -> PerasQry xs b -> PerasQry xs c)
-> (forall a b. PerasQry xs a -> PerasQry xs b -> PerasQry xs b)
-> (forall a b. PerasQry xs a -> PerasQry xs b -> PerasQry xs a)
-> Applicative (PerasQry xs)
forall (xs :: [*]). Functor (PerasQry xs)
forall (xs :: [*]) a. a -> PerasQry xs a
forall (xs :: [*]) a b.
PerasQry xs a -> PerasQry xs b -> PerasQry xs a
forall (xs :: [*]) a b.
PerasQry xs a -> PerasQry xs b -> PerasQry xs b
forall (xs :: [*]) a b.
PerasQry xs (a -> b) -> PerasQry xs a -> PerasQry xs b
forall (xs :: [*]) a b c.
(a -> b -> c) -> PerasQry xs a -> PerasQry xs b -> PerasQry xs c
forall a. a -> PerasQry xs a
forall a b. PerasQry xs a -> PerasQry xs b -> PerasQry xs a
forall a b. PerasQry xs a -> PerasQry xs b -> PerasQry xs b
forall a b. PerasQry xs (a -> b) -> PerasQry xs a -> PerasQry xs b
forall a b c.
(a -> b -> c) -> PerasQry xs a -> PerasQry xs b -> PerasQry xs c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (xs :: [*]) a. a -> PerasQry xs a
pure :: forall a. a -> PerasQry xs a
$c<*> :: forall (xs :: [*]) a b.
PerasQry xs (a -> b) -> PerasQry xs a -> PerasQry xs b
<*> :: forall a b. PerasQry xs (a -> b) -> PerasQry xs a -> PerasQry xs b
$cliftA2 :: forall (xs :: [*]) a b c.
(a -> b -> c) -> PerasQry xs a -> PerasQry xs b -> PerasQry xs c
liftA2 :: forall a b c.
(a -> b -> c) -> PerasQry xs a -> PerasQry xs b -> PerasQry xs c
$c*> :: forall (xs :: [*]) a b.
PerasQry xs a -> PerasQry xs b -> PerasQry xs b
*> :: forall a b. PerasQry xs a -> PerasQry xs b -> PerasQry xs b
$c<* :: forall (xs :: [*]) a b.
PerasQry xs a -> PerasQry xs b -> PerasQry xs a
<* :: forall a b. PerasQry xs a -> PerasQry xs b -> PerasQry xs a
Applicative, Applicative (PerasQry xs)
Applicative (PerasQry xs) =>
(forall a b.
 PerasQry xs a -> (a -> PerasQry xs b) -> PerasQry xs b)
-> (forall a b. PerasQry xs a -> PerasQry xs b -> PerasQry xs b)
-> (forall a. a -> PerasQry xs a)
-> Monad (PerasQry xs)
forall (xs :: [*]). Applicative (PerasQry xs)
forall (xs :: [*]) a. a -> PerasQry xs a
forall (xs :: [*]) a b.
PerasQry xs a -> PerasQry xs b -> PerasQry xs b
forall (xs :: [*]) a b.
PerasQry xs a -> (a -> PerasQry xs b) -> PerasQry xs b
forall a. a -> PerasQry xs a
forall a b. PerasQry xs a -> PerasQry xs b -> PerasQry xs b
forall a b. PerasQry xs a -> (a -> PerasQry xs b) -> PerasQry xs b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (xs :: [*]) a b.
PerasQry xs a -> (a -> PerasQry xs b) -> PerasQry xs b
>>= :: forall a b. PerasQry xs a -> (a -> PerasQry xs b) -> PerasQry xs b
$c>> :: forall (xs :: [*]) a b.
PerasQry xs a -> PerasQry xs b -> PerasQry xs b
>> :: forall a b. PerasQry xs a -> PerasQry xs b -> PerasQry xs b
$creturn :: forall (xs :: [*]) a. a -> PerasQry xs a
return :: forall a. a -> PerasQry xs a
Monad)

-- | Run a 'PerasQry' against a hard fork summary
runPerasQry ::
  HF.Summary xs ->
  PerasQry xs a ->
  Either PerasQryException a
runPerasQry :: forall (xs :: [*]) a.
Summary xs -> PerasQry xs a -> Either PerasQryException a
runPerasQry Summary xs
summary (PerasQry ExceptT PerasQryException (Reader (Summary xs)) a
qry) =
  Reader (Summary xs) (Either PerasQryException a)
-> Summary xs -> Either PerasQryException a
forall r a. Reader r a -> r -> a
runReader (ExceptT PerasQryException (Reader (Summary xs)) a
-> Reader (Summary xs) (Either PerasQryException a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT PerasQryException (Reader (Summary xs)) a
qry) Summary xs
summary

-- | Arrival slot number of a certificate
perasCertArrivalSlot ::
  WithArrivalTime cert ->
  PerasQry xs SlotNo
perasCertArrivalSlot :: forall cert (xs :: [*]). WithArrivalTime cert -> PerasQry xs SlotNo
perasCertArrivalSlot WithArrivalTime cert
cert = ExceptT PerasQryException (Reader (Summary xs)) SlotNo
-> PerasQry xs SlotNo
forall (xs :: [*]) a.
ExceptT PerasQryException (Reader (Summary xs)) a -> PerasQry xs a
PerasQry (ExceptT PerasQryException (Reader (Summary xs)) SlotNo
 -> PerasQry xs SlotNo)
-> ExceptT PerasQryException (Reader (Summary xs)) SlotNo
-> PerasQry xs SlotNo
forall a b. (a -> b) -> a -> b
$ do
  summary <- ExceptT PerasQryException (Reader (Summary xs)) (Summary xs)
forall r (m :: * -> *). MonadReader r m => m r
ask
  case HF.runQuery (HF.wallclockToSlot (getArrivalTime cert)) summary of
    Left PastHorizonException
pastHorizon ->
      PerasQryException
-> ExceptT PerasQryException (Reader (Summary xs)) SlotNo
forall a.
PerasQryException
-> ExceptT PerasQryException (Reader (Summary xs)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PastHorizonException -> PerasQryException
PerasQryExceptionPastHorizon PastHorizonException
pastHorizon)
    Right (SlotNo
slotNo, NominalDiffTime
_, NominalDiffTime
_) ->
      SlotNo -> ExceptT PerasQryException (Reader (Summary xs)) SlotNo
forall a. a -> ExceptT PerasQryException (Reader (Summary xs)) a
forall (m :: * -> *) a. Monad m => a -> m a
return SlotNo
slotNo

-- | Slot number at the start of a Peras round
perasRoundStart ::
  PerasRoundNo ->
  PerasQry xs SlotNo
perasRoundStart :: forall (xs :: [*]). PerasRoundNo -> PerasQry xs SlotNo
perasRoundStart PerasRoundNo
roundNo = ExceptT PerasQryException (Reader (Summary xs)) SlotNo
-> PerasQry xs SlotNo
forall (xs :: [*]) a.
ExceptT PerasQryException (Reader (Summary xs)) a -> PerasQry xs a
PerasQry (ExceptT PerasQryException (Reader (Summary xs)) SlotNo
 -> PerasQry xs SlotNo)
-> ExceptT PerasQryException (Reader (Summary xs)) SlotNo
-> PerasQry xs SlotNo
forall a b. (a -> b) -> a -> b
$ do
  summary <- ExceptT PerasQryException (Reader (Summary xs)) (Summary xs)
forall r (m :: * -> *). MonadReader r m => m r
ask
  case HF.runQuery (HF.perasRoundNoToSlot roundNo) summary of
    Left PastHorizonException
pastHorizon ->
      PerasQryException
-> ExceptT PerasQryException (Reader (Summary xs)) SlotNo
forall a.
PerasQryException
-> ExceptT PerasQryException (Reader (Summary xs)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PastHorizonException -> PerasQryException
PerasQryExceptionPastHorizon PastHorizonException
pastHorizon)
    Right PerasEnabled (SlotNo, PerasRoundLength)
NoPerasEnabled ->
      PerasQryException
-> ExceptT PerasQryException (Reader (Summary xs)) SlotNo
forall a.
PerasQryException
-> ExceptT PerasQryException (Reader (Summary xs)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PerasQryException
PerasQryExceptionPerasDisabled
    Right (PerasEnabled (SlotNo
slotNo, PerasRoundLength
_)) ->
      SlotNo -> ExceptT PerasQryException (Reader (Summary xs)) SlotNo
forall a. a -> ExceptT PerasQryException (Reader (Summary xs)) a
forall (m :: * -> *) a. Monad m => a -> m a
return SlotNo
slotNo

-- | Chain prefix leading to the candidate block.
--
-- This corresponds to the last block /before/ the candidate slot horizon,
-- defined as the slot that is at least 'blockMinSlots' (L) old from the start
-- of the current round.
--
-- NOTE: this is where the candidate is determined according to CIP-0140.
-- This function may evolve in the future if the candidate block selection
-- becomes more complex.
perasChainAtCandidateBlock ::
  GetHeader blk =>
  PerasBlockMinSlots ->
  PerasRoundNo ->
  AnchoredFragment (Header blk) ->
  PerasQry xs (AnchoredFragment (Header blk))
perasChainAtCandidateBlock :: forall blk (xs :: [*]).
GetHeader blk =>
PerasBlockMinSlots
-> PerasRoundNo
-> AnchoredFragment (Header blk)
-> PerasQry xs (AnchoredFragment (Header blk))
perasChainAtCandidateBlock PerasBlockMinSlots
blockMinSlots PerasRoundNo
currRoundNo AnchoredFragment (Header blk)
currChain = do
  -- Slot number at the start of the current round
  currRoundStart <- PerasRoundNo -> PerasQry xs SlotNo
forall (xs :: [*]). PerasRoundNo -> PerasQry xs SlotNo
perasRoundStart PerasRoundNo
currRoundNo
  -- Minimum number of slots to consider before the candidate block
  let _L = Word64 -> SlotNo
SlotNo (PerasBlockMinSlots -> Word64
unPerasBlockMinSlots PerasBlockMinSlots
blockMinSlots)
  -- Determine the candidate slot horizon
  -- NOTE: here we need make sure that the result doesn't underflow
  let candidateSlotHorizon
        | SlotNo
currRoundStart SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
_L = SlotNo
currRoundStart SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
_L
        | Bool
otherwise = Word64 -> SlotNo
SlotNo Word64
0
  -- Split the chain at the candidate slot horizon
  pure $ fst $ AF.splitAtSlot candidateSlotHorizon currChain

{-------------------------------------------------------------------------------
  Voting interface
-------------------------------------------------------------------------------}

-- | View of the latest certificate seen by the voter
--
-- NOTE: the voting rules depend on the candidate block indirectly. This is
-- reflected in the fact that the voting view does not contain the candidate
-- block or its point, but only whether the candidate block extends the block
-- boosted by the most recent certificate seen by the voter, which is provided
-- to the rules via 'lcsCandidateBlockExtendsCert' here.
data LatestCertSeenView cert
  = LatestCertSeenView
  { forall cert. LatestCertSeenView cert -> cert
lcsCert :: !cert
  -- ^ Latest certificate seen by the voter
  , forall cert. LatestCertSeenView cert -> SlotNo
lcsArrivalSlot :: !SlotNo
  -- ^ Slot number at which this certificate was received
  , forall cert. LatestCertSeenView cert -> SlotNo
lcsRoundStartSlot :: !SlotNo
  -- ^ Starting slot number of the round where this certificate was received
  , forall cert. LatestCertSeenView cert -> Bool
lcsCandidateBlockExtendsCert :: !Bool
  -- ^ Does the candidate block extend the one boosted by this certificate?
  }
  deriving Int -> LatestCertSeenView cert -> ShowS
[LatestCertSeenView cert] -> ShowS
LatestCertSeenView cert -> String
(Int -> LatestCertSeenView cert -> ShowS)
-> (LatestCertSeenView cert -> String)
-> ([LatestCertSeenView cert] -> ShowS)
-> Show (LatestCertSeenView cert)
forall cert. Show cert => Int -> LatestCertSeenView cert -> ShowS
forall cert. Show cert => [LatestCertSeenView cert] -> ShowS
forall cert. Show cert => LatestCertSeenView cert -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall cert. Show cert => Int -> LatestCertSeenView cert -> ShowS
showsPrec :: Int -> LatestCertSeenView cert -> ShowS
$cshow :: forall cert. Show cert => LatestCertSeenView cert -> String
show :: LatestCertSeenView cert -> String
$cshowList :: forall cert. Show cert => [LatestCertSeenView cert] -> ShowS
showList :: [LatestCertSeenView cert] -> ShowS
Show

-- | View of the latest certificate present in our preferred chain
--
-- NOTE: if we add more fields here in the future, do not forget to add
-- strictness annotations as needed.
newtype LatestCertOnChainView cert
  = LatestCertOnChainView
  { forall cert. LatestCertOnChainView cert -> cert
lcocCert :: cert
  -- ^ Latest certificate present in our preferred chain
  }
  deriving Int -> LatestCertOnChainView cert -> ShowS
[LatestCertOnChainView cert] -> ShowS
LatestCertOnChainView cert -> String
(Int -> LatestCertOnChainView cert -> ShowS)
-> (LatestCertOnChainView cert -> String)
-> ([LatestCertOnChainView cert] -> ShowS)
-> Show (LatestCertOnChainView cert)
forall cert.
Show cert =>
Int -> LatestCertOnChainView cert -> ShowS
forall cert. Show cert => [LatestCertOnChainView cert] -> ShowS
forall cert. Show cert => LatestCertOnChainView cert -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall cert.
Show cert =>
Int -> LatestCertOnChainView cert -> ShowS
showsPrec :: Int -> LatestCertOnChainView cert -> ShowS
$cshow :: forall cert. Show cert => LatestCertOnChainView cert -> String
show :: LatestCertOnChainView cert -> String
$cshowList :: forall cert. Show cert => [LatestCertOnChainView cert] -> ShowS
showList :: [LatestCertOnChainView cert] -> ShowS
Show

-- | Interface needed to evaluate the Peras voting rules
--
-- NOTE: the voting rules depend on the candidate block indirectly. This is
-- reflected in the fact that the voting view does not contain the candidate
-- block or its point, but only whether the candidate block extends the block
-- boosted by the most recent certificate seen by the voter, which is provided
-- to the rules via 'lcsCandidateBlockExtendsCert' inside 'latestCertSeen'.
data PerasVotingView cert = PerasVotingView
  { forall cert. PerasVotingView cert -> PerasParams
perasParams :: PerasParams
  -- ^ Peras protocol parameters
  , forall cert. PerasVotingView cert -> PerasRoundNo
currRoundNo :: !PerasRoundNo
  -- ^ The current Peras round number
  , forall cert.
PerasVotingView cert -> WithOrigin (LatestCertSeenView cert)
latestCertSeen :: !(WithOrigin (LatestCertSeenView cert))
  -- ^ The most recent certificate seen by the voter
  , forall cert.
PerasVotingView cert -> WithOrigin (LatestCertOnChainView cert)
latestCertOnChain :: !(WithOrigin (LatestCertOnChainView cert))
  -- ^ The most recent certificate present in our preferred chain
  }
  deriving Int -> PerasVotingView cert -> ShowS
[PerasVotingView cert] -> ShowS
PerasVotingView cert -> String
(Int -> PerasVotingView cert -> ShowS)
-> (PerasVotingView cert -> String)
-> ([PerasVotingView cert] -> ShowS)
-> Show (PerasVotingView cert)
forall cert. Show cert => Int -> PerasVotingView cert -> ShowS
forall cert. Show cert => [PerasVotingView cert] -> ShowS
forall cert. Show cert => PerasVotingView cert -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall cert. Show cert => Int -> PerasVotingView cert -> ShowS
showsPrec :: Int -> PerasVotingView cert -> ShowS
$cshow :: forall cert. Show cert => PerasVotingView cert -> String
show :: PerasVotingView cert -> String
$cshowList :: forall cert. Show cert => [PerasVotingView cert] -> ShowS
showList :: [PerasVotingView cert] -> ShowS
Show

-- | Indicate the status of a block boosted by a certificate w.r.t. the
-- chain's immutable prefix and volatile suffix.
data WithBoostedBlockStatus cert
  = -- | Certificate boosting a block within the immutable prefix
    CertWithImmutableBlock cert
  | -- | Certificate boosting a block within the volatile suffix
    CertWithVolatileBlock cert
  deriving Int -> WithBoostedBlockStatus cert -> ShowS
[WithBoostedBlockStatus cert] -> ShowS
WithBoostedBlockStatus cert -> String
(Int -> WithBoostedBlockStatus cert -> ShowS)
-> (WithBoostedBlockStatus cert -> String)
-> ([WithBoostedBlockStatus cert] -> ShowS)
-> Show (WithBoostedBlockStatus cert)
forall cert.
Show cert =>
Int -> WithBoostedBlockStatus cert -> ShowS
forall cert. Show cert => [WithBoostedBlockStatus cert] -> ShowS
forall cert. Show cert => WithBoostedBlockStatus cert -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall cert.
Show cert =>
Int -> WithBoostedBlockStatus cert -> ShowS
showsPrec :: Int -> WithBoostedBlockStatus cert -> ShowS
$cshow :: forall cert. Show cert => WithBoostedBlockStatus cert -> String
show :: WithBoostedBlockStatus cert -> String
$cshowList :: forall cert. Show cert => [WithBoostedBlockStatus cert] -> ShowS
showList :: [WithBoostedBlockStatus cert] -> ShowS
Show

-- | Deconstruct a certificate from its provenance wrapper
forgetBoostedBlockStatus :: WithBoostedBlockStatus cert -> cert
forgetBoostedBlockStatus :: forall cert. WithBoostedBlockStatus cert -> cert
forgetBoostedBlockStatus = \case
  CertWithVolatileBlock cert
cert -> cert
cert
  CertWithImmutableBlock cert
cert -> cert
cert

-- | Construct a 'PerasVotingView'.
--
-- NOTE: this assumes that the client code computes all the needed inputs
-- within the same STM transaction, or the results may be inconsistent.
mkPerasVotingView ::
  ( cert ~ WithArrivalTime (ValidatedPerasCert blk)
  , GetHeader blk
  ) =>
  -- | Peras protocol parameters
  PerasParams ->
  -- | Current Peras round number
  PerasRoundNo ->
  -- | Most recent certificate seen by the voter
  WithOrigin (WithBoostedBlockStatus cert) ->
  -- | Most recent certificate included in some block in our preferred chain
  WithOrigin cert ->
  -- | Prefix leading to the candidate block in the volatile suffix of our
  -- preferred chain
  AnchoredFragment (Header blk) ->
  -- | Constructed voting view
  PerasQry xs (PerasVotingView cert)
mkPerasVotingView :: forall cert blk (xs :: [*]).
(cert ~ WithArrivalTime (ValidatedPerasCert blk), GetHeader blk) =>
PerasParams
-> PerasRoundNo
-> WithOrigin (WithBoostedBlockStatus cert)
-> WithOrigin cert
-> AnchoredFragment (Header blk)
-> PerasQry xs (PerasVotingView cert)
mkPerasVotingView
  PerasParams
perasParams
  PerasRoundNo
currRoundNo
  WithOrigin (WithBoostedBlockStatus cert)
latestCertSeen
  WithOrigin cert
latestCertOnChain
  AnchoredFragment (Header blk)
chainAtCandidateBlock = do
    latestCertSeenView <- (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
 -> PerasQry
      xs (LatestCertSeenView (WithArrivalTime (ValidatedPerasCert blk))))
-> WithOrigin
     (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
-> PerasQry
     xs
     (WithOrigin
        (LatestCertSeenView (WithArrivalTime (ValidatedPerasCert blk))))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> WithOrigin a -> f (WithOrigin b)
traverse WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
-> PerasQry
     xs (LatestCertSeenView (WithArrivalTime (ValidatedPerasCert blk)))
mkLatestCertSeenView WithOrigin (WithBoostedBlockStatus cert)
WithOrigin
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen
    latestCertOnChainView <- traverse mkLatestCertOnChainView latestCertOnChain
    pure $
      PerasVotingView
        { perasParams = perasParams
        , currRoundNo = currRoundNo
        , latestCertSeen = latestCertSeenView
        , latestCertOnChain = latestCertOnChainView
        }
   where
    mkLatestCertSeenView :: WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
-> PerasQry
     xs (LatestCertSeenView (WithArrivalTime (ValidatedPerasCert blk)))
mkLatestCertSeenView WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
certWithProvenance = do
      let lcsCert :: WithArrivalTime (ValidatedPerasCert blk)
lcsCert = WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
-> WithArrivalTime (ValidatedPerasCert blk)
forall cert. WithBoostedBlockStatus cert -> cert
forgetBoostedBlockStatus WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
certWithProvenance
      lcsArrivalSlot <- WithArrivalTime (ValidatedPerasCert blk) -> PerasQry xs SlotNo
forall cert (xs :: [*]). WithArrivalTime cert -> PerasQry xs SlotNo
perasCertArrivalSlot WithArrivalTime (ValidatedPerasCert blk)
lcsCert
      lcsRoundStartSlot <- perasRoundStart (getPerasCertRound lcsCert)
      let lcsCandidateBlockExtendsCert = WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
-> Bool
candidateBlockExtendsCert WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
certWithProvenance
      pure $
        LatestCertSeenView
          { lcsCert
          , lcsArrivalSlot
          , lcsRoundStartSlot
          , lcsCandidateBlockExtendsCert
          }

    mkLatestCertOnChainView :: cert -> f (LatestCertOnChainView cert)
mkLatestCertOnChainView cert
lcocCert =
      LatestCertOnChainView cert -> f (LatestCertOnChainView cert)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LatestCertOnChainView cert -> f (LatestCertOnChainView cert))
-> LatestCertOnChainView cert -> f (LatestCertOnChainView cert)
forall a b. (a -> b) -> a -> b
$
        LatestCertOnChainView
          { cert
lcocCert :: cert
lcocCert :: cert
lcocCert
          }

    -- Does the candidate block extend the one boosted by a certificate?
    --
    -- This can be trivially tested by checking whether the certificate is
    -- within the bounds of the volatile chain prefix leading to the candidate
    -- block. Conversely, the case of a certificate pointing to a block that's
    -- too new to be voted for is also covered by this logic, as it won't be
    -- part of the 'chainAtCandidateBlock' fragment.
    --
    -- NOTE: the case of an extremely old certificate boosting a block beyond
    -- the volatile suffix is covered by also providing the status of the
    -- boosted block w.r.t. the chain's immutable prefix and volatile suffix.
    candidateBlockExtendsCert :: WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
-> Bool
candidateBlockExtendsCert (CertWithImmutableBlock WithArrivalTime (ValidatedPerasCert blk)
_) =
      -- This case is vacuously true: an immutable block is always part of
      -- any volatile suffix, so the candidate block trivially extends it.
      Bool
True
    candidateBlockExtendsCert (CertWithVolatileBlock WithArrivalTime (ValidatedPerasCert blk)
cert) =
      -- Check whether the boosted block is within the volatile fragment leading
      -- to the candidate block.
      Point (Header blk) -> AnchoredFragment (Header blk) -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds
        (Point blk -> Point (Header blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (WithArrivalTime (ValidatedPerasCert blk) -> Point blk
forall cert blk.
HasPerasCertBoostedBlock cert blk =>
cert -> Point blk
getPerasCertBoostedBlock WithArrivalTime (ValidatedPerasCert blk)
cert))
        AnchoredFragment (Header blk)
chainAtCandidateBlock