{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- TODO: remove this after getting rid of the degenerate 'BlockSupportsPeras'
-- instance that renders some of the constraints here redundant.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Ouroboros.Consensus.Peras.Context
  ( -- * Bounded Peras epoch context
    BoundedPerasEpochContext (..)
  , withinEpochContext

    -- * Peras epoch context resolver and handle
  , PerasEpochContextResolver (..)
  , PerasEpochContextNotFoundForRound (..)
  , resolveRoundNo
  , perasEpochContextResolverBounds
  , PerasEpochContextResolverHandle (..)
  , mockPerasEpochContextResolverHandle
  , withResolvedRoundNo

    -- * Extracting and resolving Peras epoch contexts from the node state
  , StateSupportsPerasEpochContext (..)
  , mkBoundedPerasEpochContextWith
  , initPerasEpochContextResolver
  , tickPerasEpochContextResolver

    -- * Time resolution
  , TimeResolutionContext (..)
  , runQueryWithContext
  , runQueryEraIndexedWithContext
  , TimeResolutionContextHandle (..)
  , runQueryWithContextHandle

    -- * Next-epoch detection
  , EpochCrossing (..)
  , DetectNextEpochError
  , isNextEpoch
  )
where

import Cardano.Binary
  ( FromCBOR (..)
  , ToCBOR (..)
  , decodeListLen
  , decodeListLenOf
  , encodeListLen
  )
import Cardano.Prelude (maybeToEither)
import Control.Exception (Exception)
import Control.Monad.Class.MonadSTM (STM)
import Data.Bifunctor (Bifunctor (..))
import qualified Data.ByteString.Char8 as ByteString
import Data.Data (Proxy (..))
import Data.Kind (Type)
import Data.SOP (HCollapse (..), K (..))
import Data.SOP.Constraint (All, Top)
import Data.SOP.Index (himap, injectNS)
import Data.Typeable (Typeable)
import Data.Word (Word8)
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block.Abstract
  ( BlockProtocol
  , EpochNo (..)
  , SlotNo
  , WithOrigin (..)
  )
import Ouroboros.Consensus.Block.SupportsPeras
  ( BlockSupportsPeras (..)
  , IsPerasError (..)
  , PerasEpochContext (..)
  , PerasRoundNo
  , PerasVotingCommittee
  , PerasVotingCommitteeInput
  )
import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee)
import qualified Ouroboros.Consensus.Committee.Class as Committee
import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..))
import Ouroboros.Consensus.HardFork.History.Qry
  ( EpochToPerasRoundInfo (..)
  , EraIndexed (..)
  , PastHorizonException
  , Qry
  , epochToPerasRoundInfo
  , runQuery
  , runQueryEraIndexed
  , slotToEpoch'
  )
import Ouroboros.Consensus.HeaderValidation
  ( HeaderState
  , Ticked
  , annTipSlotNo
  , headerStateTip
  )
import Ouroboros.Consensus.Ledger.Abstract (EmptyMK, LedgerConfig, LedgerState)
import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras (..))
import Ouroboros.Consensus.Peras.Params
  ( PerasEnabled
  , perasEnabledToMaybe
  , pattern NoPerasEnabled
  , pattern PerasEnabled
  )
import Ouroboros.Consensus.Protocol.Abstract
  ( ChainDepStateSupportsPeras
  , ConsensusProtocol (..)
  )
import Ouroboros.Consensus.Storage.Serialisation
  ( DecodeDisk (..)
  , EncodeDisk (..)
  )
import Ouroboros.Consensus.Util.IOLike
  ( IOLike
  , MonadSTM
  , MonadThrow
  , NoThunks (..)
  , newTVarIO
  , readTVar
  , throwSTM
  )

-- * Bounded Peras epoch context

-- | A 'PerasEpochContext' that is valid only in a given range of round numbers
data BoundedPerasEpochContext blk
  = BoundedPerasEpochContext
  { forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
startPerasRoundNo :: PerasRoundNo
  -- ^ Inclusive lower bound
  , forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
endPerasRoundNo :: PerasRoundNo
  -- ^ Exclusive upper bound
  , forall blk. BoundedPerasEpochContext blk -> PerasEpochContext blk
epochContext :: PerasEpochContext blk
  -- ^ Epcoh context that is valid within the given bounds
  }

deriving instance
  Show (PerasEpochContext blk) =>
  Show (BoundedPerasEpochContext blk)
deriving instance
  Eq (PerasEpochContext blk) =>
  Eq (BoundedPerasEpochContext blk)
deriving instance
  NoThunks (PerasEpochContext blk) =>
  NoThunks (BoundedPerasEpochContext blk)
deriving instance
  Generic (BoundedPerasEpochContext blk)

instance
  ( Typeable blk
  , FromCBOR (PerasVotingCommittee blk)
  ) =>
  FromCBOR (BoundedPerasEpochContext blk)
  where
  fromCBOR :: forall s. Decoder s (BoundedPerasEpochContext blk)
fromCBOR = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
3
    startPerasRoundNo <- Decoder s PerasRoundNo
forall s. Decoder s PerasRoundNo
forall a s. FromCBOR a => Decoder s a
fromCBOR
    endPerasRoundNo <- fromCBOR
    epochContext <- fromCBOR
    pure
      BoundedPerasEpochContext
        { startPerasRoundNo
        , endPerasRoundNo
        , epochContext
        }

instance
  ( Typeable blk
  , ToCBOR (PerasVotingCommittee blk)
  ) =>
  ToCBOR (BoundedPerasEpochContext blk)
  where
  toCBOR :: BoundedPerasEpochContext blk -> Encoding
toCBOR
    BoundedPerasEpochContext
      { PerasRoundNo
startPerasRoundNo :: forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
startPerasRoundNo :: PerasRoundNo
startPerasRoundNo
      , PerasRoundNo
endPerasRoundNo :: forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
endPerasRoundNo :: PerasRoundNo
endPerasRoundNo
      , PerasEpochContext blk
epochContext :: forall blk. BoundedPerasEpochContext blk -> PerasEpochContext blk
epochContext :: PerasEpochContext blk
epochContext
      } =
      Word -> Encoding
encodeListLen Word
3
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasRoundNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PerasRoundNo
startPerasRoundNo
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasRoundNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PerasRoundNo
endPerasRoundNo
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasEpochContext blk -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PerasEpochContext blk
epochContext

instance
  FromCBOR (BoundedPerasEpochContext blk) =>
  DecodeDisk blk (BoundedPerasEpochContext blk)
  where
  decodeDisk :: CodecConfig blk
-> forall s. Decoder s (BoundedPerasEpochContext blk)
decodeDisk CodecConfig blk
_ccfg = Decoder s (BoundedPerasEpochContext blk)
forall s. Decoder s (BoundedPerasEpochContext blk)
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance
  ToCBOR (BoundedPerasEpochContext blk) =>
  EncodeDisk blk (BoundedPerasEpochContext blk)
  where
  encodeDisk :: CodecConfig blk -> BoundedPerasEpochContext blk -> Encoding
encodeDisk CodecConfig blk
_ccfg = BoundedPerasEpochContext blk -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR

-- | Check whether a given 'PerasRoundNo' is within the bounds of a
-- 'BoundedPerasEpochContext'.
--
-- Returns the corresponding 'PerasEpochContext' if the round number is within
-- the bounds, or 'Nothing' otherwise.
withinEpochContext ::
  PerasRoundNo ->
  BoundedPerasEpochContext blk ->
  Maybe (PerasEpochContext blk)
withinEpochContext :: forall blk.
PerasRoundNo
-> BoundedPerasEpochContext blk -> Maybe (PerasEpochContext blk)
withinEpochContext PerasRoundNo
roundNo BoundedPerasEpochContext blk
boundedContext
  | PerasRoundNo
roundNo PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
>= BoundedPerasEpochContext blk -> PerasRoundNo
forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
startPerasRoundNo BoundedPerasEpochContext blk
boundedContext
      Bool -> Bool -> Bool
&& PerasRoundNo
roundNo PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
< BoundedPerasEpochContext blk -> PerasRoundNo
forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
endPerasRoundNo BoundedPerasEpochContext blk
boundedContext =
      PerasEpochContext blk -> Maybe (PerasEpochContext blk)
forall a. a -> Maybe a
Just (BoundedPerasEpochContext blk -> PerasEpochContext blk
forall blk. BoundedPerasEpochContext blk -> PerasEpochContext blk
epochContext BoundedPerasEpochContext blk
boundedContext)
  | Bool
otherwise =
      Maybe (PerasEpochContext blk)
forall a. Maybe a
Nothing

-- * Peras epoch context resolver (and handle)

-- | A two-epoch window of Peras epoch contexts, which can be used to resolve
-- round numbers into their corresponding Peras contexts.
data PerasEpochContextResolver blk
  = -- | The resolver is in an error state, and cannot resolve any round number.
    --
    -- NOTE: this exists to allow for recoverable errors during resolver
    -- initialisation or ticking caused, e.g., by incorrect parameterization.
    PerasEpochContextResolverError
      !String
  | -- | The resolver has a two-epoch window of Peras epoch contexts, which may
    -- be empty if Peras is not enabled in either of these epochs.
    PerasEpochContextResolver
      -- | Current epoch context
      !(PerasEnabled (BoundedPerasEpochContext blk))
      -- | Previous epoch context
      !(PerasEnabled (BoundedPerasEpochContext blk))

deriving instance
  Show (PerasEpochContext blk) =>
  Show (PerasEpochContextResolver blk)
deriving instance
  Eq (PerasEpochContext blk) =>
  Eq (PerasEpochContextResolver blk)
deriving instance
  NoThunks (PerasEpochContext blk) =>
  NoThunks (PerasEpochContextResolver blk)
deriving instance
  Generic (PerasEpochContextResolver blk)

instance
  ( Typeable blk
  , FromCBOR (PerasVotingCommittee blk)
  ) =>
  FromCBOR (PerasEpochContextResolver blk)
  where
  fromCBOR :: forall s. Decoder s (PerasEpochContextResolver blk)
