{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

-- | Integration between the Shelley ledger and its corresponding (Transitional
-- Praos) protocol.
--
-- In particular, this code supports extracting the components of the ledger
-- state needed for protocol execution, both now and in a 2k-slot window.
module Cardano.Protocol.TPraos.API (
  PraosCrypto,
  GetLedgerView (..),
  LedgerView (..),
  mkInitialShelleyLedgerView,
  FutureLedgerViewError (..),
  -- $chainstate
  ChainDepState (..),
  ChainTransitionError (..),
  tickChainDepState,
  updateChainDepState,
  reupdateChainDepState,
  initialChainDepState,
  -- Leader Schedule
  checkLeaderValue,
  getLeaderSchedule,
) where

import qualified Cardano.Crypto.KES as KES
import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.BHeaderView (isOverlaySlot)
import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.BaseTypes (
  Globals (..),
  Nonce (NeutralNonce),
  Seed,
  ShelleyBase,
  UnitInterval,
  epochInfoPure,
 )
import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
import Cardano.Ledger.Binary.Plain (FromCBOR (..), ToCBOR (..), decodeRecordNamed, encodeListLen)
import Cardano.Ledger.Chain (ChainChecksPParams, pparamsToChainChecksPParams)
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Core
import Cardano.Ledger.Keys (GenDelegPair (..), GenDelegs (..), coerceKeyRole)
import Cardano.Ledger.Mary (MaryEra)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core (EraGov)
import Cardano.Ledger.Shelley.LedgerState (
  NewEpochState (..),
  curPParamsEpochStateL,
  dsGenDelegsL,
  esLStateL,
  lsCertStateL,
 )
import Cardano.Ledger.Shelley.Translation (FromByronTranslationContext (..))
import Cardano.Ledger.Slot (SlotNo)
import Cardano.Ledger.State (EraCertState (..), PoolDistr (..), individualPoolStake)
import Cardano.Protocol.Crypto
import Cardano.Protocol.TPraos.BHeader (
  BHBody,
  BHeader,
  bhbody,
  bheaderPrev,
  checkLeaderValue,
  mkSeed,
  prevHashToNonce,
  seedL,
 )
import qualified Cardano.Protocol.TPraos.Rules.Prtcl as STS.Prtcl
import Cardano.Protocol.TPraos.Rules.Tickn as STS.Tickn
import Cardano.Slotting.EpochInfo (epochInfoRange)
import Control.Arrow (left, right)
import Control.Monad.Except
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended (
  BaseM,
  Environment,
  STS,
  Signal,
  State,
  TRC (..),
  applySTS,
  reapplySTS,
 )
import Data.Either (fromRight)
import Data.Functor.Identity (runIdentity)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))

-- =======================================================

class
  ( Crypto c
  , KES.Signable (KES c) (BHBody c)
  , VRF.Signable (VRF c) Seed
  ) =>
  PraosCrypto c

instance PraosCrypto StandardCrypto

class
  ( STS (EraRule "TICKF" era)
  , BaseM (EraRule "TICKF" era) ~ ShelleyBase
  , Environment (EraRule "TICKF" era) ~ ()
  , State (EraRule "TICKF" era) ~ NewEpochState era
  , Signal (EraRule "TICKF" era) ~ SlotNo
  , EraGov era
  , EraCertState era
  ) =>
  GetLedgerView era
  where
  currentLedgerView ::
    NewEpochState era ->
    LedgerView
  default currentLedgerView ::
    ProtVerAtMost era 6 =>
    NewEpochState era ->
    LedgerView
  currentLedgerView = NewEpochState era -> LedgerView
forall era.
(ProtVerAtMost era 6, EraGov era, EraCertState era) =>
NewEpochState era -> LedgerView
view

  -- $timetravel
  futureLedgerView ::
    MonadError (FutureLedgerViewError era) m =>
    Globals ->
    NewEpochState era ->
    SlotNo ->
    m LedgerView
  default futureLedgerView ::
    ( MonadError (FutureLedgerViewError era) m
    , ProtVerAtMost era 6
    ) =>
    Globals ->
    NewEpochState era ->
    SlotNo ->
    m LedgerView
  futureLedgerView = Globals -> NewEpochState era -> SlotNo -> m LedgerView
forall era (m :: * -> *).
(MonadError (FutureLedgerViewError era) m,
 STS (EraRule "TICKF" era),
 BaseM (EraRule "TICKF" era) ~ ReaderT Globals Identity,
 Environment (EraRule "TICKF" era) ~ (),
 State (EraRule "TICKF" era) ~ NewEpochState era,
 Signal (EraRule "TICKF" era) ~ SlotNo, ProtVerAtMost era 6,
 EraGov era, EraCertState era) =>
Globals -> NewEpochState era -> SlotNo -> m LedgerView
futureView

instance GetLedgerView ShelleyEra

instance GetLedgerView AllegraEra

instance GetLedgerView MaryEra

instance GetLedgerView AlonzoEra

-- Note that although we do not use TPraos in the Babbage era, we include this
-- because it makes it simpler to get the ledger view for Praos.
instance GetLedgerView BabbageEra where
  currentLedgerView :: NewEpochState BabbageEra -> LedgerView
currentLedgerView
    NewEpochState {nesPd :: forall era. NewEpochState era -> PoolDistr
nesPd = PoolDistr
pd, nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState BabbageEra
es} =
      LedgerView
        { lvD :: UnitInterval
lvD = EpochState BabbageEra
es EpochState BabbageEra
-> Getting UnitInterval (EpochState BabbageEra) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. (PParams BabbageEra -> Const UnitInterval (PParams BabbageEra))
-> EpochState BabbageEra
-> Const UnitInterval (EpochState BabbageEra)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState BabbageEra) (PParams BabbageEra)
curPParamsEpochStateL ((PParams BabbageEra -> Const UnitInterval (PParams BabbageEra))
 -> EpochState BabbageEra
 -> Const UnitInterval (EpochState BabbageEra))
-> ((UnitInterval -> Const UnitInterval UnitInterval)
    -> PParams BabbageEra -> Const UnitInterval (PParams BabbageEra))
-> Getting UnitInterval (EpochState BabbageEra) UnitInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Const UnitInterval UnitInterval)
-> PParams BabbageEra -> Const UnitInterval (PParams BabbageEra)
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams BabbageEra) UnitInterval
ppDG
        , lvExtraEntropy :: Nonce
lvExtraEntropy = [Char] -> Nonce
forall a. HasCallStack => [Char] -> a
error [Char]
"Extra entropy is not set in the Babbage era"
        , lvPoolDistr :: PoolDistr
lvPoolDistr = PoolDistr
pd
        , lvGenDelegs :: GenDelegs
lvGenDelegs = EpochState BabbageEra
es EpochState BabbageEra
-> Getting GenDelegs (EpochState BabbageEra) GenDelegs -> GenDelegs
forall s a. s -> Getting a s a -> a
^. (LedgerState BabbageEra
 -> Const GenDelegs (LedgerState BabbageEra))
-> EpochState BabbageEra -> Const GenDelegs (EpochState BabbageEra)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState BabbageEra
  -> Const GenDelegs (LedgerState BabbageEra))
 -> EpochState BabbageEra
 -> Const GenDelegs (EpochState BabbageEra))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> LedgerState BabbageEra
    -> Const GenDelegs (LedgerState BabbageEra))
-> Getting GenDelegs (EpochState BabbageEra) GenDelegs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState BabbageEra -> Const GenDelegs (CertState BabbageEra))
-> LedgerState BabbageEra
-> Const GenDelegs (LedgerState BabbageEra)
(ShelleyCertState BabbageEra
 -> Const GenDelegs (ShelleyCertState BabbageEra))
