{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# 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 (..)
  , PerasVotingView (..)
  , WithBoostedBlockStatus (..)
  , mkPerasVotingView
  , PerasVotingViewHandle (..)
  )
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
  , Point
  , SlotNo (..)
  , castPoint
  )
import Ouroboros.Consensus.Block.SupportsPeras
  ( BlockSupportsPeras (..)
  , IsPerasCert (..)
  , PerasRoundNo (..)
  , ValidatedPerasCert
  )
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.Consensus.Storage.PerasCertDB.API
  ( WithBoostedBlockStatus (..)
  , forgetBoostedBlockStatus
  )
import Ouroboros.Consensus.Util.IOLike (MonadSTM (..))
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

-- | Interface needed to evaluate the Peras voting rules
--
-- NOTE: the voting rules depend on the candidate block only indirectly. The
-- only reason to include the point of the block being voted for
-- ('candidateBlock') here is to be able to return it as part of the result of
-- 'isPerasVotingAllowed' in the positive case.
data PerasVotingView cert blk = PerasVotingView
  { forall cert blk. PerasVotingView cert blk -> PerasParams blk
perasParams :: !(PerasParams blk)
  -- ^ Peras protocol parameters
  , forall cert blk. PerasVotingView cert blk -> PerasRoundNo
currRoundNo :: !PerasRoundNo
  -- ^ The current Peras round number
  , forall cert blk.
PerasVotingView cert blk -> WithOrigin (LatestCertSeenView cert)
latestCertSeen :: !(WithOrigin (LatestCertSeenView cert))
  -- ^ The most recent certificate seen by the voter
  , forall cert blk.
PerasVotingView cert blk -> WithOrigin PerasRoundNo
latestCertOnChainRound :: !(WithOrigin PerasRoundNo)
  -- ^ 'PerasRoundNo' of the latest certificate present in our preferred chain
  -- (we don't actually need the whole certificate here).
  , forall cert blk. PerasVotingView cert blk -> Point blk
candidateBlock :: Point blk
  -- ^ The candidate block being voted for.
  --
  -- NOTE: this is the tip of the 'chainAtCandidateBlock' used to initialize
  -- the voting view.
  }
  deriving Int -> PerasVotingView cert blk -> ShowS
[PerasVotingView cert blk] -> ShowS
PerasVotingView cert blk -> String
(Int -> PerasVotingView cert blk -> ShowS)
-> (PerasVotingView cert blk -> String)
-> ([PerasVotingView cert blk] -> ShowS)
-> Show (PerasVotingView cert blk)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall cert blk.
(StandardHash blk, Show cert) =>
Int -> PerasVotingView cert blk -> ShowS
forall cert blk.
(StandardHash blk, Show cert) =>
[PerasVotingView cert blk] -> ShowS
forall cert blk.
(StandardHash blk, Show cert) =>
PerasVotingView cert blk -> String
$cshowsPrec :: forall cert blk.
(StandardHash blk, Show cert) =>
Int -> PerasVotingView cert blk -> ShowS
showsPrec :: Int -> PerasVotingView cert blk -> ShowS
$cshow :: forall cert blk.
(StandardHash blk, Show cert) =>
PerasVotingView cert blk -> String
show :: PerasVotingView cert blk -> String
$cshowList :: forall cert blk.
(StandardHash blk, Show cert) =>
[PerasVotingView cert blk] -> ShowS
showList :: [PerasVotingView cert blk] -> ShowS
Show

-- | 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
  , IsPerasCert (PerasCert blk) blk
  ) =>
  -- | Peras protocol parameters
  PerasParams blk ->
  -- | Current Peras round number
  PerasRoundNo ->
  -- | Most recent certificate seen by the voter
  WithOrigin (WithBoostedBlockStatus cert) ->
  -- | 'PerasRoundNo' of the most recent certificate included in some block in
  -- our preferred chain
  WithOrigin PerasRoundNo ->
  -- | Prefix leading to the candidate block in the volatile suffix of our
  -- preferred chain
  AnchoredFragment (Header blk) ->
  -- | Constructed voting view
  PerasQry xs (PerasVotingView cert blk)
mkPerasVotingView :: forall cert blk (xs :: [*]).
(cert ~ WithArrivalTime (ValidatedPerasCert blk), GetHeader blk,
 IsPerasCert (PerasCert blk) blk) =>
PerasParams blk
-> PerasRoundNo
-> WithOrigin (WithBoostedBlockStatus cert)
-> WithOrigin PerasRoundNo
-> AnchoredFragment (Header blk)
-> PerasQry xs (PerasVotingView cert blk)
mkPerasVotingView
  PerasParams blk
perasParams
  PerasRoundNo
currRoundNo
  WithOrigin (WithBoostedBlockStatus cert)
latestCertSeen
  WithOrigin PerasRoundNo
latestCertOnChainRound
  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
    pure $
      PerasVotingView
        { perasParams = perasParams
        , currRoundNo = currRoundNo
        , latestCertSeen = latestCertSeenView
        , latestCertOnChainRound = latestCertOnChainRound
        , candidateBlock = candidateBlock
        }
   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
          }

    -- 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 volatile suffix.
    candidateBlockExtendsCert :: WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
-> Bool
candidateBlockExtendsCert (CertBoostingBlockNoLongerInVolatileDB WithArrivalTime (ValidatedPerasCert blk)
_) =
      -- This case is vacuously true: the boosted block is from a slot that has
      -- already been garbage collected from the volatile suffix, which implies
      -- that it extends any volatile suffix.
      Bool
True
    candidateBlockExtendsCert (CertBoostingBlockInVolatileDB WithArrivalTime (ValidatedPerasCert blk)
cert) =
      -- The block boosted by the latest certificate seen is still in the
      -- VolatileDB, so we can check whether it is within the bounds of the
      -- anchored 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. IsPerasCert cert blk => cert -> Point blk
getPerasCertPoint WithArrivalTime (ValidatedPerasCert blk)
cert))
        AnchoredFragment (Header blk)
chainAtCandidateBlock

    candidateBlock :: Point blk
candidateBlock =
      Anchor blk -> Point blk
forall block. Anchor block -> Point block
AF.anchorToPoint
        (Anchor blk -> Point blk)
-> (AnchoredFragment (Header blk) -> Anchor blk)
-> AnchoredFragment (Header blk)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor (Header blk) -> Anchor blk
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor
        (Anchor (Header blk) -> Anchor blk)
-> (AnchoredFragment (Header blk) -> Anchor (Header blk))
-> AnchoredFragment (Header blk)
-> Anchor blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AF.headAnchor
        (AnchoredFragment (Header blk) -> Point blk)
-> AnchoredFragment (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk)
chainAtCandidateBlock

-- | Handle for querying the Peras voting view via STM.
newtype PerasVotingViewHandle m blk
  = PerasVotingViewHandle
      ( PerasRoundNo ->
        STM m (PerasVotingView (WithArrivalTime (ValidatedPerasCert blk)) blk)
      )