fromCBOR = do
    len <- Decoder s Int
forall s. Decoder s Int
decodeListLen
    tag <- fromCBOR @Word8
    case (len, tag) of
      (Int
2, Word8
0) -> do
        reason <- ByteString -> String
ByteString.unpack (ByteString -> String) -> Decoder s ByteString -> Decoder s String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ByteString
forall s. Decoder s ByteString
forall a s. FromCBOR a => Decoder s a
fromCBOR
        pure $ PerasEpochContextResolverError reason
      (Int
3, Word8
1) -> do
        curr <- Decoder s (PerasEnabled (BoundedPerasEpochContext blk))
forall s. Decoder s (PerasEnabled (BoundedPerasEpochContext blk))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        prev <- fromCBOR
        pure $ PerasEpochContextResolver curr prev
      (Int, Word8)
_ ->
        String -> Decoder s (PerasEpochContextResolver blk)
forall a. HasCallStack => String -> Decoder s a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail (String -> Decoder s (PerasEpochContextResolver blk))
-> String -> Decoder s (PerasEpochContextResolver blk)
forall a b. (a -> b) -> a -> b
$
          String
"PerasEpochContextResolver: unexpected list length and tag: "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int, Word8) -> String
forall a. Show a => a -> String
show (Int
len, Word8
tag)

instance
  ( Typeable blk
  , ToCBOR (PerasVotingCommittee blk)
  ) =>
  ToCBOR (PerasEpochContextResolver blk)
  where
  toCBOR :: PerasEpochContextResolver blk -> Encoding
toCBOR = \case
    PerasEpochContextResolverError String
reason ->
      Word -> Encoding
encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
0 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (String -> ByteString
ByteString.pack String
reason)
    PerasEpochContextResolver PerasEnabled (BoundedPerasEpochContext blk)
curr PerasEnabled (BoundedPerasEpochContext blk)
prev ->
      Word -> Encoding
encodeListLen Word
3
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
1 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasEnabled (BoundedPerasEpochContext blk) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PerasEnabled (BoundedPerasEpochContext blk)
curr
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasEnabled (BoundedPerasEpochContext blk) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PerasEnabled (BoundedPerasEpochContext blk)
prev

instance
  FromCBOR (PerasEpochContextResolver blk) =>
  DecodeDisk blk (PerasEpochContextResolver blk)
  where
  decodeDisk :: CodecConfig blk
-> forall s. Decoder s (PerasEpochContextResolver blk)
decodeDisk CodecConfig blk
_ccfg = Decoder s (PerasEpochContextResolver blk)
forall s. Decoder s (PerasEpochContextResolver blk)
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance
  ToCBOR (PerasEpochContextResolver blk) =>
  EncodeDisk blk (PerasEpochContextResolver blk)
  where
  encodeDisk :: CodecConfig blk -> PerasEpochContextResolver blk -> Encoding
encodeDisk CodecConfig blk
_ccfg = PerasEpochContextResolver blk -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR

-- | An error indicating that a 'PerasEpochContext' could not be found for a
-- given 'PerasRoundNo' in a 'PerasEpochContextResolver'.
data PerasEpochContextNotFoundForRound
  = PerasEpochContextNotFoundForRound
      -- | The round number for which the context could not be found.
      !PerasRoundNo
      -- | Detailed reason for the failure.
      !String
  deriving (PerasEpochContextNotFoundForRound
-> PerasEpochContextNotFoundForRound -> Bool
(PerasEpochContextNotFoundForRound
 -> PerasEpochContextNotFoundForRound -> Bool)
-> (PerasEpochContextNotFoundForRound
    -> PerasEpochContextNotFoundForRound -> Bool)
-> Eq PerasEpochContextNotFoundForRound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PerasEpochContextNotFoundForRound
-> PerasEpochContextNotFoundForRound -> Bool
== :: PerasEpochContextNotFoundForRound
-> PerasEpochContextNotFoundForRound -> Bool
$c/= :: PerasEpochContextNotFoundForRound
-> PerasEpochContextNotFoundForRound -> Bool
/= :: PerasEpochContextNotFoundForRound
-> PerasEpochContextNotFoundForRound -> Bool
Eq, Int -> PerasEpochContextNotFoundForRound -> ShowS
[PerasEpochContextNotFoundForRound] -> ShowS
PerasEpochContextNotFoundForRound -> String
(Int -> PerasEpochContextNotFoundForRound -> ShowS)
-> (PerasEpochContextNotFoundForRound -> String)
-> ([PerasEpochContextNotFoundForRound] -> ShowS)
-> Show PerasEpochContextNotFoundForRound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PerasEpochContextNotFoundForRound -> ShowS
showsPrec :: Int -> PerasEpochContextNotFoundForRound -> ShowS
$cshow :: PerasEpochContextNotFoundForRound -> String
show :: PerasEpochContextNotFoundForRound -> String
$cshowList :: [PerasEpochContextNotFoundForRound] -> ShowS
showList :: [PerasEpochContextNotFoundForRound] -> ShowS
Show, (forall x.
 PerasEpochContextNotFoundForRound
 -> Rep PerasEpochContextNotFoundForRound x)
-> (forall x.
    Rep PerasEpochContextNotFoundForRound x
    -> PerasEpochContextNotFoundForRound)
-> Generic PerasEpochContextNotFoundForRound
forall x.
Rep PerasEpochContextNotFoundForRound x
-> PerasEpochContextNotFoundForRound
forall x.
PerasEpochContextNotFoundForRound
-> Rep PerasEpochContextNotFoundForRound x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
PerasEpochContextNotFoundForRound
-> Rep PerasEpochContextNotFoundForRound x
from :: forall x.
PerasEpochContextNotFoundForRound
-> Rep PerasEpochContextNotFoundForRound x
$cto :: forall x.
Rep PerasEpochContextNotFoundForRound x
-> PerasEpochContextNotFoundForRound
to :: forall x.
Rep PerasEpochContextNotFoundForRound x
-> PerasEpochContextNotFoundForRound
Generic, Context
-> PerasEpochContextNotFoundForRound -> IO (Maybe ThunkInfo)
Proxy PerasEpochContextNotFoundForRound -> String
(Context
 -> PerasEpochContextNotFoundForRound -> IO (Maybe ThunkInfo))
-> (Context
    -> PerasEpochContextNotFoundForRound -> IO (Maybe ThunkInfo))
-> (Proxy PerasEpochContextNotFoundForRound -> String)
-> NoThunks PerasEpochContextNotFoundForRound
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context
-> PerasEpochContextNotFoundForRound -> IO (Maybe ThunkInfo)
noThunks :: Context
-> PerasEpochContextNotFoundForRound -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context
-> PerasEpochContextNotFoundForRound -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> PerasEpochContextNotFoundForRound -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PerasEpochContextNotFoundForRound -> String
showTypeOf :: Proxy PerasEpochContextNotFoundForRound -> String
NoThunks, Show PerasEpochContextNotFoundForRound
Typeable PerasEpochContextNotFoundForRound
(Typeable PerasEpochContextNotFoundForRound,
 Show PerasEpochContextNotFoundForRound) =>
(PerasEpochContextNotFoundForRound -> SomeException)
-> (SomeException -> Maybe PerasEpochContextNotFoundForRound)
-> (PerasEpochContextNotFoundForRound -> String)
-> (PerasEpochContextNotFoundForRound -> Bool)
-> Exception PerasEpochContextNotFoundForRound
SomeException -> Maybe PerasEpochContextNotFoundForRound
PerasEpochContextNotFoundForRound -> Bool
PerasEpochContextNotFoundForRound -> String
PerasEpochContextNotFoundForRound -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: PerasEpochContextNotFoundForRound -> SomeException
toException :: PerasEpochContextNotFoundForRound -> SomeException
$cfromException :: SomeException -> Maybe PerasEpochContextNotFoundForRound
fromException :: SomeException -> Maybe PerasEpochContextNotFoundForRound
$cdisplayException :: PerasEpochContextNotFoundForRound -> String
displayException :: PerasEpochContextNotFoundForRound -> String
$cbacktraceDesired :: PerasEpochContextNotFoundForRound -> Bool
backtraceDesired :: PerasEpochContextNotFoundForRound -> Bool
Exception)

-- | Initialise a 'PerasEpochContextResolver' using a bounded context.
--
-- NOTE: regarding why this function uses a hardcoded 'NoPerasEnabled' for the
-- epoch prior to the one being used to initialize this bounded context: please
-- notice that this function is only used in cases where we don't have
-- information about the previous epoch:
--
--  * When creating a new context resolver from scratch, where we don't have any
--    information about Peras for the previous epoch (there might not even be a
--    previous epoch if we are boostrapping from Genesis).
--
--  * When ticking the resolver out of an error state. This could occur due to
--    bad parameterization leading to an error while creating a voting committee
--    for a given epoch.
--
--  * When ticking the resolver more than one epoch at a time, in which case we
--    cannot faitfully build a context for the previous (gap) epoch. This only
--    happens in tests, though.
--
-- In all these cases, using 'NoPerasEnabled' for the previous epoch is the only
-- safe option, although in the future we might want to make each of the cases
-- mentioned above more explicitly representable.
newPerasEpochContextResolver ::
  PerasEnabled (BoundedPerasEpochContext blk) ->
  PerasEpochContextResolver blk
newPerasEpochContextResolver :: forall blk.
PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
newPerasEpochContextResolver PerasEnabled (BoundedPerasEpochContext blk)
currEpochContext =
  PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
forall blk.
PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
PerasEpochContextResolver
    PerasEnabled (BoundedPerasEpochContext blk)
currEpochContext
    PerasEnabled (BoundedPerasEpochContext blk)
forall a. PerasEnabled a
NoPerasEnabled