-> LedgerState BabbageEra
-> Const GenDelegs (LedgerState BabbageEra)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((ShelleyCertState BabbageEra
  -> Const GenDelegs (ShelleyCertState BabbageEra))
 -> LedgerState BabbageEra
 -> Const GenDelegs (LedgerState BabbageEra))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> ShelleyCertState BabbageEra
    -> Const GenDelegs (ShelleyCertState BabbageEra))
-> (GenDelegs -> Const GenDelegs GenDelegs)
-> LedgerState BabbageEra
-> Const GenDelegs (LedgerState BabbageEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState BabbageEra -> Const GenDelegs (DState BabbageEra))
-> CertState BabbageEra -> Const GenDelegs (CertState BabbageEra)
(DState BabbageEra -> Const GenDelegs (DState BabbageEra))
-> ShelleyCertState BabbageEra
-> Const GenDelegs (ShelleyCertState BabbageEra)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState BabbageEra) (DState BabbageEra)
certDStateL ((DState BabbageEra -> Const GenDelegs (DState BabbageEra))
 -> ShelleyCertState BabbageEra
 -> Const GenDelegs (ShelleyCertState BabbageEra))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> DState BabbageEra -> Const GenDelegs (DState BabbageEra))
-> (GenDelegs -> Const GenDelegs GenDelegs)
-> ShelleyCertState BabbageEra
-> Const GenDelegs (ShelleyCertState BabbageEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenDelegs -> Const GenDelegs GenDelegs)
-> DState BabbageEra -> Const GenDelegs (DState BabbageEra)
forall era (f :: * -> *).
Functor f =>
(GenDelegs -> f GenDelegs) -> DState era -> f (DState era)
dsGenDelegsL
        , lvChainChecks :: ChainChecksPParams
lvChainChecks = PParams BabbageEra -> ChainChecksPParams
forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams (PParams BabbageEra -> ChainChecksPParams)
-> PParams BabbageEra -> ChainChecksPParams
forall a b. (a -> b) -> a -> b
$ EpochState BabbageEra
es EpochState BabbageEra
-> Getting
     (PParams BabbageEra) (EpochState BabbageEra) (PParams BabbageEra)
-> PParams BabbageEra
forall s a. s -> Getting a s a -> a
^. Getting
  (PParams BabbageEra) (EpochState BabbageEra) (PParams BabbageEra)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState BabbageEra) (PParams BabbageEra)
curPParamsEpochStateL
        }

  futureLedgerView :: forall (m :: * -> *).
MonadError (FutureLedgerViewError BabbageEra) m =>
Globals -> NewEpochState BabbageEra -> SlotNo -> m LedgerView
futureLedgerView Globals
globals NewEpochState BabbageEra
ss SlotNo
slot =
    Either (FutureLedgerViewError BabbageEra) LedgerView
-> m LedgerView
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      (Either (FutureLedgerViewError BabbageEra) LedgerView
 -> m LedgerView)
-> (Either
      (NonEmpty (ShelleyTickfPredFailure BabbageEra))
      (NewEpochState BabbageEra)
    -> Either (FutureLedgerViewError BabbageEra) LedgerView)
-> Either
     (NonEmpty (ShelleyTickfPredFailure BabbageEra))
     (NewEpochState BabbageEra)
-> m LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NewEpochState BabbageEra -> LedgerView)
-> Either
     (FutureLedgerViewError BabbageEra) (NewEpochState BabbageEra)
-> Either (FutureLedgerViewError BabbageEra) LedgerView
forall b c d. (b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right (forall era. GetLedgerView era => NewEpochState era -> LedgerView
currentLedgerView @BabbageEra)
      (Either
   (FutureLedgerViewError BabbageEra) (NewEpochState BabbageEra)
 -> Either (FutureLedgerViewError BabbageEra) LedgerView)
-> (Either
      (NonEmpty (ShelleyTickfPredFailure BabbageEra))
      (NewEpochState BabbageEra)
    -> Either
         (FutureLedgerViewError BabbageEra) (NewEpochState BabbageEra))
-> Either
     (NonEmpty (ShelleyTickfPredFailure BabbageEra))
     (NewEpochState BabbageEra)
-> Either (FutureLedgerViewError BabbageEra) LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (ShelleyTickfPredFailure BabbageEra)
 -> FutureLedgerViewError BabbageEra)
-> Either
     (NonEmpty (ShelleyTickfPredFailure BabbageEra))
     (NewEpochState BabbageEra)
-> Either
     (FutureLedgerViewError BabbageEra) (NewEpochState BabbageEra)
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left NonEmpty (PredicateFailure (EraRule "TICKF" BabbageEra))
-> FutureLedgerViewError BabbageEra
NonEmpty (ShelleyTickfPredFailure BabbageEra)
-> FutureLedgerViewError BabbageEra
forall era.
NonEmpty (PredicateFailure (EraRule "TICKF" era))
-> FutureLedgerViewError era
FutureLedgerViewError
      (Either
   (NonEmpty (ShelleyTickfPredFailure BabbageEra))
   (NewEpochState BabbageEra)
 -> m LedgerView)
-> Either
     (NonEmpty (ShelleyTickfPredFailure BabbageEra))
     (NewEpochState BabbageEra)
-> m LedgerView
forall a b. (a -> b) -> a -> b
$ Either
  (NonEmpty (ShelleyTickfPredFailure BabbageEra))
  (NewEpochState BabbageEra)
res
    where
      res :: Either
  (NonEmpty (ShelleyTickfPredFailure BabbageEra))
  (NewEpochState BabbageEra)
res =
        (Reader
   Globals
   (Either
      (NonEmpty (ShelleyTickfPredFailure BabbageEra))
      (NewEpochState BabbageEra))
 -> Globals
 -> Either
      (NonEmpty (ShelleyTickfPredFailure BabbageEra))
      (NewEpochState BabbageEra))
-> Globals
-> Reader
     Globals
     (Either
        (NonEmpty (ShelleyTickfPredFailure BabbageEra))
        (NewEpochState BabbageEra))
-> Either
     (NonEmpty (ShelleyTickfPredFailure BabbageEra))
     (NewEpochState BabbageEra)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals
  (Either
     (NonEmpty (ShelleyTickfPredFailure BabbageEra))
     (NewEpochState BabbageEra))
-> Globals
-> Either
     (NonEmpty (ShelleyTickfPredFailure BabbageEra))
     (NewEpochState BabbageEra)
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader
   Globals
   (Either
      (NonEmpty (ShelleyTickfPredFailure BabbageEra))
      (NewEpochState BabbageEra))
 -> Either
      (NonEmpty (ShelleyTickfPredFailure BabbageEra))
      (NewEpochState BabbageEra))
-> (TRC (ShelleyTICKF BabbageEra)
    -> Reader
         Globals
         (Either
            (NonEmpty (ShelleyTickfPredFailure BabbageEra))
            (NewEpochState BabbageEra)))