-- | Advance a 'PerasEpochContextResolver' to the next epoch, given a new
-- bounded context for the next epoch.
--
-- NOTE: this will recover from an error state, but it will leave the previous
-- epoch context disabled.
advancePerasEpochContextResolver ::
  PerasEpochContextResolver blk ->
  PerasEnabled (BoundedPerasEpochContext blk) ->
  PerasEpochContextResolver blk
advancePerasEpochContextResolver :: forall blk.
PerasEpochContextResolver blk
-> PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
advancePerasEpochContextResolver PerasEpochContextResolver blk
resolver PerasEnabled (BoundedPerasEpochContext blk)
newEpochContext =
  case PerasEpochContextResolver blk
resolver of
    -- The previous resolver is in a valid state => slide the window forward
    PerasEpochContextResolver PerasEnabled (BoundedPerasEpochContext blk)
currEpochContext PerasEnabled (BoundedPerasEpochContext blk)
_prevEpochContext ->
      PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
forall blk.
PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
PerasEpochContextResolver
        PerasEnabled (BoundedPerasEpochContext blk)
newEpochContext
        PerasEnabled (BoundedPerasEpochContext blk)
currEpochContext
    -- The previous resolver is in an error state => re-initialise the window
    PerasEpochContextResolverError{} ->
      PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
forall blk.
PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
newPerasEpochContextResolver
        PerasEnabled (BoundedPerasEpochContext blk)
newEpochContext

-- | Resolve a 'PerasRoundNo' into its corresponding 'PerasEpochContext' using a
-- 'PerasEpochContextResolver'.
--
-- Fails with 'PerasEpochContextNotFoundForRound' if the round number is not
-- within the bounds of either the current or previous epoch context, or if the
-- resolver is in an error state.
resolveRoundNo ::
  PerasEpochContextResolver blk ->
  PerasRoundNo ->
  Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)
resolveRoundNo :: forall blk.
PerasEpochContextResolver blk
-> PerasRoundNo
-> Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)
resolveRoundNo PerasEpochContextResolver blk
resolver PerasRoundNo
roundNo = case PerasEpochContextResolver blk
resolver of
  PerasEpochContextResolverError String
reason ->
    PerasEpochContextNotFoundForRound
-> Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)
forall a b. a -> Either a b
Left (PerasEpochContextNotFoundForRound
 -> Either
      PerasEpochContextNotFoundForRound (PerasEpochContext blk))
-> PerasEpochContextNotFoundForRound
-> Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)
forall a b. (a -> b) -> a -> b
$
      PerasRoundNo -> String -> PerasEpochContextNotFoundForRound
PerasEpochContextNotFoundForRound PerasRoundNo
roundNo String
reason
  PerasEpochContextResolver PerasEnabled (BoundedPerasEpochContext blk)
curr PerasEnabled (BoundedPerasEpochContext blk)
prev ->
    case (String
-> PerasEnabled (BoundedPerasEpochContext blk)
-> Either String (PerasEpochContext blk)
lookupBounded String
"current" PerasEnabled (BoundedPerasEpochContext blk)
curr, String
-> PerasEnabled (BoundedPerasEpochContext blk)
-> Either String (PerasEpochContext blk)
lookupBounded String
"previous" PerasEnabled (BoundedPerasEpochContext blk)
prev) of
      -- The round number is within the bounds of the current epoch context
      (Right PerasEpochContext blk
context, Either String (PerasEpochContext blk)
_) ->
        PerasEpochContext blk
-> Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)
forall a b. b -> Either a b
Right PerasEpochContext blk
context
      -- The round number is within the bounds of the previous epoch context
      (Either String (PerasEpochContext blk)
_, Right PerasEpochContext blk
context) ->
        PerasEpochContext blk
-> Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)
forall a b. b -> Either a b
Right PerasEpochContext blk
context
      -- The round number is not within the bounds of either epoch context
      (Left String
reason1, Left String
reason2) ->
        PerasEpochContextNotFoundForRound
-> Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)
forall a b. a -> Either a b
Left (PerasEpochContextNotFoundForRound
 -> Either
      PerasEpochContextNotFoundForRound (PerasEpochContext blk))
-> PerasEpochContextNotFoundForRound
-> Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)
forall a b. (a -> b) -> a -> b
$
          PerasRoundNo -> String -> PerasEpochContextNotFoundForRound
PerasEpochContextNotFoundForRound PerasRoundNo
roundNo (String
reason1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"; " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
reason2)
 where
  lookupBounded :: String
-> PerasEnabled (BoundedPerasEpochContext blk)
-> Either String (PerasEpochContext blk)
lookupBounded String
name PerasEnabled (BoundedPerasEpochContext blk)
mbContext = do
    boundedContext <-
      String
-> Maybe (BoundedPerasEpochContext blk)
-> Either String (BoundedPerasEpochContext blk)
forall e a. e -> Maybe a -> Either e a
maybeToEither
        (String
"no " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" epoch context available because Peras isn't enabled")
        (PerasEnabled (BoundedPerasEpochContext blk)
-> Maybe (BoundedPerasEpochContext blk)
forall a. PerasEnabled a -> Maybe a
perasEnabledToMaybe PerasEnabled (BoundedPerasEpochContext blk)
mbContext)
    maybeToEither
      ( name
          <> " epoch context available, but roundNo "
          <> show roundNo
          <> " not within "
          <> name
          <> " epoch context bounds ["
          <> show (startPerasRoundNo boundedContext)
          <> ", "
          <> show (endPerasRoundNo boundedContext)
          <> ")"
      )
      (withinEpochContext roundNo boundedContext)

-- | Compute the bounds of the Peras round numbers that are covered by the
-- given 'PerasEpochContextResolver'.
--
-- NOTE: the upper bound is exclusive, thus we return an empty range [0,0) when
-- the resolver doesn't cover any Peras round.
perasEpochContextResolverBounds ::
  PerasEpochContextResolver blk ->
  (PerasRoundNo, PerasRoundNo)
perasEpochContextResolverBounds :: forall blk.
PerasEpochContextResolver blk -> (PerasRoundNo, PerasRoundNo)
perasEpochContextResolverBounds = \case
  PerasEpochContextResolverError String
_ ->
    ( PerasRoundNo
0
    , PerasRoundNo
0
    )
  PerasEpochContextResolver PerasEnabled (BoundedPerasEpochContext blk)
NoPerasEnabled PerasEnabled (BoundedPerasEpochContext blk)
NoPerasEnabled ->
    ( PerasRoundNo
0
    , PerasRoundNo
0
    )
  PerasEpochContextResolver (PerasEnabled BoundedPerasEpochContext blk
curr) PerasEnabled (BoundedPerasEpochContext blk)
NoPerasEnabled ->
    ( BoundedPerasEpochContext blk -> PerasRoundNo
forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
startPerasRoundNo BoundedPerasEpochContext blk
curr
    , BoundedPerasEpochContext blk -> PerasRoundNo
forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
endPerasRoundNo BoundedPerasEpochContext blk
curr
    )
  PerasEpochContextResolver PerasEnabled (BoundedPerasEpochContext blk)
NoPerasEnabled (PerasEnabled BoundedPerasEpochContext blk
prev) ->
    ( BoundedPerasEpochContext blk -> PerasRoundNo
forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
startPerasRoundNo BoundedPerasEpochContext blk
prev
    , BoundedPerasEpochContext blk -> PerasRoundNo
forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
endPerasRoundNo BoundedPerasEpochContext blk
prev
    )
  PerasEpochContextResolver (PerasEnabled BoundedPerasEpochContext blk
curr) (PerasEnabled BoundedPerasEpochContext blk
prev) ->
    ( PerasRoundNo -> PerasRoundNo -> PerasRoundNo
forall a. Ord a => a -> a -> a
min (BoundedPerasEpochContext blk -> PerasRoundNo
forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
startPerasRoundNo BoundedPerasEpochContext blk
curr) (BoundedPerasEpochContext blk -> PerasRoundNo
forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
startPerasRoundNo BoundedPerasEpochContext blk
prev)
    , PerasRoundNo -> PerasRoundNo -> PerasRoundNo
forall a. Ord a => a -> a -> a
max (BoundedPerasEpochContext blk -> PerasRoundNo
forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
endPerasRoundNo BoundedPerasEpochContext blk
curr) (BoundedPerasEpochContext blk -> PerasRoundNo
forall blk. BoundedPerasEpochContext blk -> PerasRoundNo
endPerasRoundNo BoundedPerasEpochContext blk
prev)
    )

-- | A handle to a 'PerasEpochContextResolver' that can be used in 'STM' to
-- resolve round numbers into their corresponding 'PerasEpochContext's.
newtype PerasEpochContextResolverHandle m blk
  = PerasEpochContextResolverHandle
  { forall (m :: * -> *) blk.
PerasEpochContextResolverHandle m blk
-> STM m (PerasEpochContextResolver blk)
getPerasEpochContextResolver :: STM m (PerasEpochContextResolver blk)
  }

-- | A mocked 'PerasEpochContextResolverHandle' that always succeeds by
-- resolving every round number to a fixed given (fixed) 'PerasEpochContext'.
mockPerasEpochContextResolverHandle ::
  ( IOLike m
  , NoThunks (PerasEpochContext blk)
  ) =>
  PerasEpochContext blk ->
  m (PerasEpochContextResolverHandle m blk)
mockPerasEpochContextResolverHandle :: forall (m :: * -> *) blk.
(IOLike m, NoThunks (PerasEpochContext blk)) =>
PerasEpochContext blk -> m (PerasEpochContextResolverHandle m blk)
mockPerasEpochContextResolverHandle PerasEpochContext blk
context = do
  resolverVar <-
    PerasEpochContextResolver blk
-> m (StrictTVar m (PerasEpochContextResolver blk))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO
      ( PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
forall blk.
PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
PerasEpochContextResolver
          (BoundedPerasEpochContext blk
-> PerasEnabled (BoundedPerasEpochContext blk)
forall a. a -> PerasEnabled a
PerasEnabled (PerasRoundNo
-> PerasRoundNo
-> PerasEpochContext blk
-> BoundedPerasEpochContext blk
forall blk.
PerasRoundNo
-> PerasRoundNo
-> PerasEpochContext blk
-> BoundedPerasEpochContext blk
BoundedPerasEpochContext PerasRoundNo
forall a. Bounded a => a
minBound PerasRoundNo
forall a. Bounded a => a
maxBound PerasEpochContext blk
context))
          PerasEnabled (BoundedPerasEpochContext blk)
forall a. PerasEnabled a
NoPerasEnabled
      )
  pure $ PerasEpochContextResolverHandle (readTVar resolverVar)

-- | Helper to resolve the epoch context for a given round a pass it to a
-- continuation for further processing.
--
-- NOTE: this function will throw an STM exception if round number cannot be
-- resolved, or if the continuation fails.
withResolvedRoundNo ::
  ( MonadSTM m
  , MonadThrow (STM m)
  , Exception err
  ) =>
  PerasEpochContextResolverHandle m blk ->
  PerasRoundNo ->
  (PerasEpochContext blk -> Either err a) ->
  STM m a
withResolvedRoundNo :: forall (m :: * -> *) err blk a.
(MonadSTM m, MonadThrow (STM m), Exception err) =>
PerasEpochContextResolverHandle m blk
-> PerasRoundNo
-> (PerasEpochContext blk -> Either err a)
-> STM m a
withResolvedRoundNo PerasEpochContextResolverHandle m blk
handle PerasRoundNo
roundNo PerasEpochContext blk -> Either err a
k = do
  resolver <- PerasEpochContextResolverHandle m blk
-> STM m (PerasEpochContextResolver blk)
forall (m :: * -> *) blk.
PerasEpochContextResolverHandle m blk
-> STM m (PerasEpochContextResolver blk)
getPerasEpochContextResolver PerasEpochContextResolverHandle m blk
handle
  case resolveRoundNo resolver roundNo of
    Left PerasEpochContextNotFoundForRound
err -> PerasEpochContextNotFoundForRound -> STM m a
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM PerasEpochContextNotFoundForRound
err
    Right PerasEpochContext blk
context ->
      case PerasEpochContext blk -> Either err a
k PerasEpochContext blk
context of
        Left err
err -> err -> STM m a
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM err
err
        Right a
a -> a -> STM m a
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- * Extracting and resolving Peras epoch contexts from the node state

-- | Type-class for blocks that support constructing a Peras epoch contexts from
-- their corresponding ledger and chain-dep states.
class
  ( HasHardForkHistory blk
  , LedgerStateSupportsPeras (LedgerState blk)
  , LedgerStateSupportsPeras (Ticked LedgerState blk)
  , ChainDepStateSupportsPeras (ChainDepState (BlockProtocol blk))
  , ChainDepStateSupportsPeras (Ticked (ChainDepState (BlockProtocol blk)))
  , IsPerasError (PerasError blk) blk
  , Show (PerasError blk)
  , Show (PerasVotingCommittee blk)
  , Eq (PerasVotingCommittee blk)
  , NoThunks (PerasVotingCommittee blk)
  , Typeable (PerasVotingCommittee blk)
  , FromCBOR (PerasVotingCommittee blk)
  , ToCBOR (PerasVotingCommittee blk)
  , Show (PerasEpochContextResolver blk)
  , Eq (PerasEpochContextResolver blk)
  , NoThunks (PerasEpochContextResolver blk)
  , Typeable (PerasEpochContextResolver blk)
  , FromCBOR (PerasEpochContextResolver blk)
  , ToCBOR (PerasEpochContextResolver blk)
  , EncodeDisk blk (PerasEpochContextResolver blk)
  , DecodeDisk blk (PerasEpochContextResolver blk)
  ) =>
  StateSupportsPerasEpochContext blk
  where
  -- | Epoch-dependent information needed to resolve a 'PerasRoundNo' into its
  -- corresponding 'PerasEpochContext'. In practice, this is always an
  -- 'EpochToPerasRoundInfo', with the exception of the 'HardForkBlock', which
  -- additionally takes advantage of the era index returned by
  -- 'runQueryEraIndexed' to be able to dispatch to the correct era-specific
  -- implementation.
  type MaybeEraIndexedEpochToPerasRoundInfo blk :: Type

  -- | Extract a 'EpochToPerasRoundInfo' the opaque
  -- 'MaybeEraIndexedEpochToPerasRoundInfo' of this block.
  fromMaybeEraIndexedEpochToPerasRoundInfo ::
    proxy blk ->
    MaybeEraIndexedEpochToPerasRoundInfo blk ->
    EpochToPerasRoundInfo

  -- | Inject an era-indexed 'EpochToPerasRoundInfo' into an opaque
  -- 'MaybeEraIndexedEpochToPerasRoundInfo' of this block.
  toMaybeEraIndexedEpochToPerasRoundInfo ::
    All Top (HardForkIndices blk) =>
    proxy blk ->
    EraIndexed (HardForkIndices blk) EpochToPerasRoundInfo ->
    MaybeEraIndexedEpochToPerasRoundInfo blk

  -- | Create a bounded epoch context from a given epoch-to-round info.
  mkBoundedPerasEpochContext ::
    ( LedgerStateSupportsPeras ledgerState
    , ChainDepStateSupportsPeras chainDepState
    ) =>
    MaybeEraIndexedEpochToPerasRoundInfo blk ->
    ledgerState EmptyMK ->
    chainDepState ->
    Either
      (PerasError blk)
      (BoundedPerasEpochContext blk)

-- | Helper to build a 'BoundedPerasEpochContext' using a function that produces
-- a 'PerasVotingCommitteeInput' from a ledger and chain-dep state.
--
-- NOTE: this is useful to define instances for 'StateSupportsPerasEpochContext'
-- where 'mkBoundedPerasEpochContext' is instantiated to either:
--   * @mkBoundedPerasEpochContextWith mkMockPerasVotingCommitteeInput@ for test
--     types with limited Peras support, and
--   * @mkBoundedPerasEpochContextWith V1.mkPerasVotingCommitteeInput@ for
--     production types.
mkBoundedPerasEpochContextWith ::
  ( LedgerStateSupportsPeras ledgerState
  , ChainDepStateSupportsPeras chainDepState
  , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk)
  , MaybeEraIndexedEpochToPerasRoundInfo blk ~ EpochToPerasRoundInfo
  , IsPerasError (PerasError blk) blk
  ) =>
  ( ( LedgerStateSupportsPeras ledgerState
    , ChainDepStateSupportsPeras chainDepState
    ) =>
    ledgerState EmptyMK ->
    chainDepState ->
    Either
      (PerasError blk)
      (PerasVotingCommitteeInput blk)
  ) ->
  MaybeEraIndexedEpochToPerasRoundInfo blk ->
  ledgerState EmptyMK ->
  chainDepState ->
  Either
    (PerasError blk)
    (BoundedPerasEpochContext blk)
mkBoundedPerasEpochContextWith :: forall (ledgerState :: MapKind -> *) chainDepState blk.
(LedgerStateSupportsPeras ledgerState,
 ChainDepStateSupportsPeras chainDepState,
 CryptoSupportsVotingCommittee
   (PerasCrypto blk) (PerasVotingCommitteeScheme blk),
 MaybeEraIndexedEpochToPerasRoundInfo blk ~ EpochToPerasRoundInfo,
 IsPerasError (PerasError blk) blk) =>
((LedgerStateSupportsPeras ledgerState,
  ChainDepStateSupportsPeras chainDepState) =>
 ledgerState EmptyMK
 -> chainDepState
 -> Either (PerasError blk) (PerasVotingCommitteeInput blk))
-> MaybeEraIndexedEpochToPerasRoundInfo blk
-> ledgerState EmptyMK
-> chainDepState
-> Either (PerasError blk) (BoundedPerasEpochContext blk)
mkBoundedPerasEpochContextWith
  (LedgerStateSupportsPeras ledgerState,
 ChainDepStateSupportsPeras chainDepState) =>
ledgerState EmptyMK
-> chainDepState
-> Either (PerasError blk) (PerasVotingCommitteeInput blk)
mkPerasVotingCommitteeInput
  MaybeEraIndexedEpochToPerasRoundInfo blk
epochToRoundInfo
  ledgerState EmptyMK
ledgerState
  chainDepState
headerState = do
    committeeInput <-
      ledgerState EmptyMK
-> chainDepState
-> Either (PerasError blk) (PerasVotingCommitteeInput blk)
(LedgerStateSupportsPeras ledgerState,
 ChainDepStateSupportsPeras chainDepState) =>
ledgerState EmptyMK
-> chainDepState
-> Either (PerasError blk) (PerasVotingCommitteeInput blk)
mkPerasVotingCommitteeInput ledgerState EmptyMK
ledgerState chainDepState
headerState
    committee <-
      bimap injectVotingCommitteeError id $
        Committee.mkVotingCommittee committeeInput
    let params =
          Proxy blk -> ledgerState EmptyMK -> PerasParams blk
forall (proxy :: * -> *) blk.
proxy blk -> ledgerState EmptyMK -> PerasParams blk
forall (ledgerState :: MapKind -> *) (proxy :: * -> *) blk.
LedgerStateSupportsPeras ledgerState =>
proxy blk -> ledgerState EmptyMK -> PerasParams blk
getPerasParams Proxy blk
forall {k} (t :: k). Proxy t
Proxy ledgerState EmptyMK
ledgerState
    pure
      BoundedPerasEpochContext
        { startPerasRoundNo =
            etpriEpochStartPerasRound epochToRoundInfo
        , endPerasRoundNo =
            etpriEpochEndPerasRound epochToRoundInfo
        , epochContext =
            PerasEpochContext
              { pecParams =
                  params
              , pecCommittee =
                  committee
              }
        }