-> TRC (ShelleyTICKF BabbageEra)
-> Either
     (NonEmpty (ShelleyTickfPredFailure BabbageEra))
     (NewEpochState BabbageEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS @(EraRule "TICKF" BabbageEra)
          (TRC (ShelleyTICKF BabbageEra)
 -> Either
      (NonEmpty (ShelleyTickfPredFailure BabbageEra))
      (NewEpochState BabbageEra))
-> TRC (ShelleyTICKF BabbageEra)
-> Either
     (NonEmpty (ShelleyTickfPredFailure BabbageEra))
     (NewEpochState BabbageEra)
forall a b. (a -> b) -> a -> b
$ (Environment (ShelleyTICKF BabbageEra),
 State (ShelleyTICKF BabbageEra), Signal (ShelleyTICKF BabbageEra))
-> TRC (ShelleyTICKF BabbageEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (ShelleyTICKF BabbageEra)
NewEpochState BabbageEra
ss, SlotNo
Signal (ShelleyTICKF BabbageEra)
slot)

-- Note that although we do not use TPraos in the Conway era, we include this
-- because it makes it simpler to get the ledger view for Praos.
instance GetLedgerView ConwayEra where
  currentLedgerView :: NewEpochState ConwayEra -> LedgerView
currentLedgerView
    NewEpochState {nesPd :: forall era. NewEpochState era -> PoolDistr
nesPd = PoolDistr
pd, nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState ConwayEra
es} =
      LedgerView
        { lvD :: UnitInterval
lvD = EpochState ConwayEra
es EpochState ConwayEra
-> Getting UnitInterval (EpochState ConwayEra) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. (PParams ConwayEra -> Const UnitInterval (PParams ConwayEra))
-> EpochState ConwayEra
-> Const UnitInterval (EpochState ConwayEra)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState ConwayEra) (PParams ConwayEra)
curPParamsEpochStateL ((PParams ConwayEra -> Const UnitInterval (PParams ConwayEra))
 -> EpochState ConwayEra
 -> Const UnitInterval (EpochState ConwayEra))
-> ((UnitInterval -> Const UnitInterval UnitInterval)
    -> PParams ConwayEra -> Const UnitInterval (PParams ConwayEra))
-> Getting UnitInterval (EpochState ConwayEra) UnitInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Const UnitInterval UnitInterval)
-> PParams ConwayEra -> Const UnitInterval (PParams ConwayEra)
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams ConwayEra) UnitInterval
ppDG
        , lvExtraEntropy :: Nonce
lvExtraEntropy = [Char] -> Nonce
forall a. HasCallStack => [Char] -> a
error [Char]
"Extra entropy is not set in the Conway era"
        , lvPoolDistr :: PoolDistr
lvPoolDistr = PoolDistr
pd
        , lvGenDelegs :: GenDelegs
lvGenDelegs = EpochState ConwayEra
es EpochState ConwayEra
-> Getting GenDelegs (EpochState ConwayEra) GenDelegs -> GenDelegs
forall s a. s -> Getting a s a -> a
^. (LedgerState ConwayEra -> Const GenDelegs (LedgerState ConwayEra))
-> EpochState ConwayEra -> Const GenDelegs (EpochState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState ConwayEra -> Const GenDelegs (LedgerState ConwayEra))
 -> EpochState ConwayEra -> Const GenDelegs (EpochState ConwayEra))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> LedgerState ConwayEra
    -> Const GenDelegs (LedgerState ConwayEra))
-> Getting GenDelegs (EpochState ConwayEra) GenDelegs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState ConwayEra -> Const GenDelegs (CertState ConwayEra))
-> LedgerState ConwayEra -> Const GenDelegs (LedgerState ConwayEra)
(ConwayCertState ConwayEra
 -> Const GenDelegs (ConwayCertState ConwayEra))
-> LedgerState ConwayEra -> Const GenDelegs (LedgerState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((ConwayCertState ConwayEra
  -> Const GenDelegs (ConwayCertState ConwayEra))
 -> LedgerState ConwayEra
 -> Const GenDelegs (LedgerState ConwayEra))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> ConwayCertState ConwayEra
    -> Const GenDelegs (ConwayCertState ConwayEra))
-> (GenDelegs -> Const GenDelegs GenDelegs)
-> LedgerState ConwayEra
-> Const GenDelegs (LedgerState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState ConwayEra -> Const GenDelegs (DState ConwayEra))
-> CertState ConwayEra -> Const GenDelegs (CertState ConwayEra)
(DState ConwayEra -> Const GenDelegs (DState ConwayEra))
-> ConwayCertState ConwayEra
-> Const GenDelegs (ConwayCertState ConwayEra)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState ConwayEra) (DState ConwayEra)
certDStateL ((DState ConwayEra -> Const GenDelegs (DState ConwayEra))
 -> ConwayCertState ConwayEra
 -> Const GenDelegs (ConwayCertState ConwayEra))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> DState ConwayEra -> Const GenDelegs (DState ConwayEra))
-> (GenDelegs -> Const GenDelegs GenDelegs)
-> ConwayCertState ConwayEra
-> Const GenDelegs (ConwayCertState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenDelegs -> Const GenDelegs GenDelegs)
-> DState ConwayEra -> Const GenDelegs (DState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(GenDelegs -> f GenDelegs) -> DState era -> f (DState era)
dsGenDelegsL
        , lvChainChecks :: ChainChecksPParams
lvChainChecks = PParams ConwayEra -> ChainChecksPParams
forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams (PParams ConwayEra -> ChainChecksPParams)
-> PParams ConwayEra -> ChainChecksPParams
forall a b. (a -> b) -> a -> b
$ EpochState ConwayEra
es EpochState ConwayEra
-> Getting
     (PParams ConwayEra) (EpochState ConwayEra) (PParams ConwayEra)
-> PParams ConwayEra
forall s a. s -> Getting a s a -> a
^. Getting
  (PParams ConwayEra) (EpochState ConwayEra) (PParams ConwayEra)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState ConwayEra) (PParams ConwayEra)
curPParamsEpochStateL
        }

  futureLedgerView :: forall (m :: * -> *).
MonadError (FutureLedgerViewError ConwayEra) m =>
Globals -> NewEpochState ConwayEra -> SlotNo -> m LedgerView
futureLedgerView Globals
globals NewEpochState ConwayEra
ss SlotNo
slot =
    Either (FutureLedgerViewError ConwayEra) LedgerView -> m LedgerView
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      (Either (FutureLedgerViewError ConwayEra) LedgerView
 -> m LedgerView)
-> (Either
      (NonEmpty (ConwayTickfPredFailure ConwayEra))
      (NewEpochState ConwayEra)
    -> Either (FutureLedgerViewError ConwayEra) LedgerView)
-> Either
     (NonEmpty (ConwayTickfPredFailure ConwayEra))
     (NewEpochState ConwayEra)
-> m LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NewEpochState ConwayEra -> LedgerView)
-> Either
     (FutureLedgerViewError ConwayEra) (NewEpochState ConwayEra)
-> Either (FutureLedgerViewError ConwayEra) LedgerView
forall b c d. (b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right NewEpochState ConwayEra -> LedgerView
forall era. GetLedgerView era => NewEpochState era -> LedgerView
currentLedgerView
      (Either (FutureLedgerViewError ConwayEra) (NewEpochState ConwayEra)
 -> Either (FutureLedgerViewError ConwayEra) LedgerView)
-> (Either
      (NonEmpty (ConwayTickfPredFailure ConwayEra))
      (NewEpochState ConwayEra)
    -> Either
         (FutureLedgerViewError ConwayEra) (NewEpochState ConwayEra))
-> Either
     (NonEmpty (ConwayTickfPredFailure ConwayEra))
     (NewEpochState ConwayEra)
-> Either (FutureLedgerViewError ConwayEra) LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (ConwayTickfPredFailure ConwayEra)
 -> FutureLedgerViewError ConwayEra)
-> Either
     (NonEmpty (ConwayTickfPredFailure ConwayEra))
     (NewEpochState ConwayEra)
-> Either
     (FutureLedgerViewError ConwayEra) (NewEpochState ConwayEra)
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left NonEmpty (PredicateFailure (EraRule "TICKF" ConwayEra))
-> FutureLedgerViewError ConwayEra
NonEmpty (ConwayTickfPredFailure ConwayEra)
-> FutureLedgerViewError ConwayEra
forall era.
NonEmpty (PredicateFailure (EraRule "TICKF" era))
-> FutureLedgerViewError era
FutureLedgerViewError
      (Either
   (NonEmpty (ConwayTickfPredFailure ConwayEra))
   (NewEpochState ConwayEra)
 -> m LedgerView)
-> Either
     (NonEmpty (ConwayTickfPredFailure ConwayEra))
     (NewEpochState ConwayEra)
-> m LedgerView
forall a b. (a -> b) -> a -> b
$ Either
  (NonEmpty (ConwayTickfPredFailure ConwayEra))
  (NewEpochState ConwayEra)
res
    where
      res :: Either
  (NonEmpty (ConwayTickfPredFailure ConwayEra))
  (NewEpochState ConwayEra)
res =
        (Reader
   Globals
   (Either
      (NonEmpty (ConwayTickfPredFailure ConwayEra))
      (NewEpochState ConwayEra))
 -> Globals
 -> Either
      (NonEmpty (ConwayTickfPredFailure ConwayEra))
      (NewEpochState ConwayEra))
-> Globals
-> Reader
     Globals
     (Either
        (NonEmpty (ConwayTickfPredFailure ConwayEra))
        (NewEpochState ConwayEra))
-> Either
     (NonEmpty (ConwayTickfPredFailure ConwayEra))
     (NewEpochState ConwayEra)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals
  (Either
     (NonEmpty (ConwayTickfPredFailure ConwayEra))
     (NewEpochState ConwayEra))
-> Globals
-> Either
     (NonEmpty (ConwayTickfPredFailure ConwayEra))
     (NewEpochState ConwayEra)
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader
   Globals
   (Either
      (NonEmpty (ConwayTickfPredFailure ConwayEra))
      (NewEpochState ConwayEra))
 -> Either
      (NonEmpty (ConwayTickfPredFailure ConwayEra))
      (NewEpochState ConwayEra))
-> (TRC (ConwayTICKF ConwayEra)
    -> Reader
         Globals
         (Either
            (NonEmpty (ConwayTickfPredFailure ConwayEra))
            (NewEpochState ConwayEra)))
-> TRC (ConwayTICKF ConwayEra)
-> Either
     (NonEmpty (ConwayTickfPredFailure ConwayEra))
     (NewEpochState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS @(EraRule "TICKF" ConwayEra)
          (TRC (ConwayTICKF ConwayEra)
 -> Either
      (NonEmpty (ConwayTickfPredFailure ConwayEra))
      (NewEpochState ConwayEra))
-> TRC (ConwayTICKF ConwayEra)
-> Either
     (NonEmpty (ConwayTickfPredFailure ConwayEra))
     (NewEpochState ConwayEra)
forall a b. (a -> b) -> a -> b
$ (Environment (ConwayTICKF ConwayEra),
 State (ConwayTICKF ConwayEra), Signal (ConwayTICKF ConwayEra))
-> TRC (ConwayTICKF ConwayEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (ConwayTICKF ConwayEra)
NewEpochState ConwayEra
ss, SlotNo
Signal (ConwayTICKF ConwayEra)
slot)

-- | Data required by the Transitional Praos protocol from the Shelley ledger.
data LedgerView = LedgerView
  { LedgerView -> UnitInterval
lvD :: UnitInterval
  , -- Note that this field is not present in Babbage, but we require this view
    -- in order to construct the Babbage ledger view. We allow this to be lazy
    -- so that we may set it to an error. Note that `LedgerView` is never
    -- serialised, so this should not be forced except as a result of a
    -- programmer error.
    LedgerView -> Nonce
lvExtraEntropy :: ~Nonce
  , LedgerView -> PoolDistr
lvPoolDistr :: PoolDistr
  , LedgerView -> GenDelegs
lvGenDelegs :: GenDelegs
  , LedgerView -> ChainChecksPParams
lvChainChecks :: ChainChecksPParams
  }
  deriving (LedgerView -> LedgerView -> Bool
(LedgerView -> LedgerView -> Bool)
-> (LedgerView -> LedgerView -> Bool) -> Eq LedgerView
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LedgerView -> LedgerView -> Bool
== :: LedgerView -> LedgerView -> Bool
$c/= :: LedgerView -> LedgerView -> Bool
/= :: LedgerView -> LedgerView -> Bool
Eq, Int -> LedgerView -> ShowS
[LedgerView] -> ShowS
LedgerView -> [Char]
(Int -> LedgerView -> ShowS)
-> (LedgerView -> [Char])
-> ([LedgerView] -> ShowS)
-> Show LedgerView
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerView -> ShowS
showsPrec :: Int -> LedgerView -> ShowS
$cshow :: LedgerView -> [Char]
show :: LedgerView -> [Char]
$cshowList :: [LedgerView] -> ShowS
showList :: [LedgerView] -> ShowS
Show, (forall x. LedgerView -> Rep LedgerView x)
-> (forall x. Rep LedgerView x -> LedgerView) -> Generic LedgerView
forall x. Rep LedgerView x -> LedgerView
forall x. LedgerView -> Rep LedgerView x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LedgerView -> Rep LedgerView x
from :: forall x. LedgerView -> Rep LedgerView x
$cto :: forall x. Rep LedgerView x -> LedgerView
to :: forall x. Rep LedgerView x -> LedgerView
Generic)

instance NoThunks LedgerView

-- | Construct a protocol environment from the ledger view, along with the
-- current slot and a marker indicating whether this is the first block in a new
-- epoch.
mkPrtclEnv ::
  LedgerView ->
  -- | Epoch nonce
  Nonce ->
  STS.Prtcl.PrtclEnv
mkPrtclEnv :: LedgerView -> Nonce -> PrtclEnv
mkPrtclEnv
  LedgerView
    { UnitInterval
lvD :: LedgerView -> UnitInterval
lvD :: UnitInterval
lvD
    , PoolDistr
lvPoolDistr :: LedgerView -> PoolDistr
lvPoolDistr :: PoolDistr
lvPoolDistr
    , GenDelegs
lvGenDelegs :: LedgerView -> GenDelegs
lvGenDelegs :: GenDelegs
lvGenDelegs
    } =
    UnitInterval -> PoolDistr -> GenDelegs -> Nonce -> PrtclEnv
STS.Prtcl.PrtclEnv
      UnitInterval
lvD
      PoolDistr
lvPoolDistr
      GenDelegs
lvGenDelegs

view ::
  (ProtVerAtMost era 6, EraGov era, EraCertState era) =>
  NewEpochState era ->
  LedgerView
view :: forall era.
(ProtVerAtMost era 6, EraGov era, EraCertState era) =>
NewEpochState era -> LedgerView
view
  NewEpochState
    { nesPd :: forall era. NewEpochState era -> PoolDistr
nesPd = PoolDistr
pd
    , nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState era
es
    } =
    let !ee :: Nonce
ee = EpochState era
es EpochState era -> Getting Nonce (EpochState era) Nonce -> Nonce
forall s a. s -> Getting a s a -> a
^. (PParams era -> Const Nonce (PParams era))
-> EpochState era -> Const Nonce (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const Nonce (PParams era))
 -> EpochState era -> Const Nonce (EpochState era))
-> ((Nonce -> Const Nonce Nonce)
    -> PParams era -> Const Nonce (PParams era))
-> Getting Nonce (EpochState era) Nonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Nonce -> Const Nonce Nonce)
-> PParams era -> Const Nonce (PParams era)
forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) Nonce
Lens' (PParams era) Nonce
ppExtraEntropyL
     in LedgerView
          { lvD :: UnitInterval
lvD = EpochState era
es EpochState era
-> Getting UnitInterval (EpochState era) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. (PParams era -> Const UnitInterval (PParams era))
-> EpochState era -> Const UnitInterval (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const UnitInterval (PParams era))
 -> EpochState era -> Const UnitInterval (EpochState era))
-> ((UnitInterval -> Const UnitInterval UnitInterval)
    -> PParams era -> Const UnitInterval (PParams era))