-- | Initialize a 'PerasEpochContextResolver' from a ledger and header state.
--
-- NOTES:
--   1. We may later decide that a 'PerasEpochContextResolver' is always
--      initiated with empty/error value, and rely on the first ticking to
--      properly initialize it. In the current architecture, however, that would
--      work only if the first ticking happens when the previous slot is either
--      'Origin', or a slot from a previous epoch compared to the target slot.
--   2. Given that we have no assumption that (1) would work, we made a
--      polymorphic system where a 'BoundedEpochContext' can be created from
--      either a ticked or unticked ledger+header state
--      (see 'LedgerStateSupportsPeras' and 'ChainDepStateSupportsPeras'
--      helper classes). This way, a 'PerasEpochContextResolver' can be
--      initialized from unticked 'LedgerState' and 'HeaderState', but then
--      ticked by using the 'Ticked LedgerState' and 'Ticked HeaderState'.
--   3. If in the future we move on to a system where the resolver is always
--      initialized with empty/error value, we can remove the polymorphic system
--      and only create a 'BoundedPerasEpochContext' from 'Ticked LedgerState'
--      and 'Ticked HeaderState'.
initPerasEpochContextResolver ::
  ( All Top (HardForkIndices blk)
  , StateSupportsPerasEpochContext blk
  ) =>
  LedgerConfig blk ->
  LedgerState blk EmptyMK ->
  HeaderState blk ->
  PerasEpochContextResolver blk
initPerasEpochContextResolver :: forall blk.
(All Top (HardForkIndices blk),
 StateSupportsPerasEpochContext blk) =>
LedgerConfig blk
-> LedgerState blk EmptyMK
-> HeaderState blk
-> PerasEpochContextResolver blk
initPerasEpochContextResolver LedgerConfig blk
ledgerConfig LedgerState blk EmptyMK
ledgerState HeaderState blk
headerState =
  case WithOrigin SlotNo
chainTipSlot of
    WithOrigin SlotNo
Origin ->
      PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
forall blk.
PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
newPerasEpochContextResolver PerasEnabled (BoundedPerasEpochContext blk)
forall a. PerasEnabled a
NoPerasEnabled
    NotOrigin SlotNo
slotNo ->
      case SlotNo
-> Either
     PastHorizonException
     (EraIndexed
        (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
resolveEpochToRoundInfo SlotNo
slotNo of
        Left PastHorizonException
err ->
          String -> PerasEpochContextResolver blk
forall blk. String -> PerasEpochContextResolver blk
PerasEpochContextResolverError (PastHorizonException -> String
forall a. Show a => a -> String
show PastHorizonException
err)
        Right EraIndexed
  (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
eraIndexedEpochToPerasRoundInfo ->
          (PerasEnabled (BoundedPerasEpochContext blk)
 -> PerasEpochContextResolver blk)
-> LedgerState blk EmptyMK
-> HeaderState blk
-> EraIndexed
     (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
-> PerasEpochContextResolver blk
forall blk (ledgerState :: MapKind -> *) chainDepState.
(All Top (HardForkIndices blk),
 LedgerStateSupportsPeras ledgerState,
 ChainDepStateSupportsPeras chainDepState,
 StateSupportsPerasEpochContext blk) =>
(PerasEnabled (BoundedPerasEpochContext blk)
 -> PerasEpochContextResolver blk)
-> ledgerState EmptyMK
-> chainDepState
-> EraIndexed
     (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
-> PerasEpochContextResolver blk
embedBoundedEpochContext
            PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
forall blk.
PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
newPerasEpochContextResolver
            LedgerState blk EmptyMK
ledgerState
            HeaderState blk
headerState
            EraIndexed
  (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
eraIndexedEpochToPerasRoundInfo
 where
  chainTipSlot :: WithOrigin SlotNo
chainTipSlot =
    (AnnTip blk -> SlotNo)
-> WithOrigin (AnnTip blk) -> WithOrigin SlotNo
forall a b. (a -> b) -> WithOrigin a -> WithOrigin b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnTip blk -> SlotNo
forall blk. AnnTip blk -> SlotNo
annTipSlotNo (HeaderState blk -> WithOrigin (AnnTip blk)
forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
headerStateTip HeaderState blk
headerState)
  timeResolutionContext :: TimeResolutionContext blk
timeResolutionContext =
    LedgerConfig blk
-> LedgerState blk EmptyMK -> TimeResolutionContext blk
forall blk (mk :: MapKind).
LedgerConfig blk -> LedgerState blk mk -> TimeResolutionContext blk
TimeResolutionContext LedgerConfig blk
ledgerConfig LedgerState blk EmptyMK
ledgerState
  resolveEpochToRoundInfo :: SlotNo
-> Either
     PastHorizonException
     (EraIndexed
        (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
resolveEpochToRoundInfo SlotNo
slotNo = do
    (epochNo, _) <-
      TimeResolutionContext blk
-> Qry (EpochNo, Word64)
-> Either PastHorizonException (EpochNo, Word64)
forall blk a.
HasHardForkHistory blk =>
TimeResolutionContext blk -> Qry a -> Either PastHorizonException a
runQueryWithContext
        TimeResolutionContext blk
timeResolutionContext
        (SlotNo -> Qry (EpochNo, Word64)
slotToEpoch' SlotNo
slotNo)
    runQueryEraIndexedWithContext
      timeResolutionContext
      (epochToPerasRoundInfo epochNo)

-- | Tick a 'PerasEpochContextResolver' to a target 'SlotNo'.
--
-- NOTES:
--   1. To avoid circular dependencies, this function uses a deconstructed
--      'ExtLedgerState' instead of the 'ExtLedgerState' itself.
--   2. It doesn't seem to bring much to differentiate a
--      'PerasEpochContextResolver' from a ticked one at type level, since they
--      need to carry exactly the same information. We tried, and it didn't
--      improve readability.
tickPerasEpochContextResolver ::
  ( All Top (HardForkIndices blk)
  , StateSupportsPerasEpochContext blk
  ) =>
  LedgerConfig blk ->
  -- | The fields needed from the previous 'ExtLedgerState' (before ticking)
  (PerasEpochContextResolver blk, LedgerState blk EmptyMK, HeaderState blk) ->
  -- | Target 'SlotNo' and fields of the 'Ticked ExtLedgerState' ticked to it
  (SlotNo, Ticked LedgerState blk EmptyMK, Ticked (HeaderState blk)) ->
  PerasEpochContextResolver blk
tickPerasEpochContextResolver :: forall blk.
(All Top (HardForkIndices blk),
 StateSupportsPerasEpochContext blk) =>
LedgerConfig blk
-> (PerasEpochContextResolver blk, LedgerState blk EmptyMK,
    HeaderState blk)
-> (SlotNo, Ticked LedgerState blk EmptyMK,
    Ticked (HeaderState blk))
-> PerasEpochContextResolver blk
tickPerasEpochContextResolver
  LedgerConfig blk
ledgerConfig
  (PerasEpochContextResolver blk
perasEpochContextResolver, LedgerState blk EmptyMK
ledgerState, HeaderState blk
headerState)
  (SlotNo
targetSlot, Ticked LedgerState blk EmptyMK
tickedLedger, Ticked (HeaderState blk)
tickedHeader) =
    case ( TimeResolutionContext blk
-> WithOrigin SlotNo
-> SlotNo
-> Either
     DetectNextEpochError
     (EpochCrossing
        (EraIndexed
           (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)))
forall blk.
HasHardForkHistory blk =>
TimeResolutionContext blk
-> WithOrigin SlotNo
-> SlotNo
-> Either
     DetectNextEpochError
     (EpochCrossing
        (EraIndexed
           (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)))
isNextEpoch
             TimeResolutionContext blk
timeResolutionContext
             WithOrigin SlotNo
chainTipSlot
             SlotNo
targetSlot
         ) of
      Left DetectNextEpochError
err ->
        String -> PerasEpochContextResolver blk
forall a. HasCallStack => String -> a
error (DetectNextEpochError -> String
forall a. Show a => a -> String
show DetectNextEpochError
err)
      Right EpochCrossing
  (EraIndexed
     (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
SameEpoch ->
        -- No epoch boundary was crossed: keep the current resolver as is.
        PerasEpochContextResolver blk
perasEpochContextResolver
      Right (NextEpoch EraIndexed
  (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
eraIndexedEpochToPerasRoundInfo) ->
        -- Exactly one epoch boundary was crossed: advance the two-epoch window
        -- incrementally (the current context becomes the previous one).
        (PerasEnabled (BoundedPerasEpochContext blk)
 -> PerasEpochContextResolver blk)
-> Ticked LedgerState blk EmptyMK
-> Ticked (HeaderState blk)
-> EraIndexed
     (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
-> PerasEpochContextResolver blk
forall blk (ledgerState :: MapKind -> *) chainDepState.
(All Top (HardForkIndices blk),
 LedgerStateSupportsPeras ledgerState,
 ChainDepStateSupportsPeras chainDepState,
 StateSupportsPerasEpochContext blk) =>
(PerasEnabled (BoundedPerasEpochContext blk)
 -> PerasEpochContextResolver blk)
-> ledgerState EmptyMK
-> chainDepState
-> EraIndexed
     (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
-> PerasEpochContextResolver blk
embedBoundedEpochContext
          (PerasEpochContextResolver blk
-> PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
forall blk.
PerasEpochContextResolver blk
-> PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
advancePerasEpochContextResolver PerasEpochContextResolver blk
perasEpochContextResolver)
          Ticked LedgerState blk EmptyMK
tickedLedger
          Ticked (HeaderState blk)
tickedHeader
          EraIndexed
  (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
eraIndexedEpochToPerasRoundInfo
      Right (ManyEpochsCrossed EraIndexed
  (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
eraIndexedEpochToPerasRoundInfo) ->
        -- More than one epoch boundary was crossed at once, which is only
        -- possible when the chain skips one or more entire epochs (e.g. a
        -- sparse/empty chain, or a node ticking its ledger far ahead of its
        -- tip). The two-epoch window cannot be advanced incrementally
        -- across the gap, so we re-initialise it at the target epoch.
        --
        -- NOTE: this should be an impossible case in production, as we
        -- expect at least one block per epoch. However, we still need to
        -- handle this case in a way that doesn't break the more lenient
        -- test suites, where we might tick the ledger far ahead of its tip.
        -- See: https://github.com/tweag/cardano-peras/issues/260
        (PerasEnabled (BoundedPerasEpochContext blk)
 -> PerasEpochContextResolver blk)
-> Ticked LedgerState blk EmptyMK
-> Ticked (HeaderState blk)
-> EraIndexed
     (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
-> PerasEpochContextResolver blk
forall blk (ledgerState :: MapKind -> *) chainDepState.
(All Top (HardForkIndices blk),
 LedgerStateSupportsPeras ledgerState,
 ChainDepStateSupportsPeras chainDepState,
 StateSupportsPerasEpochContext blk) =>
(PerasEnabled (BoundedPerasEpochContext blk)
 -> PerasEpochContextResolver blk)
-> ledgerState EmptyMK
-> chainDepState
-> EraIndexed
     (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
-> PerasEpochContextResolver blk
embedBoundedEpochContext
          PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
forall blk.
PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
newPerasEpochContextResolver
          Ticked LedgerState blk EmptyMK
tickedLedger
          Ticked (HeaderState blk)
tickedHeader
          EraIndexed
  (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
eraIndexedEpochToPerasRoundInfo
   where
    chainTipSlot :: WithOrigin SlotNo
chainTipSlot =
      (AnnTip blk -> SlotNo)
-> WithOrigin (AnnTip blk) -> WithOrigin SlotNo
forall a b. (a -> b) -> WithOrigin a -> WithOrigin b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnTip blk -> SlotNo
forall blk. AnnTip blk -> SlotNo
annTipSlotNo (HeaderState blk -> WithOrigin (AnnTip blk)
forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
headerStateTip HeaderState blk
headerState)
    timeResolutionContext :: TimeResolutionContext blk
timeResolutionContext =
      LedgerConfig blk
-> LedgerState blk EmptyMK -> TimeResolutionContext blk
forall blk (mk :: MapKind).
LedgerConfig blk -> LedgerState blk mk -> TimeResolutionContext blk
TimeResolutionContext LedgerConfig blk
ledgerConfig LedgerState blk EmptyMK
ledgerState

-- | Build a 'PerasEpochContextResolver' from the per-era Peras info for an
-- epoch, given a ledger and chain-dep state to derive the bounded epoch context
-- from and a way to embed that context into the resolver.
--
-- NOTE: this captures the logic shared between initialising the resolver
-- ('initPerasEpochContextResolver') and re-initialising or advancing it while
-- ticking ('tickPerasEpochContextResolver').
embedBoundedEpochContext ::
  forall blk ledgerState chainDepState.
  ( All Top (HardForkIndices blk)
  , LedgerStateSupportsPeras ledgerState
  , ChainDepStateSupportsPeras chainDepState
  , StateSupportsPerasEpochContext blk
  ) =>
  -- | How to embed the (optional) fresh bounded epoch context into a resolver.
  ( PerasEnabled (BoundedPerasEpochContext blk) ->
    PerasEpochContextResolver blk
  ) ->
  ledgerState EmptyMK ->
  chainDepState ->
  EraIndexed (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo) ->
  PerasEpochContextResolver blk
embedBoundedEpochContext :: forall blk (ledgerState :: MapKind -> *) chainDepState.
(All Top (HardForkIndices blk),
 LedgerStateSupportsPeras ledgerState,
 ChainDepStateSupportsPeras chainDepState,
 StateSupportsPerasEpochContext blk) =>
(PerasEnabled (BoundedPerasEpochContext blk)
 -> PerasEpochContextResolver blk)
-> ledgerState EmptyMK
-> chainDepState
-> EraIndexed
     (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
-> PerasEpochContextResolver blk
embedBoundedEpochContext
  PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
embed
  ledgerState EmptyMK
ledgerState
  chainDepState
chainDepState
  EraIndexed
  (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
eraIndexedEpochToRoundInfo =
    case EraIndexed
  (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
-> PerasEnabled
     (EraIndexed (HardForkIndices blk) EpochToPerasRoundInfo)
forall (xs :: [*]) a.
All Top xs =>
EraIndexed xs (PerasEnabled a) -> PerasEnabled (EraIndexed xs a)
collapseEraIndexed EraIndexed
  (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
eraIndexedEpochToRoundInfo of
      PerasEnabled EraIndexed (HardForkIndices blk) EpochToPerasRoundInfo
eiEpochToPerasRoundInfo ->
        case ( MaybeEraIndexedEpochToPerasRoundInfo blk
-> ledgerState EmptyMK
-> chainDepState
-> Either (PerasError blk) (BoundedPerasEpochContext blk)
forall blk (ledgerState :: MapKind -> *) chainDepState.
(StateSupportsPerasEpochContext blk,
 LedgerStateSupportsPeras ledgerState,
 ChainDepStateSupportsPeras chainDepState) =>
MaybeEraIndexedEpochToPerasRoundInfo blk
-> ledgerState EmptyMK
-> chainDepState
-> Either (PerasError blk) (BoundedPerasEpochContext blk)
forall (ledgerState :: MapKind -> *) chainDepState.
(LedgerStateSupportsPeras ledgerState,
 ChainDepStateSupportsPeras chainDepState) =>
MaybeEraIndexedEpochToPerasRoundInfo blk
-> ledgerState EmptyMK
-> chainDepState
-> Either (PerasError blk) (BoundedPerasEpochContext blk)
mkBoundedPerasEpochContext
                 ( Proxy blk
-> EraIndexed (HardForkIndices blk) EpochToPerasRoundInfo
-> MaybeEraIndexedEpochToPerasRoundInfo blk
forall blk (proxy :: * -> *).
(StateSupportsPerasEpochContext blk,
 All Top (HardForkIndices blk)) =>
proxy blk
-> EraIndexed (HardForkIndices blk) EpochToPerasRoundInfo
-> MaybeEraIndexedEpochToPerasRoundInfo blk
forall (proxy :: * -> *).
All Top (HardForkIndices blk) =>
proxy blk
-> EraIndexed (HardForkIndices blk) EpochToPerasRoundInfo
-> MaybeEraIndexedEpochToPerasRoundInfo blk
toMaybeEraIndexedEpochToPerasRoundInfo
                     (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
                     EraIndexed (HardForkIndices blk) EpochToPerasRoundInfo
eiEpochToPerasRoundInfo
                 )
                 ledgerState EmptyMK
ledgerState
                 chainDepState
chainDepState
             ) of
          Left PerasError blk
err ->
            String -> PerasEpochContextResolver blk
forall blk. String -> PerasEpochContextResolver blk
PerasEpochContextResolverError (VoidPerasError blk -> String
forall a. Show a => a -> String
show VoidPerasError blk
PerasError blk
err)
          Right BoundedPerasEpochContext blk
boundedContext ->
            PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
embed (BoundedPerasEpochContext blk
-> PerasEnabled (BoundedPerasEpochContext blk)
forall a. a -> PerasEnabled a
PerasEnabled BoundedPerasEpochContext blk
boundedContext)
      PerasEnabled
  (EraIndexed (HardForkIndices blk) EpochToPerasRoundInfo)
NoPerasEnabled ->
        PerasEnabled (BoundedPerasEpochContext blk)
-> PerasEpochContextResolver blk
embed PerasEnabled (BoundedPerasEpochContext blk)
forall a. PerasEnabled a
NoPerasEnabled
   where
    -- Swap the positions of the 'EraIndexed' and 'PerasEnabled' wrappers, so we
    -- can directly pattern-match on the 'PerasEnabled' information.
    collapseEraIndexed ::
      All Top xs =>
      EraIndexed xs (PerasEnabled a) ->
      PerasEnabled (EraIndexed xs a)
    collapseEraIndexed :: forall (xs :: [*]) a.
All Top xs =>
EraIndexed xs (PerasEnabled a) -> PerasEnabled (EraIndexed xs a)
collapseEraIndexed (EraIndexed NS (K (PerasEnabled a)) xs
ns) =
      NS (K (PerasEnabled (EraIndexed xs a))) xs
-> CollapseTo NS (PerasEnabled (EraIndexed xs a))
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K (PerasEnabled (EraIndexed xs a))) xs
 -> CollapseTo NS (PerasEnabled (EraIndexed xs a)))
-> NS (K (PerasEnabled (EraIndexed xs a))) xs
-> CollapseTo NS (PerasEnabled (EraIndexed xs a))
forall a b. (a -> b) -> a -> b
$
        (forall a.
 Index xs a
 -> K (PerasEnabled a) a -> K (PerasEnabled (EraIndexed xs a)) a)
-> NS (K (PerasEnabled a)) xs
-> NS (K (PerasEnabled (EraIndexed xs a))) xs
forall {k} (h :: (k -> *) -> [k] -> *) (xs :: [k]) (f1 :: k -> *)
       (f2 :: k -> *).
(HAp h, SListI xs, Prod h ~ NP) =>
(forall (a :: k). Index xs a -> f1 a -> f2 a) -> h f1 xs -> h f2 xs
himap
          ( \Index xs a
idx (K PerasEnabled a
pea) ->
              case PerasEnabled a
pea of
                PerasEnabled a
a ->
                  PerasEnabled (EraIndexed xs a)
-> K (PerasEnabled (EraIndexed xs a)) a
forall k a (b :: k). a -> K a b
K (EraIndexed xs a -> PerasEnabled (EraIndexed xs a)
forall a. a -> PerasEnabled a
PerasEnabled (NS (K a) xs -> EraIndexed xs a
forall (xs :: [*]) a. NS (K a) xs -> EraIndexed xs a
EraIndexed (Index xs a -> K a a -> NS (K a) xs
forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
All Top xs =>
Index xs x -> f x -> NS f xs
injectNS Index xs a
idx (a -> K a a
forall k a (b :: k). a -> K a b
K a
a))))
                PerasEnabled a
NoPerasEnabled ->
                  PerasEnabled (EraIndexed xs a)
-> K (PerasEnabled (EraIndexed xs a)) a
forall k a (b :: k). a -> K a b
K PerasEnabled (EraIndexed xs a)
forall a. PerasEnabled a
NoPerasEnabled
          )
          NS (K (PerasEnabled a)) xs
ns

-- * Time resolution

-- | Data needed to run time-dependent queries.
--
-- NOTE: this is existential on the 'MapKind' of the ledger state, as we really
-- don't care about it for the purpose of time resolution.
data TimeResolutionContext blk where
  TimeResolutionContext ::
    forall blk mk.
    LedgerConfig blk ->
    LedgerState blk mk ->
    TimeResolutionContext blk

-- | Wrapper over 'runQuery' that uses a 'TimeResolutionContext' to build a
-- 'Summary'.
runQueryWithContext ::
  HasHardForkHistory blk =>
  TimeResolutionContext blk ->
  Qry a ->
  Either PastHorizonException a
runQueryWithContext :: forall blk a.
HasHardForkHistory blk =>
TimeResolutionContext blk -> Qry a -> Either PastHorizonException a
runQueryWithContext (TimeResolutionContext LedgerConfig blk
cfg LedgerState blk mk
state) Qry a
qry =
  Qry a
-> Summary (HardForkIndices blk) -> Either PastHorizonException a
forall a (xs :: [*]).
HasCallStack =>
Qry a -> Summary xs -> Either PastHorizonException a
runQuery Qry a
qry (LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall blk (mk :: MapKind).
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall (mk :: MapKind).
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig blk
cfg LedgerState blk mk
state)

-- | Wrapper over 'runQueryEraIndexed' that uses a 'TimeResolutionContext' to
-- build a 'Summary'.
runQueryEraIndexedWithContext ::
  HasHardForkHistory blk =>
  TimeResolutionContext blk ->
  Qry a ->
  Either PastHorizonException (EraIndexed (HardForkIndices blk) a)
runQueryEraIndexedWithContext :: forall blk a.
HasHardForkHistory blk =>
TimeResolutionContext blk
-> Qry a
-> Either PastHorizonException (EraIndexed (HardForkIndices blk) a)
runQueryEraIndexedWithContext (TimeResolutionContext LedgerConfig blk
cfg LedgerState blk mk
state) Qry a
qry =
  Qry a
-> Summary (HardForkIndices blk)
-> Either PastHorizonException (EraIndexed (HardForkIndices blk) a)
forall a (xs :: [*]).
HasCallStack =>
Qry a
-> Summary xs -> Either PastHorizonException (EraIndexed xs a)
runQueryEraIndexed Qry a
qry (LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall blk (mk :: MapKind).
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall (mk :: MapKind).
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig blk
cfg LedgerState blk mk
state)

-- | A handle to an STM action that returns a 'TimeResolutionContext'.
newtype TimeResolutionContextHandle m blk
  = TimeResolutionContextHandle
  { forall (m :: * -> *) blk.
TimeResolutionContextHandle m blk
-> STM m (TimeResolutionContext blk)
getTimeResolutionContext :: STM m (TimeResolutionContext blk)
  }

-- | Helper to run a time-dependent query using a 'TimeResolutionContextHandle'.
runQueryWithContextHandle ::
  (HasHardForkHistory blk, MonadSTM m) =>
  TimeResolutionContextHandle m blk ->
  Qry a ->
  STM m (Either PastHorizonException a)
runQueryWithContextHandle :: forall blk (m :: * -> *) a.
(HasHardForkHistory blk, MonadSTM m) =>
TimeResolutionContextHandle m blk
-> Qry a -> STM m (Either PastHorizonException a)
runQueryWithContextHandle TimeResolutionContextHandle m blk
handle Qry a
qry = do
  context <- TimeResolutionContextHandle m blk
-> STM m (TimeResolutionContext blk)
forall (m :: * -> *) blk.
TimeResolutionContextHandle m blk
-> STM m (TimeResolutionContext blk)
getTimeResolutionContext TimeResolutionContextHandle m blk
handle
  pure (runQueryWithContext context qry)

-- * Next-epoch detection

-- | The outcome of comparing the epoch of a previous slot with the epoch of a
-- target slot when ticking the ledger, discriminated by how many epoch
-- boundaries were crossed. This drives how the Peras epoch-context resolver is
-- updated.
data EpochCrossing a
  = -- | The target slot is in the same epoch as the previous slot: no epoch
    -- boundary was crossed.
    SameEpoch
  | -- | Exactly one epoch boundary was crossed. The resolver can be advanced
    -- incrementally (the current context becomes the previous one).
    NextEpoch !a
  | -- | More than one epoch boundary was crossed at once, i.e. the chain
    -- skipped one or more entire epochs. This is only possible for a
    -- sparse/empty chain, or when ticking the ledger far ahead of its tip. The
    -- two-epoch window cannot be advanced incrementally across the gap, so the
    -- resolver must be re-initialised at the target epoch instead.
    ManyEpochsCrossed !a
  deriving (Int -> EpochCrossing a -> ShowS
[EpochCrossing a] -> ShowS
EpochCrossing a -> String
(Int -> EpochCrossing a -> ShowS)
-> (EpochCrossing a -> String)
-> ([EpochCrossing a] -> ShowS)
-> Show (EpochCrossing a)
forall a. Show a => Int -> EpochCrossing a -> ShowS
forall a. Show a => [EpochCrossing a] -> ShowS
forall a. Show a => EpochCrossing a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> EpochCrossing a -> ShowS
showsPrec :: Int -> EpochCrossing a -> ShowS
$cshow :: forall a. Show a => EpochCrossing a -> String
show :: EpochCrossing a -> String
$cshowList :: forall a. Show a => [EpochCrossing a] -> ShowS
showList :: [EpochCrossing a] -> ShowS
Show, (forall a b. (a -> b) -> EpochCrossing a -> EpochCrossing b)
-> (forall a b. a -> EpochCrossing b -> EpochCrossing a)
-> Functor EpochCrossing
forall a b. a -> EpochCrossing b -> EpochCrossing a
forall a b. (a -> b) -> EpochCrossing a -> EpochCrossing b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> EpochCrossing a -> EpochCrossing b
fmap :: forall a b. (a -> b) -> EpochCrossing a -> EpochCrossing b
$c<$ :: forall a b. a -> EpochCrossing b -> EpochCrossing a
<$ :: forall a b. a -> EpochCrossing b -> EpochCrossing a
Functor, (forall m. Monoid m => EpochCrossing m -> m)
-> (forall m a. Monoid m => (a -> m) -> EpochCrossing a -> m)
-> (forall m a. Monoid m => (a -> m) -> EpochCrossing a -> m)
-> (forall a b. (a -> b -> b) -> b -> EpochCrossing a -> b)
-> (forall a b. (a -> b -> b) -> b -> EpochCrossing a -> b)
-> (forall b a. (b -> a -> b) -> b -> EpochCrossing a -> b)
-> (forall b a. (b -> a -> b) -> b -> EpochCrossing a -> b)
-> (forall a. (a -> a -> a) -> EpochCrossing a -> a)
-> (forall a. (a -> a -> a) -> EpochCrossing a -> a)
-> (forall a. EpochCrossing a -> [a])
-> (forall a. EpochCrossing a -> Bool)
-> (forall a. EpochCrossing a -> Int)
-> (forall a. Eq a => a -> EpochCrossing a -> Bool)
-> (forall a. Ord a => EpochCrossing a -> a)
-> (forall a. Ord a => EpochCrossing a -> a)
-> (forall a. Num a => EpochCrossing a -> a)
-> (forall a. Num a => EpochCrossing a -> a)
-> Foldable EpochCrossing
forall a. Eq a => a -> EpochCrossing a -> Bool
forall a. Num a => EpochCrossing a -> a
forall a. Ord a => EpochCrossing a -> a
forall m. Monoid m => EpochCrossing m -> m
forall a. EpochCrossing a -> Bool
forall a. EpochCrossing a -> Int
forall a. EpochCrossing a -> [a]
forall a. (a -> a -> a) -> EpochCrossing a -> a
forall m a. Monoid m => (a -> m) -> EpochCrossing a -> m
forall b a. (b -> a -> b) -> b -> EpochCrossing a -> b
forall a b. (a -> b -> b) -> b -> EpochCrossing a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => EpochCrossing m -> m
fold :: forall m. Monoid m => EpochCrossing m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> EpochCrossing a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> EpochCrossing a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> EpochCrossing a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> EpochCrossing a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> EpochCrossing a -> b
foldr :: forall a b. (a -> b -> b) -> b -> EpochCrossing a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> EpochCrossing a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> EpochCrossing a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> EpochCrossing a -> b
foldl :: forall b a. (b -> a -> b) -> b -> EpochCrossing a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> EpochCrossing a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> EpochCrossing a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> EpochCrossing a -> a
foldr1 :: forall a. (a -> a -> a) -> EpochCrossing a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> EpochCrossing a -> a
foldl1 :: forall a. (a -> a -> a) -> EpochCrossing a -> a
$ctoList :: forall a. EpochCrossing a -> [a]
toList :: forall a. EpochCrossing a -> [a]
$cnull :: forall a. EpochCrossing a -> Bool
null :: forall a. EpochCrossing a -> Bool
$clength :: forall a. EpochCrossing a -> Int
length :: forall a. EpochCrossing a -> Int
$celem :: forall a. Eq a => a -> EpochCrossing a -> Bool
elem :: forall a. Eq a => a -> EpochCrossing a -> Bool
$cmaximum :: forall a. Ord a => EpochCrossing a -> a
maximum :: forall a. Ord a => EpochCrossing a -> a
$cminimum :: forall a. Ord a => EpochCrossing a -> a
minimum :: forall a. Ord a => EpochCrossing a -> a
$csum :: forall a. Num a => EpochCrossing a -> a
sum :: forall a. Num a => EpochCrossing a -> a
$cproduct :: forall a. Num a => EpochCrossing a -> a
product :: forall a. Num a => EpochCrossing a -> a
Foldable, Functor EpochCrossing
Foldable EpochCrossing
(Functor EpochCrossing, Foldable EpochCrossing) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> EpochCrossing a -> f (EpochCrossing b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    EpochCrossing (f a) -> f (EpochCrossing a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> EpochCrossing a -> m (EpochCrossing b))
-> (forall (m :: * -> *) a.
    Monad m =>
    EpochCrossing (m a) -> m (EpochCrossing a))
-> Traversable EpochCrossing
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
EpochCrossing (m a) -> m (EpochCrossing a)
forall (f :: * -> *) a.
Applicative f =>
EpochCrossing (f a) -> f (EpochCrossing a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EpochCrossing a -> m (EpochCrossing b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EpochCrossing a -> f (EpochCrossing b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EpochCrossing a -> f (EpochCrossing b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EpochCrossing a -> f (EpochCrossing b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
EpochCrossing (f a) -> f (EpochCrossing a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
EpochCrossing (f a) -> f (EpochCrossing a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EpochCrossing a -> m (EpochCrossing b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EpochCrossing a -> m (EpochCrossing b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
EpochCrossing (m a) -> m (EpochCrossing a)
sequence :: forall (m :: * -> *) a.
Monad m =>
EpochCrossing (m a) -> m (EpochCrossing a)
Traversable)

-- | Errors that can occur when detecting whether a target slot is in the next
-- epoch compared to a previous slot.
data DetectNextEpochError
  = -- | Target slot is past the horizon of the given time resolution context.
    DetectNextEpochPastHorizonError
      PastHorizonException
  | -- | Target slot is in the past compared to the previous slot.
    DetectNextEpochNewSlotInPast
      -- Previous slot.
      !SlotNo
      -- Epoch of the previous slot.
      !EpochNo
      -- Target slot.
      !SlotNo
      -- Epoch of the target slot.
      !EpochNo
  deriving (Int -> DetectNextEpochError -> ShowS
[DetectNextEpochError] -> ShowS
DetectNextEpochError -> String
(Int -> DetectNextEpochError -> ShowS)
-> (DetectNextEpochError -> String)
-> ([DetectNextEpochError] -> ShowS)
-> Show DetectNextEpochError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DetectNextEpochError -> ShowS
showsPrec :: Int -> DetectNextEpochError -> ShowS
$cshow :: DetectNextEpochError -> String
show :: DetectNextEpochError -> String
$cshowList :: [DetectNextEpochError] -> ShowS
showList :: [DetectNextEpochError] -> ShowS
Show, Show DetectNextEpochError
Typeable DetectNextEpochError
(Typeable DetectNextEpochError, Show DetectNextEpochError) =>
(DetectNextEpochError -> SomeException)
-> (SomeException -> Maybe DetectNextEpochError)
-> (DetectNextEpochError -> String)
-> (DetectNextEpochError -> Bool)
-> Exception DetectNextEpochError
SomeException -> Maybe DetectNextEpochError
DetectNextEpochError -> Bool
DetectNextEpochError -> String
DetectNextEpochError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: DetectNextEpochError -> SomeException
toException :: DetectNextEpochError -> SomeException
$cfromException :: SomeException -> Maybe DetectNextEpochError
fromException :: SomeException -> Maybe DetectNextEpochError
$cdisplayException :: DetectNextEpochError -> String
displayException :: DetectNextEpochError -> String
$cbacktraceDesired :: DetectNextEpochError -> Bool
backtraceDesired :: DetectNextEpochError -> Bool
Exception)

-- | Determine whether a target slot is in the next epoch compared to a previous
-- slot, and if so, how many epoch boundaries were crossed.
isNextEpoch ::
  HasHardForkHistory blk =>
  TimeResolutionContext blk ->
  WithOrigin SlotNo ->
  SlotNo ->
  Either
    DetectNextEpochError
    ( EpochCrossing
        ( EraIndexed
            (HardForkIndices blk)
            (PerasEnabled EpochToPerasRoundInfo)
        )
    )
isNextEpoch :: forall blk.
HasHardForkHistory blk =>
TimeResolutionContext blk
-> WithOrigin SlotNo
-> SlotNo
-> Either
     DetectNextEpochError
     (EpochCrossing
        (EraIndexed
           (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)))
isNextEpoch TimeResolutionContext blk
context WithOrigin SlotNo
mbPrevSlot SlotNo
nextSlot = do
  Either DetectNextEpochError (EpochCrossing EpochNo)
resolveEpochCrossing Either DetectNextEpochError (EpochCrossing EpochNo)
-> (EpochCrossing EpochNo
    -> Either
         DetectNextEpochError
         (EpochCrossing
            (EraIndexed
               (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))))
-> Either
     DetectNextEpochError
     (EpochCrossing
        (EraIndexed
           (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)))
forall a b.
Either DetectNextEpochError a
-> (a -> Either DetectNextEpochError b)
-> Either DetectNextEpochError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (EpochNo
 -> Either
      DetectNextEpochError
      (EraIndexed
         (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)))
-> EpochCrossing EpochNo
-> Either
     DetectNextEpochError
     (EpochCrossing
        (EraIndexed
           (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)))
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) -> EpochCrossing a -> f (EpochCrossing b)
traverse EpochNo
-> Either
     DetectNextEpochError
     (EraIndexed
        (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
resolvePerasInfoForEpoch
 where
  slotToEpochOrError :: SlotNo -> Either DetectNextEpochError EpochNo
slotToEpochOrError SlotNo
slot =
    (PastHorizonException -> DetectNextEpochError)
-> ((EpochNo, Word64) -> EpochNo)
-> Either PastHorizonException (EpochNo, Word64)
-> Either DetectNextEpochError EpochNo
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: MapKind) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap PastHorizonException -> DetectNextEpochError
DetectNextEpochPastHorizonError (EpochNo, Word64) -> EpochNo
forall a b. (a, b) -> a
fst (Either PastHorizonException (EpochNo, Word64)
 -> Either DetectNextEpochError EpochNo)
-> Either PastHorizonException (EpochNo, Word64)
-> Either DetectNextEpochError EpochNo
forall a b. (a -> b) -> a -> b
$
      TimeResolutionContext blk
-> Qry (EpochNo, Word64)
-> Either PastHorizonException (EpochNo, Word64)
forall blk a.
HasHardForkHistory blk =>
TimeResolutionContext blk -> Qry a -> Either PastHorizonException a
runQueryWithContext TimeResolutionContext blk
context (Qry (EpochNo, Word64)
 -> Either PastHorizonException (EpochNo, Word64))
-> Qry (EpochNo, Word64)
-> Either PastHorizonException (EpochNo, Word64)
forall a b. (a -> b) -> a -> b
$
        SlotNo -> Qry (EpochNo, Word64)
slotToEpoch' SlotNo
slot

  resolvePerasInfoForEpoch :: EpochNo
-> Either
     DetectNextEpochError
     (EraIndexed
        (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
resolvePerasInfoForEpoch EpochNo
epochNo =
    (PastHorizonException -> DetectNextEpochError)
-> (EraIndexed
      (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
    -> EraIndexed
         (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
-> Either
     PastHorizonException
     (EraIndexed
        (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
-> Either
     DetectNextEpochError
     (EraIndexed
        (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: MapKind) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap PastHorizonException -> DetectNextEpochError
DetectNextEpochPastHorizonError EraIndexed
  (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
-> EraIndexed
     (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)
forall a. a -> a
id (Either
   PastHorizonException
   (EraIndexed
      (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
 -> Either
      DetectNextEpochError
      (EraIndexed
         (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo)))
-> Either
     PastHorizonException
     (EraIndexed
        (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
-> Either
     DetectNextEpochError
     (EraIndexed
        (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
forall a b. (a -> b) -> a -> b
$
      TimeResolutionContext blk
-> Qry (PerasEnabled EpochToPerasRoundInfo)
-> Either
     PastHorizonException
     (EraIndexed
        (HardForkIndices blk) (PerasEnabled EpochToPerasRoundInfo))
forall blk a.
HasHardForkHistory blk =>
TimeResolutionContext blk
-> Qry a
-> Either PastHorizonException (EraIndexed (HardForkIndices blk) a)
runQueryEraIndexedWithContext TimeResolutionContext blk
context (EpochNo -> Qry (PerasEnabled EpochToPerasRoundInfo)
epochToPerasRoundInfo EpochNo
epochNo)

  resolveEpochCrossing :: Either DetectNextEpochError (EpochCrossing EpochNo)
resolveEpochCrossing =
    case WithOrigin SlotNo
mbPrevSlot of
      WithOrigin SlotNo
Origin -> do
        nextEpoch <- SlotNo -> Either DetectNextEpochError EpochNo
slotToEpochOrError SlotNo
nextSlot
        if
          | EpochNo 0 <- nextEpoch ->
              Right (NextEpoch nextEpoch)
          | otherwise ->
              Right (ManyEpochsCrossed nextEpoch)
      NotOrigin SlotNo
prevSlot -> do
        prevEpoch <- SlotNo -> Either DetectNextEpochError EpochNo
slotToEpochOrError SlotNo
prevSlot
        nextEpoch <- slotToEpochOrError nextSlot
        if
          | prevEpoch == nextEpoch ->
              Right SameEpoch
          | prevEpoch < nextEpoch ->
              if EpochNo (unEpochNo prevEpoch + 1) == nextEpoch
                then Right (NextEpoch nextEpoch)
                else Right (ManyEpochsCrossed nextEpoch)
          | otherwise ->
              Left
                ( DetectNextEpochNewSlotInPast
                    prevSlot
                    prevEpoch
                    nextSlot
                    nextEpoch
                )