-> Getting UnitInterval (EpochState era) UnitInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Const UnitInterval UnitInterval)
-> PParams era -> Const UnitInterval (PParams era)
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams era) UnitInterval
ppDG
          , lvExtraEntropy :: Nonce
lvExtraEntropy = Nonce
ee
          , lvPoolDistr :: PoolDistr
lvPoolDistr = PoolDistr
pd
          , lvGenDelegs :: GenDelegs
lvGenDelegs = EpochState era
es EpochState era
-> Getting GenDelegs (EpochState era) GenDelegs -> GenDelegs
forall s a. s -> Getting a s a -> a
^. (LedgerState era -> Const GenDelegs (LedgerState era))
-> EpochState era -> Const GenDelegs (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const GenDelegs (LedgerState era))
 -> EpochState era -> Const GenDelegs (EpochState era))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> LedgerState era -> Const GenDelegs (LedgerState era))
-> Getting GenDelegs (EpochState era) GenDelegs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const GenDelegs (CertState era))
-> LedgerState era -> Const GenDelegs (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const GenDelegs (CertState era))
 -> LedgerState era -> Const GenDelegs (LedgerState era))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> CertState era -> Const GenDelegs (CertState era))
-> (GenDelegs -> Const GenDelegs GenDelegs)
-> LedgerState era
-> Const GenDelegs (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const GenDelegs (DState era))
-> CertState era -> Const GenDelegs (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const GenDelegs (DState era))
 -> CertState era -> Const GenDelegs (CertState era))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> DState era -> Const GenDelegs (DState era))
-> (GenDelegs -> Const GenDelegs GenDelegs)
-> CertState era
-> Const GenDelegs (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenDelegs -> Const GenDelegs GenDelegs)
-> DState era -> Const GenDelegs (DState era)
forall era (f :: * -> *).
Functor f =>
(GenDelegs -> f GenDelegs) -> DState era -> f (DState era)
dsGenDelegsL
          , lvChainChecks :: ChainChecksPParams
lvChainChecks = PParams era -> ChainChecksPParams
forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams (PParams era -> ChainChecksPParams)
-> PParams era -> ChainChecksPParams
forall a b. (a -> b) -> a -> b
$ EpochState era
es EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
          }

-- $timetravel
--
--  Time Travel (or the anachronistic ledger view)
--
--  The ledger needs to expose access to the 'LedgerView' for a window of slots
--  around the current tip of the chain. We call this period the stability
--  window, and it corresponds to the number of slots needed to "guarantee" the
--  presence of k blocks (where k is the security parameter). This functionality
--  allows the protocol layer to validate headers without downloading
--  corresponding blocks.
--
--  The ability to travel backwards in time is obviously always possible by
--  keeping a record of past ledger states (or, more conservatively, ledger
--  views). We do not therefore deal explicitly with it in this module, though
--  see later for discussion on when snapshots should be taken.
--
--  In order to achieve forward time travel, we need a few things:
--  - Transition rules which process the body of a block should not have any
--    effect on the @LedgerView@ during the stability window after they are
--    received. This property should be guaranteed by the design of the ledger.
--  - The effect of transition rules which process the header of a block should
--    be predictable for the stability window.
--
--  We make the following claim:
--
--  A future ledger view (within the stability window) is equal to the
--  application of the TICK rule at the target slot to the curernt ledger state.

newtype FutureLedgerViewError era
  = FutureLedgerViewError (NonEmpty (PredicateFailure (EraRule "TICKF" era)))

deriving stock instance
  Eq (PredicateFailure (EraRule "TICKF" era)) =>
  Eq (FutureLedgerViewError era)

deriving stock instance
  Show (PredicateFailure (EraRule "TICKF" era)) =>
  Show (FutureLedgerViewError era)

-- | Anachronistic ledger view
--
--   Given a slot within the future stability window from our current slot (the
--   slot corresponding to the passed-in 'NewEpochState'), return a 'LedgerView'
--   appropriate to that slot.
futureView ::
  forall era m.
  ( MonadError (FutureLedgerViewError era) m
  , STS (EraRule "TICKF" era)
  , BaseM (EraRule "TICKF" era) ~ ShelleyBase
  , Environment (EraRule "TICKF" era) ~ ()
  , State (EraRule "TICKF" era) ~ NewEpochState era
  , Signal (EraRule "TICKF" era) ~ SlotNo
  , ProtVerAtMost era 6
  , EraGov era
  , EraCertState era
  ) =>
  Globals ->
  NewEpochState era ->
  SlotNo ->
  m LedgerView
futureView :: forall era (m :: * -> *).
(MonadError (FutureLedgerViewError era) m,
 STS (EraRule "TICKF" era),
 BaseM (EraRule "TICKF" era) ~ ReaderT Globals Identity,
 Environment (EraRule "TICKF" era) ~ (),
 State (EraRule "TICKF" era) ~ NewEpochState era,
 Signal (EraRule "TICKF" era) ~ SlotNo, ProtVerAtMost era 6,
 EraGov era, EraCertState era) =>
Globals -> NewEpochState era -> SlotNo -> m LedgerView
futureView Globals
globals NewEpochState era
ss SlotNo
slot =
  Either (FutureLedgerViewError era) LedgerView -> m LedgerView
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
    (Either (FutureLedgerViewError era) LedgerView -> m LedgerView)
-> (Either
      (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
      (NewEpochState era)
    -> Either (FutureLedgerViewError era) LedgerView)
-> Either
     (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
     (NewEpochState era)
-> m LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NewEpochState era -> LedgerView)
-> Either (FutureLedgerViewError era) (NewEpochState era)
-> Either (FutureLedgerViewError era) LedgerView
forall b c d. (b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right NewEpochState era -> LedgerView
forall era.
(ProtVerAtMost era 6, EraGov era, EraCertState era) =>
NewEpochState era -> LedgerView
view
    (Either (FutureLedgerViewError era) (NewEpochState era)
 -> Either (FutureLedgerViewError era) LedgerView)
-> (Either
      (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
      (NewEpochState era)
    -> Either (FutureLedgerViewError era) (NewEpochState era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
     (NewEpochState era)
-> Either (FutureLedgerViewError era) LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (PredicateFailure (EraRule "TICKF" era))
 -> FutureLedgerViewError era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
     (NewEpochState era)
-> Either (FutureLedgerViewError era) (NewEpochState era)
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left NonEmpty (PredicateFailure (EraRule "TICKF" era))
-> FutureLedgerViewError era
forall era.
NonEmpty (PredicateFailure (EraRule "TICKF" era))
-> FutureLedgerViewError era
FutureLedgerViewError
    (Either
   (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
   (NewEpochState era)
 -> m LedgerView)
-> Either
     (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
     (NewEpochState era)
-> m LedgerView
forall a b. (a -> b) -> a -> b
$ Either
  (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
  (NewEpochState era)
res
  where
    res :: Either
  (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
  (NewEpochState era)
res =
      (Reader
   Globals
   (Either
      (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
      (NewEpochState era))
 -> Globals
 -> Either
      (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
      (NewEpochState era))
-> Globals
-> Reader
     Globals
     (Either
        (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
        (NewEpochState era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
     (NewEpochState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals
  (Either
     (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
     (NewEpochState era))
-> Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
     (NewEpochState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals
        (Reader
   Globals
   (Either
      (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
      (NewEpochState era))
 -> Either
      (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
      (NewEpochState era))
-> (TRC (EraRule "TICKF" era)
    -> Reader
         Globals
         (Either
            (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
            (NewEpochState era)))
-> TRC (EraRule "TICKF" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
     (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS @(EraRule "TICKF" era)
        (TRC (EraRule "TICKF" era)
 -> Either
      (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
      (NewEpochState era))
-> TRC (EraRule "TICKF" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "TICKF" era)))
     (NewEpochState era)
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule "TICKF" era), State (EraRule "TICKF" era),
 Signal (EraRule "TICKF" era))
-> TRC (EraRule "TICKF" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (EraRule "TICKF" era)
NewEpochState era
ss, SlotNo
Signal (EraRule "TICKF" era)
slot)

-- $chainstate
--
-- Chain state operations
--
-- The chain state is an amalgam of the protocol state and the ticked nonce.

data ChainDepState = ChainDepState
  { ChainDepState -> PrtclState
csProtocol :: !STS.Prtcl.PrtclState
  , ChainDepState -> TicknState
csTickn :: !STS.Tickn.TicknState
  , ChainDepState -> Nonce
csLabNonce :: !Nonce
  -- ^ Nonce constructed from the hash of the last applied block header.
  }
  deriving (ChainDepState -> ChainDepState -> Bool
(ChainDepState -> ChainDepState -> Bool)
-> (ChainDepState -> ChainDepState -> Bool) -> Eq ChainDepState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainDepState -> ChainDepState -> Bool
== :: ChainDepState -> ChainDepState -> Bool
$c/= :: ChainDepState -> ChainDepState -> Bool
/= :: ChainDepState -> ChainDepState -> Bool
Eq, Int -> ChainDepState -> ShowS
[ChainDepState] -> ShowS
ChainDepState -> [Char]
(Int -> ChainDepState -> ShowS)
-> (ChainDepState -> [Char])
-> ([ChainDepState] -> ShowS)
-> Show ChainDepState
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainDepState -> ShowS
showsPrec :: Int -> ChainDepState -> ShowS
$cshow :: ChainDepState -> [Char]
show :: ChainDepState -> [Char]
$cshowList :: [ChainDepState] -> ShowS
showList :: [ChainDepState] -> ShowS
Show, (forall x. ChainDepState -> Rep ChainDepState x)
-> (forall x. Rep ChainDepState x -> ChainDepState)
-> Generic ChainDepState
forall x. Rep ChainDepState x -> ChainDepState
forall x. ChainDepState -> Rep ChainDepState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainDepState -> Rep ChainDepState x
from :: forall x. ChainDepState -> Rep ChainDepState x
$cto :: forall x. Rep ChainDepState x -> ChainDepState
to :: forall x. Rep ChainDepState x -> ChainDepState
Generic)

-- | Construct an initial chain state given an initial nonce and a set of
-- genesis delegates.
initialChainDepState ::
  Nonce ->
  Map (KeyHash 'Genesis) GenDelegPair ->
  ChainDepState
initialChainDepState :: Nonce -> Map (KeyHash 'Genesis) GenDelegPair -> ChainDepState
initialChainDepState Nonce
initNonce Map (KeyHash 'Genesis) GenDelegPair
genDelegs =
  ChainDepState
    { csProtocol :: PrtclState
csProtocol =
        Map (KeyHash 'BlockIssuer) Word64 -> Nonce -> Nonce -> PrtclState
STS.Prtcl.PrtclState
          Map (KeyHash 'BlockIssuer) Word64
ocertIssueNos
          Nonce
initNonce
          Nonce
initNonce
    , csTickn :: TicknState
csTickn =
        Nonce -> Nonce -> TicknState
STS.Tickn.TicknState
          Nonce
initNonce
          Nonce
NeutralNonce
    , csLabNonce :: Nonce
csLabNonce =
        Nonce
NeutralNonce
    }
  where
    ocertIssueNos :: Map (KeyHash 'BlockIssuer) Word64
ocertIssueNos =
      [(KeyHash 'BlockIssuer, Word64)]
-> Map (KeyHash 'BlockIssuer) Word64
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        ( (GenDelegPair -> (KeyHash 'BlockIssuer, Word64))
-> [GenDelegPair] -> [(KeyHash 'BlockIssuer, Word64)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (\(GenDelegPair KeyHash 'GenesisDelegate
hk VRFVerKeyHash 'GenDelegVRF
_) -> (KeyHash 'GenesisDelegate -> KeyHash 'BlockIssuer
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'GenesisDelegate
hk, Word64
0))
            (Map (KeyHash 'Genesis) GenDelegPair -> [GenDelegPair]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Genesis) GenDelegPair
genDelegs)
        )

instance NoThunks ChainDepState

instance DecCBOR ChainDepState

instance FromCBOR ChainDepState where
  fromCBOR :: forall s. Decoder s ChainDepState
fromCBOR =
    Text
-> (ChainDepState -> Int)
-> Decoder s ChainDepState
-> Decoder s ChainDepState
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed
      Text
"ChainDepState"
      (Int -> ChainDepState -> Int
forall a b. a -> b -> a
const Int
3)
      ( PrtclState -> TicknState -> Nonce -> ChainDepState
ChainDepState
          (PrtclState -> TicknState -> Nonce -> ChainDepState)
-> Decoder s PrtclState
-> Decoder s (TicknState -> Nonce -> ChainDepState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s PrtclState
forall s. Decoder s PrtclState
forall a s. FromCBOR a => Decoder s a
fromCBOR
          Decoder s (TicknState -> Nonce -> ChainDepState)
-> Decoder s TicknState -> Decoder s (Nonce -> ChainDepState)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s TicknState
forall s. Decoder s TicknState
forall a s. FromCBOR a => Decoder s a
fromCBOR
          Decoder s (Nonce -> ChainDepState)
-> Decoder s Nonce -> Decoder s ChainDepState
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s Nonce
forall s. Decoder s Nonce
forall a s. FromCBOR a => Decoder s a
fromCBOR
      )

instance EncCBOR ChainDepState

instance ToCBOR ChainDepState where
  toCBOR :: ChainDepState -> Encoding
toCBOR
    ChainDepState
      { PrtclState
csProtocol :: ChainDepState -> PrtclState
csProtocol :: PrtclState
csProtocol
      , TicknState
csTickn :: ChainDepState -> TicknState
csTickn :: TicknState
csTickn
      , Nonce
csLabNonce :: ChainDepState -> Nonce
csLabNonce :: Nonce
csLabNonce
      } =
      [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
        [ Word -> Encoding
encodeListLen Word
3
        , PrtclState -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PrtclState
csProtocol
        , TicknState -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR TicknState
csTickn
        , Nonce -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Nonce
csLabNonce
        ]

newtype ChainTransitionError c
  = ChainTransitionError (NonEmpty (PredicateFailure (STS.Prtcl.PRTCL c)))
  deriving ((forall x.
 ChainTransitionError c -> Rep (ChainTransitionError c) x)
-> (forall x.
    Rep (ChainTransitionError c) x -> ChainTransitionError c)
-> Generic (ChainTransitionError c)
forall x. Rep (ChainTransitionError c) x -> ChainTransitionError c
forall x. ChainTransitionError c -> Rep (ChainTransitionError c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (ChainTransitionError c) x -> ChainTransitionError c
forall c x.
ChainTransitionError c -> Rep (ChainTransitionError c) x
$cfrom :: forall c x.
ChainTransitionError c -> Rep (ChainTransitionError c) x
from :: forall x. ChainTransitionError c -> Rep (ChainTransitionError c) x
$cto :: forall c x.
Rep (ChainTransitionError c) x -> ChainTransitionError c
to :: forall x. Rep (ChainTransitionError c) x -> ChainTransitionError c
Generic)

instance Crypto c => NoThunks (ChainTransitionError c)

deriving instance Crypto c => Eq (ChainTransitionError c)

deriving instance Crypto c => Show (ChainTransitionError c)

-- | Tick the chain state to a new epoch.
tickChainDepState ::
  Globals ->
  LedgerView ->
  -- | Are we in a new epoch?
  Bool ->
  ChainDepState ->
  ChainDepState
tickChainDepState :: Globals -> LedgerView -> Bool -> ChainDepState -> ChainDepState
tickChainDepState
  Globals
globals
  LedgerView {Nonce
lvExtraEntropy :: LedgerView -> Nonce
lvExtraEntropy :: Nonce
lvExtraEntropy}
  Bool
isNewEpoch
  cs :: ChainDepState
cs@ChainDepState {PrtclState
csProtocol :: ChainDepState -> PrtclState
csProtocol :: PrtclState
csProtocol, TicknState
csTickn :: ChainDepState -> TicknState
csTickn :: TicknState
csTickn, Nonce
csLabNonce :: ChainDepState -> Nonce
csLabNonce :: Nonce
csLabNonce} = ChainDepState
cs {csTickn = newTickState}
    where
      STS.Prtcl.PrtclState Map (KeyHash 'BlockIssuer) Word64
_ Nonce
_ Nonce
candidateNonce = PrtclState
csProtocol
      err :: a
err = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Panic! tickChainDepState failed."
      newTickState :: TicknState
newTickState =
        TicknState
-> Either (NonEmpty TicknPredicateFailure) TicknState -> TicknState
forall b a. b -> Either a b -> b
fromRight TicknState
forall {a}. a
err
          (Either (NonEmpty TicknPredicateFailure) TicknState -> TicknState)
-> (TRC TICKN
    -> Either (NonEmpty TicknPredicateFailure) TicknState)
-> TRC TICKN
-> TicknState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reader
   Globals (Either (NonEmpty TicknPredicateFailure) TicknState)
 -> Globals -> Either (NonEmpty TicknPredicateFailure) TicknState)
-> Globals
-> Reader
     Globals (Either (NonEmpty TicknPredicateFailure) TicknState)
-> Either (NonEmpty TicknPredicateFailure) TicknState
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader Globals (Either (NonEmpty TicknPredicateFailure) TicknState)
-> Globals -> Either (NonEmpty TicknPredicateFailure) TicknState
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader
   Globals (Either (NonEmpty TicknPredicateFailure) TicknState)
 -> Either (NonEmpty TicknPredicateFailure) TicknState)
-> (TRC TICKN
    -> Reader
         Globals (Either (NonEmpty TicknPredicateFailure) TicknState))
-> TRC TICKN
-> Either (NonEmpty TicknPredicateFailure) TicknState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS @STS.Tickn.TICKN
          (TRC TICKN -> TicknState) -> TRC TICKN -> TicknState
forall a b. (a -> b) -> a -> b
$ (Environment TICKN, State TICKN, Signal TICKN) -> TRC TICKN
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
            ( Nonce -> Nonce -> Nonce -> TicknEnv
STS.Tickn.TicknEnv
                Nonce
lvExtraEntropy
                Nonce
candidateNonce
                Nonce
csLabNonce
            , State TICKN
TicknState
csTickn
            , Bool
Signal TICKN
isNewEpoch
            )

-- | Update the chain state based upon a new block header.
--
--   This also updates the last applied block hash.
updateChainDepState ::
  forall c m.
  ( PraosCrypto c
  , MonadError (ChainTransitionError c) m
  ) =>
  Globals ->
  LedgerView ->
  BHeader c ->
  ChainDepState ->
  m ChainDepState
updateChainDepState :: forall c (m :: * -> *).
(PraosCrypto c, MonadError (ChainTransitionError c) m) =>
Globals
-> LedgerView -> BHeader c -> ChainDepState -> m ChainDepState
updateChainDepState
  Globals
globals
  LedgerView
lv
  BHeader c
bh
  cs :: ChainDepState
cs@ChainDepState {PrtclState
csProtocol :: ChainDepState -> PrtclState
csProtocol :: PrtclState
csProtocol, TicknState
csTickn :: ChainDepState -> TicknState
csTickn :: TicknState
csTickn} =
    Either (ChainTransitionError c) ChainDepState -> m ChainDepState
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      (Either (ChainTransitionError c) ChainDepState -> m ChainDepState)
-> (Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
    -> Either (ChainTransitionError c) ChainDepState)
-> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
-> m ChainDepState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrtclState -> ChainDepState)
-> Either (ChainTransitionError c) PrtclState
-> Either (ChainTransitionError c) ChainDepState
forall b c d. (b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right
        ( \PrtclState
newPrtclState ->
            ChainDepState
cs
              { csProtocol = newPrtclState
              , csLabNonce = prevHashToNonce (bheaderPrev . bhbody $ bh)
              }
        )
      (Either (ChainTransitionError c) PrtclState
 -> Either (ChainTransitionError c) ChainDepState)
-> (Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
    -> Either (ChainTransitionError c) PrtclState)
-> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
-> Either (ChainTransitionError c) ChainDepState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (PrtclPredicateFailure c) -> ChainTransitionError c)
-> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
-> Either (ChainTransitionError c) PrtclState
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left NonEmpty (PredicateFailure (PRTCL c)) -> ChainTransitionError c
NonEmpty (PrtclPredicateFailure c) -> ChainTransitionError c
forall c.
NonEmpty (PredicateFailure (PRTCL c)) -> ChainTransitionError c
ChainTransitionError
      (Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
 -> m ChainDepState)
-> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
-> m ChainDepState
forall a b. (a -> b) -> a -> b
$ Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
res
    where
      res :: Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
res =
        (Reader
   Globals (Either (NonEmpty (PrtclPredicateFailure c)) PrtclState)
 -> Globals
 -> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState)
-> Globals
-> Reader
     Globals (Either (NonEmpty (PrtclPredicateFailure c)) PrtclState)
-> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals (Either (NonEmpty (PrtclPredicateFailure c)) PrtclState)
-> Globals
-> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader
   Globals (Either (NonEmpty (PrtclPredicateFailure c)) PrtclState)
 -> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState)
-> (TRC (PRTCL c)
    -> Reader
         Globals (Either (NonEmpty (PrtclPredicateFailure c)) PrtclState))
-> TRC (PRTCL c)
-> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS @(STS.Prtcl.PRTCL c)
          (TRC (PRTCL c)
 -> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState)
-> TRC (PRTCL c)
-> Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
forall a b. (a -> b) -> a -> b
$ (Environment (PRTCL c), State (PRTCL c), Signal (PRTCL c))
-> TRC (PRTCL c)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
            ( LedgerView -> Nonce -> PrtclEnv
mkPrtclEnv LedgerView
lv Nonce
epochNonce
            , State (PRTCL c)
PrtclState
csProtocol
            , Signal (PRTCL c)
BHeader c
bh
            )
      epochNonce :: Nonce
epochNonce = TicknState -> Nonce
STS.Tickn.ticknStateEpochNonce TicknState
csTickn

-- | Re-update the chain state based upon a new block header.
--
--   This function does no validation of whether the header is internally valid
--   or consistent with the chain it is being applied to; the caller must ensure
--   that this is valid through having previously applied it.
reupdateChainDepState ::
  forall c.
  PraosCrypto c =>
  Globals ->
  LedgerView ->
  BHeader c ->
  ChainDepState ->
  ChainDepState
reupdateChainDepState :: forall c.
PraosCrypto c =>
Globals
-> LedgerView -> BHeader c -> ChainDepState -> ChainDepState
reupdateChainDepState
  Globals
globals
  LedgerView
lv
  BHeader c
bh
  cs :: ChainDepState
cs@ChainDepState {PrtclState
csProtocol :: ChainDepState -> PrtclState
csProtocol :: PrtclState
csProtocol, TicknState
csTickn :: ChainDepState -> TicknState
csTickn :: TicknState
csTickn} =
    ChainDepState
cs
      { csProtocol = res
      , csLabNonce = prevHashToNonce (bheaderPrev . bhbody $ bh)
      }
    where
      res :: PrtclState
res =
        (Reader Globals PrtclState -> Globals -> PrtclState)
-> Globals -> Reader Globals PrtclState -> PrtclState
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader Globals PrtclState -> Globals -> PrtclState
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader Globals PrtclState -> PrtclState)
-> (TRC (PRTCL c) -> Reader Globals PrtclState)
-> TRC (PRTCL c)
-> PrtclState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s -> m (State s)
reapplySTS @(STS.Prtcl.PRTCL c)
          (TRC (PRTCL c) -> PrtclState) -> TRC (PRTCL c) -> PrtclState
forall a b. (a -> b) -> a -> b
$ (Environment (PRTCL c), State (PRTCL c), Signal (PRTCL c))
-> TRC (PRTCL c)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
            ( LedgerView -> Nonce -> PrtclEnv
mkPrtclEnv LedgerView
lv Nonce
epochNonce
            , State (PRTCL c)
PrtclState
csProtocol
            , Signal (PRTCL c)
BHeader c
bh
            )
      epochNonce :: Nonce
epochNonce = TicknState -> Nonce
STS.Tickn.ticknStateEpochNonce TicknState
csTickn

-- | Get the (private) leader schedule for this epoch.
--
--   Given a private VRF key, returns the set of slots in which this node is
--   eligible to lead.
getLeaderSchedule ::
  ( EraPParams era
  , VRF.VRFAlgorithm v
  , VRF.ContextVRF v ~ ()
  , VRF.Signable v Seed
  ) =>
  Globals ->
  NewEpochState era ->
  ChainDepState ->
  KeyHash 'StakePool ->
  VRF.SignKeyVRF v ->
  PParams era ->
  Set SlotNo
getLeaderSchedule :: forall era v.
(EraPParams era, VRFAlgorithm v, ContextVRF v ~ (),
 Signable v Seed) =>
Globals
-> NewEpochState era
-> ChainDepState
-> KeyHash 'StakePool
-> SignKeyVRF v
-> PParams era
-> Set SlotNo
getLeaderSchedule Globals
globals NewEpochState era
ss ChainDepState
cds KeyHash 'StakePool
poolHash SignKeyVRF v
key PParams era
pp = (SlotNo -> Bool) -> Set SlotNo -> Set SlotNo
forall a. (a -> Bool) -> Set a -> Set a
Set.filter SlotNo -> Bool
isLeader Set SlotNo
epochSlots
  where
    isLeader :: SlotNo -> Bool
isLeader SlotNo
slotNo =
      let y :: CertifiedVRF v Seed
y = ContextVRF v -> Seed -> SignKeyVRF v -> CertifiedVRF v Seed
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified () (Nonce -> SlotNo -> Nonce -> Seed
mkSeed Nonce
seedL SlotNo
slotNo Nonce
epochNonce) SignKeyVRF v
key
       in Bool -> Bool
not (SlotNo -> UnitInterval -> SlotNo -> Bool
isOverlaySlot SlotNo
a (PParams era
pp PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams era) UnitInterval
ppDG) SlotNo
slotNo)
            Bool -> Bool -> Bool
&& OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue (CertifiedVRF v Seed -> OutputVRF v
forall v a. CertifiedVRF v a -> OutputVRF v
VRF.certifiedOutput CertifiedVRF v Seed
y) Rational
stake ActiveSlotCoeff
f
    stake :: Rational
stake = Rational
-> (IndividualPoolStake -> Rational)
-> Maybe IndividualPoolStake
-> Rational
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rational
0 IndividualPoolStake -> Rational
individualPoolStake (Maybe IndividualPoolStake -> Rational)
-> Maybe IndividualPoolStake -> Rational
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Maybe IndividualPoolStake
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
poolHash Map (KeyHash 'StakePool) IndividualPoolStake
poolDistr
    poolDistr :: Map (KeyHash 'StakePool) IndividualPoolStake
poolDistr = PoolDistr -> Map (KeyHash 'StakePool) IndividualPoolStake
unPoolDistr (PoolDistr -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> PoolDistr -> Map (KeyHash 'StakePool) IndividualPoolStake
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> PoolDistr
forall era. NewEpochState era -> PoolDistr
nesPd NewEpochState era
ss
    STS.Tickn.TicknState Nonce
epochNonce Nonce
_ = ChainDepState -> TicknState
csTickn ChainDepState
cds
    currentEpoch :: EpochNo
currentEpoch = NewEpochState era -> EpochNo
forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
ss
    ei :: EpochInfo Identity
ei = Globals -> EpochInfo Identity
epochInfoPure Globals
globals
    f :: ActiveSlotCoeff
f = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals
    epochSlots :: Set SlotNo
epochSlots = [SlotNo] -> Set SlotNo
forall a. Ord a => [a] -> Set a
Set.fromList [SlotNo
a .. SlotNo
b]
    (SlotNo
a, SlotNo
b) = Identity (SlotNo, SlotNo) -> (SlotNo, SlotNo)
forall a. Identity a -> a
runIdentity (Identity (SlotNo, SlotNo) -> (SlotNo, SlotNo))
-> Identity (SlotNo, SlotNo) -> (SlotNo, SlotNo)
forall a b. (a -> b) -> a -> b
$ EpochInfo Identity -> EpochNo -> Identity (SlotNo, SlotNo)
forall (m :: * -> *).
Monad m =>
EpochInfo m -> EpochNo -> m (SlotNo, SlotNo)
epochInfoRange EpochInfo Identity
ei EpochNo
currentEpoch

-- | We construct a 'LedgerView' using the Shelley genesis config in the same
-- way as 'translateToShelleyLedgerState'.
mkInitialShelleyLedgerView ::
  FromByronTranslationContext ->
  LedgerView
mkInitialShelleyLedgerView :: FromByronTranslationContext -> LedgerView
mkInitialShelleyLedgerView FromByronTranslationContext
transCtxt =
  let !ee :: Nonce
ee = FromByronTranslationContext -> PParams ShelleyEra
fbtcProtocolParams FromByronTranslationContext
transCtxt PParams ShelleyEra
-> Getting Nonce (PParams ShelleyEra) Nonce -> Nonce
forall s a. s -> Getting a s a -> a
^. Getting Nonce (PParams ShelleyEra) Nonce
forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) Nonce
Lens' (PParams ShelleyEra) Nonce
ppExtraEntropyL
   in LedgerView
        { lvD :: UnitInterval
lvD = FromByronTranslationContext -> PParams ShelleyEra
fbtcProtocolParams FromByronTranslationContext
transCtxt PParams ShelleyEra
-> Getting UnitInterval (PParams ShelleyEra) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams ShelleyEra) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams ShelleyEra) UnitInterval
ppDG
        , lvExtraEntropy :: Nonce
lvExtraEntropy = Nonce
ee
        , lvPoolDistr :: PoolDistr
lvPoolDistr = Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr Map (KeyHash 'StakePool) IndividualPoolStake
forall k a. Map k a
Map.empty CompactForm Coin
forall a. Monoid a => a
mempty
        , lvGenDelegs :: GenDelegs
lvGenDelegs = Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs (Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs)
-> Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
forall a b. (a -> b) -> a -> b
$ FromByronTranslationContext -> Map (KeyHash 'Genesis) GenDelegPair
fbtcGenDelegs FromByronTranslationContext
transCtxt
        , lvChainChecks :: ChainChecksPParams
lvChainChecks = PParams ShelleyEra -> ChainChecksPParams
forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams (PParams ShelleyEra -> ChainChecksPParams)
-> (FromByronTranslationContext -> PParams ShelleyEra)
-> FromByronTranslationContext
-> ChainChecksPParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromByronTranslationContext -> PParams ShelleyEra
fbtcProtocolParams (FromByronTranslationContext -> ChainChecksPParams)
-> FromByronTranslationContext -> ChainChecksPParams
forall a b. (a -> b) -> a -> b
$ FromByronTranslationContext
transCtxt
        }