{-# 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 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 Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen)
import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Alonzo (AlonzoEra)
import qualified Cardano.Ledger.Alonzo.PParams as Alonzo (PParams' (..))
import Cardano.Ledger.BHeaderView (isOverlaySlot)
import Cardano.Ledger.Babbage (BabbageEra)
import qualified Cardano.Ledger.Babbage.PParams as Babbage (PParams' (..))
import Cardano.Ledger.BaseTypes
  ( Globals (..),
    Nonce (NeutralNonce),
    ProtVer,
    Seed,
    ShelleyBase,
    UnitInterval,
    epochInfoPure,
  )
import Cardano.Ledger.Chain (ChainChecksPParams, pparamsToChainChecksPParams)
import Cardano.Ledger.Core (ChainData, SerialisableData)
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Crypto as CC (Crypto, StandardCrypto, VRF)
import Cardano.Ledger.Era (Crypto, Era)
import Cardano.Ledger.Keys
  ( DSignable,
    GenDelegPair (..),
    GenDelegs (..),
    KESignable,
    KeyHash,
    KeyRole (..),
    SignKeyVRF,
    VRFSignable,
    coerceKeyRole,
  )
import Cardano.Ledger.Mary (MaryEra)
import Cardano.Ledger.PoolDistr (PoolDistr (..), individualPoolStake)
import Cardano.Ledger.Serialization (decodeRecordNamed)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Genesis (ShelleyGenesis (..))
import Cardano.Ledger.Shelley.LedgerState
  ( EpochState (..),
    NewEpochState (..),
    dpsDState,
    lsDPState,
    _genDelegs,
  )
import Cardano.Ledger.Shelley.PParams (PParams' (..))
import Cardano.Ledger.Shelley.Rules.EraMapping ()
import Cardano.Ledger.Shelley.Rules.Tick (TickfPredicateFailure)
import Cardano.Ledger.Slot (SlotNo)
import Cardano.Protocol.TPraos.BHeader
  ( BHBody,
    BHeader,
    bhbody,
    bheaderPrev,
    checkLeaderValue,
    mkSeed,
    prevHashToNonce,
    seedL,
  )
import Cardano.Protocol.TPraos.OCert (OCertSignable)
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.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 GHC.Records
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)

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

class
  ( CC.Crypto c,
    DSignable c (OCertSignable c),
    KESignable c (BHBody c),
    VRFSignable c Seed
  ) =>
  PraosCrypto c

instance PraosCrypto CC.StandardCrypto

class
  ( ChainData (ChainDepState (Crypto era)),
    SerialisableData (ChainDepState (Crypto era)),
    Eq (ChainTransitionError (Crypto era)),
    Show (ChainTransitionError (Crypto era)),
    Show (LedgerView (Crypto era)),
    Show (FutureLedgerViewError era),
    STS (Core.EraRule "TICKF" era),
    BaseM (Core.EraRule "TICKF" era) ~ ShelleyBase,
    Environment (Core.EraRule "TICKF" era) ~ (),
    State (Core.EraRule "TICKF" era) ~ NewEpochState era,
    Signal (Core.EraRule "TICKF" era) ~ SlotNo,
    PredicateFailure (Core.EraRule "TICKF" era) ~ TickfPredicateFailure era,
    HasField "_d" (Core.PParams era) UnitInterval,
    HasField "_maxBBSize" (Core.PParams era) Natural,
    HasField "_maxBHSize" (Core.PParams era) Natural,
    HasField "_protocolVersion" (Core.PParams era) ProtVer
  ) =>
  GetLedgerView era
  where
  currentLedgerView ::
    NewEpochState era ->
    LedgerView (Crypto era)
  default currentLedgerView ::
    HasField "_extraEntropy" (Core.PParams era) Nonce =>
    NewEpochState era ->
    LedgerView (Crypto era)
  currentLedgerView = NewEpochState era -> LedgerView (Crypto era)
forall era.
(HasField "_d" (PParams era) UnitInterval,
 HasField "_extraEntropy" (PParams era) Nonce,
 HasField "_maxBBSize" (PParams era) Natural,
 HasField "_maxBHSize" (PParams era) Natural,
 HasField "_protocolVersion" (PParams era) ProtVer) =>
NewEpochState era -> LedgerView (Crypto era)
view

  -- $timetravel
  futureLedgerView ::
    MonadError (FutureLedgerViewError era) m =>
    Globals ->
    NewEpochState era ->
    SlotNo ->
    m (LedgerView (Crypto era))
  default futureLedgerView ::
    ( MonadError (FutureLedgerViewError era) m,
      HasField "_extraEntropy" (Core.PParams era) Nonce
    ) =>
    Globals ->
    NewEpochState era ->
    SlotNo ->
    m (LedgerView (Crypto era))
  futureLedgerView = Globals
-> NewEpochState era -> SlotNo -> m (LedgerView (Crypto era))
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,
 PredicateFailure (EraRule "TICKF" era) ~ TickfPredicateFailure era,
 HasField "_d" (PParams era) UnitInterval,
 HasField "_extraEntropy" (PParams era) Nonce,
 HasField "_maxBBSize" (PParams era) Natural,
 HasField "_maxBHSize" (PParams era) Natural,
 HasField "_protocolVersion" (PParams era) ProtVer) =>
Globals
-> NewEpochState era -> SlotNo -> m (LedgerView (Crypto era))
futureView

instance CC.Crypto crypto => GetLedgerView (ShelleyEra crypto)

instance CC.Crypto c => GetLedgerView (AllegraEra c)

instance CC.Crypto c => GetLedgerView (MaryEra c)

instance CC.Crypto c => GetLedgerView (AlonzoEra c)

-- 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 CC.Crypto c => GetLedgerView (BabbageEra c) where
  currentLedgerView :: NewEpochState (BabbageEra c) -> LedgerView (Crypto (BabbageEra c))
currentLedgerView
    NewEpochState {nesPd :: forall era. NewEpochState era -> PoolDistr (Crypto era)
nesPd = PoolDistr (Crypto (BabbageEra c))
pd, nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState (BabbageEra c)
es} =
      LedgerView :: forall crypto.
UnitInterval
-> Nonce
-> PoolDistr crypto
-> GenDelegs crypto
-> ChainChecksPParams
-> LedgerView crypto
LedgerView
        { lvD :: UnitInterval
lvD = forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "_d" r a => r -> a
getField @"_d" (PParams (BabbageEra c) -> UnitInterval)
-> (EpochState (BabbageEra c) -> PParams (BabbageEra c))
-> EpochState (BabbageEra c)
-> UnitInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState (BabbageEra c) -> PParams (BabbageEra c)
forall era. EpochState era -> PParams era
esPp (EpochState (BabbageEra c) -> UnitInterval)
-> EpochState (BabbageEra c) -> UnitInterval
forall a b. (a -> b) -> a -> b
$ EpochState (BabbageEra c)
es,
          lvExtraEntropy :: Nonce
lvExtraEntropy = [Char] -> Nonce
forall a. HasCallStack => [Char] -> a
error [Char]
"Extra entropy is not set in the Babbage era",
          lvPoolDistr :: PoolDistr c
lvPoolDistr = PoolDistr c
PoolDistr (Crypto (BabbageEra c))
pd,
          lvGenDelegs :: GenDelegs c
lvGenDelegs =
            DState c -> GenDelegs c
forall crypto. DState crypto -> GenDelegs crypto
_genDelegs (DState c -> GenDelegs c)
-> (LedgerState (BabbageEra c) -> DState c)
-> LedgerState (BabbageEra c)
-> GenDelegs c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DPState c -> DState c
forall crypto. DPState crypto -> DState crypto
dpsDState
              (DPState c -> DState c)
-> (LedgerState (BabbageEra c) -> DPState c)
-> LedgerState (BabbageEra c)
-> DState c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (BabbageEra c) -> DPState c
forall era. LedgerState era -> DPState (Crypto era)
lsDPState
              (LedgerState (BabbageEra c) -> GenDelegs c)
-> LedgerState (BabbageEra c) -> GenDelegs c
forall a b. (a -> b) -> a -> b
$ EpochState (BabbageEra c) -> LedgerState (BabbageEra c)
forall era. EpochState era -> LedgerState era
esLState EpochState (BabbageEra c)
es,
          lvChainChecks :: ChainChecksPParams
lvChainChecks = PParams (BabbageEra c) -> ChainChecksPParams
forall pp.
(HasField "_maxBHSize" pp Natural,
 HasField "_maxBBSize" pp Natural,
 HasField "_protocolVersion" pp ProtVer) =>
pp -> ChainChecksPParams
pparamsToChainChecksPParams (PParams (BabbageEra c) -> ChainChecksPParams)
-> (EpochState (BabbageEra c) -> PParams (BabbageEra c))
-> EpochState (BabbageEra c)
-> ChainChecksPParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState (BabbageEra c) -> PParams (BabbageEra c)
forall era. EpochState era -> PParams era
esPp (EpochState (BabbageEra c) -> ChainChecksPParams)
-> EpochState (BabbageEra c) -> ChainChecksPParams
forall a b. (a -> b) -> a -> b
$ EpochState (BabbageEra c)
es
        }

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

-- | Data required by the Transitional Praos protocol from the Shelley ledger.
data LedgerView crypto = LedgerView
  { LedgerView crypto -> 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 crypto -> Nonce
lvExtraEntropy :: ~Nonce,
    LedgerView crypto -> PoolDistr crypto
lvPoolDistr :: PoolDistr crypto,
    LedgerView crypto -> GenDelegs crypto
lvGenDelegs :: GenDelegs crypto,
    LedgerView crypto -> ChainChecksPParams
lvChainChecks :: ChainChecksPParams
  }
  deriving (LedgerView crypto -> LedgerView crypto -> Bool
(LedgerView crypto -> LedgerView crypto -> Bool)
-> (LedgerView crypto -> LedgerView crypto -> Bool)
-> Eq (LedgerView crypto)
forall crypto. LedgerView crypto -> LedgerView crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LedgerView crypto -> LedgerView crypto -> Bool
$c/= :: forall crypto. LedgerView crypto -> LedgerView crypto -> Bool
== :: LedgerView crypto -> LedgerView crypto -> Bool
$c== :: forall crypto. LedgerView crypto -> LedgerView crypto -> Bool
Eq, Int -> LedgerView crypto -> ShowS
[LedgerView crypto] -> ShowS
LedgerView crypto -> [Char]
(Int -> LedgerView crypto -> ShowS)
-> (LedgerView crypto -> [Char])
-> ([LedgerView crypto] -> ShowS)
-> Show (LedgerView crypto)
forall crypto. Int -> LedgerView crypto -> ShowS
forall crypto. [LedgerView crypto] -> ShowS
forall crypto. LedgerView crypto -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LedgerView crypto] -> ShowS
$cshowList :: forall crypto. [LedgerView crypto] -> ShowS
show :: LedgerView crypto -> [Char]
$cshow :: forall crypto. LedgerView crypto -> [Char]
showsPrec :: Int -> LedgerView crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> LedgerView crypto -> ShowS
Show, (forall x. LedgerView crypto -> Rep (LedgerView crypto) x)
-> (forall x. Rep (LedgerView crypto) x -> LedgerView crypto)
-> Generic (LedgerView crypto)
forall x. Rep (LedgerView crypto) x -> LedgerView crypto
forall x. LedgerView crypto -> Rep (LedgerView crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x. Rep (LedgerView crypto) x -> LedgerView crypto
forall crypto x. LedgerView crypto -> Rep (LedgerView crypto) x
$cto :: forall crypto x. Rep (LedgerView crypto) x -> LedgerView crypto
$cfrom :: forall crypto x. LedgerView crypto -> Rep (LedgerView crypto) x
Generic)

instance NoThunks (LedgerView crypto)

-- | 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 crypto ->
  -- | Epoch nonce
  Nonce ->
  STS.Prtcl.PrtclEnv crypto
mkPrtclEnv :: LedgerView crypto -> Nonce -> PrtclEnv crypto
mkPrtclEnv
  LedgerView
    { UnitInterval
lvD :: UnitInterval
lvD :: forall crypto. LedgerView crypto -> UnitInterval
lvD,
      PoolDistr crypto
lvPoolDistr :: PoolDistr crypto
lvPoolDistr :: forall crypto. LedgerView crypto -> PoolDistr crypto
lvPoolDistr,
      GenDelegs crypto
lvGenDelegs :: GenDelegs crypto
lvGenDelegs :: forall crypto. LedgerView crypto -> GenDelegs crypto
lvGenDelegs
    } =
    UnitInterval
-> PoolDistr crypto -> GenDelegs crypto -> Nonce -> PrtclEnv crypto
forall crypto.
UnitInterval
-> PoolDistr crypto -> GenDelegs crypto -> Nonce -> PrtclEnv crypto
STS.Prtcl.PrtclEnv
      UnitInterval
lvD
      PoolDistr crypto
lvPoolDistr
      GenDelegs crypto
lvGenDelegs

view ::
  ( HasField "_d" (Core.PParams era) UnitInterval,
    HasField "_extraEntropy" (Core.PParams era) Nonce,
    HasField "_maxBBSize" (Core.PParams era) Natural,
    HasField "_maxBHSize" (Core.PParams era) Natural,
    HasField "_protocolVersion" (Core.PParams era) ProtVer
  ) =>
  NewEpochState era ->
  LedgerView (Crypto era)
view :: NewEpochState era -> LedgerView (Crypto era)
view
  NewEpochState
    { nesPd :: forall era. NewEpochState era -> PoolDistr (Crypto era)
nesPd = PoolDistr (Crypto era)
pd,
      nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState era
es
    } =
    let !ee :: Nonce
ee = forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "_extraEntropy" r a => r -> a
getField @"_extraEntropy" (PParams era -> Nonce)
-> (EpochState era -> PParams era) -> EpochState era -> Nonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> PParams era
forall era. EpochState era -> PParams era
esPp (EpochState era -> Nonce) -> EpochState era -> Nonce
forall a b. (a -> b) -> a -> b
$ EpochState era
es
     in LedgerView :: forall crypto.
UnitInterval
-> Nonce
-> PoolDistr crypto
-> GenDelegs crypto
-> ChainChecksPParams
-> LedgerView crypto
LedgerView
          { lvD :: UnitInterval
lvD = forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "_d" r a => r -> a
getField @"_d" (PParams era -> UnitInterval)
-> (EpochState era -> PParams era)
-> EpochState era
-> UnitInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> PParams era
forall era. EpochState era -> PParams era
esPp (EpochState era -> UnitInterval) -> EpochState era -> UnitInterval
forall a b. (a -> b) -> a -> b
$ EpochState era
es,
            lvExtraEntropy :: Nonce
lvExtraEntropy = Nonce
ee,
            lvPoolDistr :: PoolDistr (Crypto era)
lvPoolDistr = PoolDistr (Crypto era)
pd,
            lvGenDelegs :: GenDelegs (Crypto era)
lvGenDelegs =
              DState (Crypto era) -> GenDelegs (Crypto era)
forall crypto. DState crypto -> GenDelegs crypto
_genDelegs (DState (Crypto era) -> GenDelegs (Crypto era))
-> (LedgerState era -> DState (Crypto era))
-> LedgerState era
-> GenDelegs (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DPState (Crypto era) -> DState (Crypto era)
forall crypto. DPState crypto -> DState crypto
dpsDState
                (DPState (Crypto era) -> DState (Crypto era))
-> (LedgerState era -> DPState (Crypto era))
-> LedgerState era
-> DState (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState era -> DPState (Crypto era)
forall era. LedgerState era -> DPState (Crypto era)
lsDPState
                (LedgerState era -> GenDelegs (Crypto era))
-> LedgerState era -> GenDelegs (Crypto era)
forall a b. (a -> b) -> a -> b
$ EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es,
            lvChainChecks :: ChainChecksPParams
lvChainChecks = PParams era -> ChainChecksPParams
forall pp.
(HasField "_maxBHSize" pp Natural,
 HasField "_maxBBSize" pp Natural,
 HasField "_protocolVersion" pp ProtVer) =>
pp -> ChainChecksPParams
pparamsToChainChecksPParams (PParams era -> ChainChecksPParams)
-> (EpochState era -> PParams era)
-> EpochState era
-> ChainChecksPParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> PParams era
forall era. EpochState era -> PParams era
esPp (EpochState era -> ChainChecksPParams)
-> EpochState era -> ChainChecksPParams
forall a b. (a -> b) -> a -> b
$ EpochState era
es
          }

-- $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 [PredicateFailure (Core.EraRule "TICKF" era)]

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

deriving stock instance
  (Show (PredicateFailure (Core.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 (Core.EraRule "TICKF" era),
    BaseM (Core.EraRule "TICKF" era) ~ ShelleyBase,
    Environment (Core.EraRule "TICKF" era) ~ (),
    State (Core.EraRule "TICKF" era) ~ NewEpochState era,
    Signal (Core.EraRule "TICKF" era) ~ SlotNo,
    PredicateFailure (Core.EraRule "TICKF" era) ~ TickfPredicateFailure era,
    HasField "_d" (Core.PParams era) UnitInterval,
    HasField "_extraEntropy" (Core.PParams era) Nonce,
    HasField "_maxBBSize" (Core.PParams era) Natural,
    HasField "_maxBHSize" (Core.PParams era) Natural,
    HasField "_protocolVersion" (Core.PParams era) ProtVer
  ) =>
  Globals ->
  NewEpochState era ->
  SlotNo ->
  m (LedgerView (Crypto era))
futureView :: Globals
-> NewEpochState era -> SlotNo -> m (LedgerView (Crypto era))
futureView Globals
globals NewEpochState era
ss SlotNo
slot =
  Either (FutureLedgerViewError era) (LedgerView (Crypto era))
-> m (LedgerView (Crypto era))
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
    (Either (FutureLedgerViewError era) (LedgerView (Crypto era))
 -> m (LedgerView (Crypto era)))
-> (Either [TickfPredicateFailure era] (NewEpochState era)
    -> Either (FutureLedgerViewError era) (LedgerView (Crypto era)))
-> Either [TickfPredicateFailure era] (NewEpochState era)
-> m (LedgerView (Crypto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NewEpochState era -> LedgerView (Crypto era))
-> Either (FutureLedgerViewError era) (NewEpochState era)
-> Either (FutureLedgerViewError era) (LedgerView (Crypto era))
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right NewEpochState era -> LedgerView (Crypto era)
forall era.
(HasField "_d" (PParams era) UnitInterval,
 HasField "_extraEntropy" (PParams era) Nonce,
 HasField "_maxBBSize" (PParams era) Natural,
 HasField "_maxBHSize" (PParams era) Natural,
 HasField "_protocolVersion" (PParams era) ProtVer) =>
NewEpochState era -> LedgerView (Crypto era)
view
    (Either (FutureLedgerViewError era) (NewEpochState era)
 -> Either (FutureLedgerViewError era) (LedgerView (Crypto era)))
-> (Either [TickfPredicateFailure era] (NewEpochState era)
    -> Either (FutureLedgerViewError era) (NewEpochState era))
-> Either [TickfPredicateFailure era] (NewEpochState era)
-> Either (FutureLedgerViewError era) (LedgerView (Crypto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PredicateFailure (EraRule "TICKF" era)]
 -> FutureLedgerViewError era)
-> Either
     [PredicateFailure (EraRule "TICKF" era)] (NewEpochState era)
-> Either (FutureLedgerViewError era) (NewEpochState era)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left [PredicateFailure (EraRule "TICKF" era)]
-> FutureLedgerViewError era
forall era.
[PredicateFailure (EraRule "TICKF" era)]
-> FutureLedgerViewError era
FutureLedgerViewError
    (Either [TickfPredicateFailure era] (NewEpochState era)
 -> m (LedgerView (Crypto era)))
-> Either [TickfPredicateFailure era] (NewEpochState era)
-> m (LedgerView (Crypto era))
forall a b. (a -> b) -> a -> b
$ Either [TickfPredicateFailure era] (NewEpochState era)
res
  where
    res :: Either [TickfPredicateFailure era] (NewEpochState era)
res =
      (Reader
   Globals (Either [TickfPredicateFailure era] (NewEpochState era))
 -> Globals
 -> Either [TickfPredicateFailure era] (NewEpochState era))
-> Globals
-> Reader
     Globals (Either [TickfPredicateFailure era] (NewEpochState era))
-> Either [TickfPredicateFailure era] (NewEpochState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals (Either [TickfPredicateFailure era] (NewEpochState era))
-> Globals
-> Either [TickfPredicateFailure era] (NewEpochState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals
        (Reader
   Globals (Either [TickfPredicateFailure era] (NewEpochState era))
 -> Either [TickfPredicateFailure era] (NewEpochState era))
-> (TRC (EraRule "TICKF" era)
    -> Reader
         Globals (Either [TickfPredicateFailure era] (NewEpochState era)))
-> TRC (EraRule "TICKF" era)
-> Either [TickfPredicateFailure 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 [PredicateFailure s] (State s))
forall (m :: * -> *) (rtype :: RuleType).
(STS (EraRule "TICKF" era), RuleTypeRep rtype,
 m ~ BaseM (EraRule "TICKF" era)) =>
RuleContext rtype (EraRule "TICKF" era)
-> m (Either
        [PredicateFailure (EraRule "TICKF" era)]
        (State (EraRule "TICKF" era)))
applySTS @(Core.EraRule "TICKF" era)
        (TRC (EraRule "TICKF" era)
 -> Either [TickfPredicateFailure era] (NewEpochState era))
-> TRC (EraRule "TICKF" era)
-> Either [TickfPredicateFailure 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 ((), NewEpochState era
State (EraRule "TICKF" 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 crypto = ChainDepState
  { ChainDepState crypto -> PrtclState crypto
csProtocol :: !(STS.Prtcl.PrtclState crypto),
    ChainDepState crypto -> TicknState
csTickn :: !STS.Tickn.TicknState,
    -- | Nonce constructed from the hash of the last applied block header.
    ChainDepState crypto -> Nonce
csLabNonce :: !Nonce
  }
  deriving (ChainDepState crypto -> ChainDepState crypto -> Bool
(ChainDepState crypto -> ChainDepState crypto -> Bool)
-> (ChainDepState crypto -> ChainDepState crypto -> Bool)
-> Eq (ChainDepState crypto)
forall crypto. ChainDepState crypto -> ChainDepState crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainDepState crypto -> ChainDepState crypto -> Bool
$c/= :: forall crypto. ChainDepState crypto -> ChainDepState crypto -> Bool
== :: ChainDepState crypto -> ChainDepState crypto -> Bool
$c== :: forall crypto. ChainDepState crypto -> ChainDepState crypto -> Bool
Eq, Int -> ChainDepState crypto -> ShowS
[ChainDepState crypto] -> ShowS
ChainDepState crypto -> [Char]
(Int -> ChainDepState crypto -> ShowS)
-> (ChainDepState crypto -> [Char])
-> ([ChainDepState crypto] -> ShowS)
-> Show (ChainDepState crypto)
forall crypto. Int -> ChainDepState crypto -> ShowS
forall crypto. [ChainDepState crypto] -> ShowS
forall crypto. ChainDepState crypto -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ChainDepState crypto] -> ShowS
$cshowList :: forall crypto. [ChainDepState crypto] -> ShowS
show :: ChainDepState crypto -> [Char]
$cshow :: forall crypto. ChainDepState crypto -> [Char]
showsPrec :: Int -> ChainDepState crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> ChainDepState crypto -> ShowS
Show, (forall x. ChainDepState crypto -> Rep (ChainDepState crypto) x)
-> (forall x. Rep (ChainDepState crypto) x -> ChainDepState crypto)
-> Generic (ChainDepState crypto)
forall x. Rep (ChainDepState crypto) x -> ChainDepState crypto
forall x. ChainDepState crypto -> Rep (ChainDepState crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x.
Rep (ChainDepState crypto) x -> ChainDepState crypto
forall crypto x.
ChainDepState crypto -> Rep (ChainDepState crypto) x
$cto :: forall crypto x.
Rep (ChainDepState crypto) x -> ChainDepState crypto
$cfrom :: forall crypto x.
ChainDepState crypto -> Rep (ChainDepState crypto) x
Generic)

-- | Construct an initial chain state given an initial nonce and a set of
-- genesis delegates.
initialChainDepState ::
  Nonce ->
  Map (KeyHash 'Genesis crypto) (GenDelegPair crypto) ->
  ChainDepState crypto
initialChainDepState :: Nonce
-> Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> ChainDepState crypto
initialChainDepState Nonce
initNonce Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
genDelegs =
  ChainDepState :: forall crypto.
PrtclState crypto -> TicknState -> Nonce -> ChainDepState crypto
ChainDepState
    { csProtocol :: PrtclState crypto
csProtocol =
        Map (KeyHash 'BlockIssuer crypto) Word64
-> Nonce -> Nonce -> PrtclState crypto
forall crypto.
Map (KeyHash 'BlockIssuer crypto) Word64
-> Nonce -> Nonce -> PrtclState crypto
STS.Prtcl.PrtclState
          Map (KeyHash 'BlockIssuer crypto) 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 crypto) Word64
ocertIssueNos =
      [(KeyHash 'BlockIssuer crypto, Word64)]
-> Map (KeyHash 'BlockIssuer crypto) Word64
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        ( (GenDelegPair crypto -> (KeyHash 'BlockIssuer crypto, Word64))
-> [GenDelegPair crypto] -> [(KeyHash 'BlockIssuer crypto, Word64)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (\(GenDelegPair KeyHash 'GenesisDelegate crypto
hk Hash crypto (VerKeyVRF crypto)
_) -> (KeyHash 'GenesisDelegate crypto -> KeyHash 'BlockIssuer crypto
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto
       (r' :: KeyRole).
HasKeyRole a =>
a r crypto -> a r' crypto
coerceKeyRole KeyHash 'GenesisDelegate crypto
hk, Word64
0))
            (Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> [GenDelegPair crypto]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
genDelegs)
        )

instance CC.Crypto crypto => NoThunks (ChainDepState crypto)

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

instance CC.Crypto crypto => ToCBOR (ChainDepState crypto) where
  toCBOR :: ChainDepState crypto -> Encoding
toCBOR
    ChainDepState
      { PrtclState crypto
csProtocol :: PrtclState crypto
csProtocol :: forall crypto. ChainDepState crypto -> PrtclState crypto
csProtocol,
        TicknState
csTickn :: TicknState
csTickn :: forall crypto. ChainDepState crypto -> TicknState
csTickn,
        Nonce
csLabNonce :: Nonce
csLabNonce :: forall crypto. ChainDepState crypto -> Nonce
csLabNonce
      } =
      [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
        [ Word -> Encoding
encodeListLen Word
3,
          PrtclState crypto -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PrtclState crypto
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 crypto
  = ChainTransitionError [PredicateFailure (STS.Prtcl.PRTCL crypto)]
  deriving ((forall x.
 ChainTransitionError crypto -> Rep (ChainTransitionError crypto) x)
-> (forall x.
    Rep (ChainTransitionError crypto) x -> ChainTransitionError crypto)
-> Generic (ChainTransitionError crypto)
forall x.
Rep (ChainTransitionError crypto) x -> ChainTransitionError crypto
forall x.
ChainTransitionError crypto -> Rep (ChainTransitionError crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x.
Rep (ChainTransitionError crypto) x -> ChainTransitionError crypto
forall crypto x.
ChainTransitionError crypto -> Rep (ChainTransitionError crypto) x
$cto :: forall crypto x.
Rep (ChainTransitionError crypto) x -> ChainTransitionError crypto
$cfrom :: forall crypto x.
ChainTransitionError crypto -> Rep (ChainTransitionError crypto) x
Generic)

instance (CC.Crypto crypto) => NoThunks (ChainTransitionError crypto)

deriving instance (CC.Crypto crypto) => Eq (ChainTransitionError crypto)

deriving instance (CC.Crypto crypto) => Show (ChainTransitionError crypto)

-- | Tick the chain state to a new epoch.
tickChainDepState ::
  Globals ->
  LedgerView crypto ->
  -- | Are we in a new epoch?
  Bool ->
  ChainDepState crypto ->
  ChainDepState crypto
tickChainDepState :: Globals
-> LedgerView crypto
-> Bool
-> ChainDepState crypto
-> ChainDepState crypto
tickChainDepState
  Globals
globals
  LedgerView {Nonce
lvExtraEntropy :: Nonce
lvExtraEntropy :: forall crypto. LedgerView crypto -> Nonce
lvExtraEntropy}
  Bool
isNewEpoch
  cs :: ChainDepState crypto
cs@ChainDepState {PrtclState crypto
csProtocol :: PrtclState crypto
csProtocol :: forall crypto. ChainDepState crypto -> PrtclState crypto
csProtocol, TicknState
csTickn :: TicknState
csTickn :: forall crypto. ChainDepState crypto -> TicknState
csTickn, Nonce
csLabNonce :: Nonce
csLabNonce :: forall crypto. ChainDepState crypto -> Nonce
csLabNonce} = ChainDepState crypto
cs {csTickn :: TicknState
csTickn = TicknState
newTickState}
    where
      STS.Prtcl.PrtclState Map (KeyHash 'BlockIssuer crypto) Word64
_ Nonce
_ Nonce
candidateNonce = PrtclState crypto
csProtocol
      err :: a
err = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Panic! tickChainDepState failed."
      newTickState :: TicknState
newTickState =
        TicknState
-> Either [TicknPredicateFailure] TicknState -> TicknState
forall b a. b -> Either a b -> b
fromRight TicknState
forall a. a
err (Either [TicknPredicateFailure] TicknState -> TicknState)
-> (TRC TICKN -> Either [TicknPredicateFailure] TicknState)
-> TRC TICKN
-> TicknState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reader Globals (Either [TicknPredicateFailure] TicknState)
 -> Globals -> Either [TicknPredicateFailure] TicknState)
-> Globals
-> Reader Globals (Either [TicknPredicateFailure] TicknState)
-> Either [TicknPredicateFailure] TicknState
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader Globals (Either [TicknPredicateFailure] TicknState)
-> Globals -> Either [TicknPredicateFailure] TicknState
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader Globals (Either [TicknPredicateFailure] TicknState)
 -> Either [TicknPredicateFailure] TicknState)
-> (TRC TICKN
    -> Reader Globals (Either [TicknPredicateFailure] TicknState))
-> TRC TICKN
-> Either [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 [PredicateFailure s] (State s))
forall (m :: * -> *) (rtype :: RuleType).
(STS TICKN, RuleTypeRep rtype, m ~ BaseM TICKN) =>
RuleContext rtype TICKN
-> m (Either [PredicateFailure TICKN] (State TICKN))
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 crypto m.
  ( PraosCrypto crypto,
    MonadError (ChainTransitionError crypto) m
  ) =>
  Globals ->
  LedgerView crypto ->
  BHeader crypto ->
  ChainDepState crypto ->
  m (ChainDepState crypto)
updateChainDepState :: Globals
-> LedgerView crypto
-> BHeader crypto
-> ChainDepState crypto
-> m (ChainDepState crypto)
updateChainDepState
  Globals
globals
  LedgerView crypto
lv
  BHeader crypto
bh
  cs :: ChainDepState crypto
cs@ChainDepState {PrtclState crypto
csProtocol :: PrtclState crypto
csProtocol :: forall crypto. ChainDepState crypto -> PrtclState crypto
csProtocol, TicknState
csTickn :: TicknState
csTickn :: forall crypto. ChainDepState crypto -> TicknState
csTickn} =
    Either (ChainTransitionError crypto) (ChainDepState crypto)
-> m (ChainDepState crypto)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      (Either (ChainTransitionError crypto) (ChainDepState crypto)
 -> m (ChainDepState crypto))
-> (Either [PrtclPredicateFailure crypto] (PrtclState crypto)
    -> Either (ChainTransitionError crypto) (ChainDepState crypto))
-> Either [PrtclPredicateFailure crypto] (PrtclState crypto)
-> m (ChainDepState crypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrtclState crypto -> ChainDepState crypto)
-> Either (ChainTransitionError crypto) (PrtclState crypto)
-> Either (ChainTransitionError crypto) (ChainDepState crypto)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right
        ( \PrtclState crypto
newPrtclState ->
            ChainDepState crypto
cs
              { csProtocol :: PrtclState crypto
csProtocol = PrtclState crypto
newPrtclState,
                csLabNonce :: Nonce
csLabNonce = PrevHash crypto -> Nonce
forall crypto. PrevHash crypto -> Nonce
prevHashToNonce (BHBody crypto -> PrevHash crypto
forall crypto. BHBody crypto -> PrevHash crypto
bheaderPrev (BHBody crypto -> PrevHash crypto)
-> (BHeader crypto -> BHBody crypto)
-> BHeader crypto
-> PrevHash crypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader crypto -> BHBody crypto
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
bhbody (BHeader crypto -> PrevHash crypto)
-> BHeader crypto -> PrevHash crypto
forall a b. (a -> b) -> a -> b
$ BHeader crypto
bh)
              }
        )
      (Either (ChainTransitionError crypto) (PrtclState crypto)
 -> Either (ChainTransitionError crypto) (ChainDepState crypto))
-> (Either [PrtclPredicateFailure crypto] (PrtclState crypto)
    -> Either (ChainTransitionError crypto) (PrtclState crypto))
-> Either [PrtclPredicateFailure crypto] (PrtclState crypto)
-> Either (ChainTransitionError crypto) (ChainDepState crypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PrtclPredicateFailure crypto] -> ChainTransitionError crypto)
-> Either [PrtclPredicateFailure crypto] (PrtclState crypto)
-> Either (ChainTransitionError crypto) (PrtclState crypto)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left [PrtclPredicateFailure crypto] -> ChainTransitionError crypto
forall crypto.
[PredicateFailure (PRTCL crypto)] -> ChainTransitionError crypto
ChainTransitionError
      (Either [PrtclPredicateFailure crypto] (PrtclState crypto)
 -> m (ChainDepState crypto))
-> Either [PrtclPredicateFailure crypto] (PrtclState crypto)
-> m (ChainDepState crypto)
forall a b. (a -> b) -> a -> b
$ Either [PrtclPredicateFailure crypto] (PrtclState crypto)
res
    where
      res :: Either [PrtclPredicateFailure crypto] (PrtclState crypto)
res =
        (Reader
   Globals (Either [PrtclPredicateFailure crypto] (PrtclState crypto))
 -> Globals
 -> Either [PrtclPredicateFailure crypto] (PrtclState crypto))
-> Globals
-> Reader
     Globals (Either [PrtclPredicateFailure crypto] (PrtclState crypto))
-> Either [PrtclPredicateFailure crypto] (PrtclState crypto)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals (Either [PrtclPredicateFailure crypto] (PrtclState crypto))
-> Globals
-> Either [PrtclPredicateFailure crypto] (PrtclState crypto)
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader
   Globals (Either [PrtclPredicateFailure crypto] (PrtclState crypto))
 -> Either [PrtclPredicateFailure crypto] (PrtclState crypto))
-> (TRC (PRTCL crypto)
    -> Reader
         Globals
         (Either [PrtclPredicateFailure crypto] (PrtclState crypto)))
-> TRC (PRTCL crypto)
-> Either [PrtclPredicateFailure crypto] (PrtclState crypto)
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 [PredicateFailure s] (State s))
forall (m :: * -> *) (rtype :: RuleType).
(STS (PRTCL crypto), RuleTypeRep rtype,
 m ~ BaseM (PRTCL crypto)) =>
RuleContext rtype (PRTCL crypto)
-> m (Either
        [PredicateFailure (PRTCL crypto)] (State (PRTCL crypto)))
applySTS @(STS.Prtcl.PRTCL crypto)
          (TRC (PRTCL crypto)
 -> Either [PrtclPredicateFailure crypto] (PrtclState crypto))
-> TRC (PRTCL crypto)
-> Either [PrtclPredicateFailure crypto] (PrtclState crypto)
forall a b. (a -> b) -> a -> b
$ (Environment (PRTCL crypto), State (PRTCL crypto),
 Signal (PRTCL crypto))
-> TRC (PRTCL crypto)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
            ( LedgerView crypto -> Nonce -> PrtclEnv crypto
forall crypto. LedgerView crypto -> Nonce -> PrtclEnv crypto
mkPrtclEnv LedgerView crypto
lv Nonce
epochNonce,
              State (PRTCL crypto)
PrtclState crypto
csProtocol,
              Signal (PRTCL crypto)
BHeader crypto
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 crypto.
  PraosCrypto crypto =>
  Globals ->
  LedgerView crypto ->
  BHeader crypto ->
  ChainDepState crypto ->
  ChainDepState crypto
reupdateChainDepState :: Globals
-> LedgerView crypto
-> BHeader crypto
-> ChainDepState crypto
-> ChainDepState crypto
reupdateChainDepState
  Globals
globals
  LedgerView crypto
lv
  BHeader crypto
bh
  cs :: ChainDepState crypto
cs@ChainDepState {PrtclState crypto
csProtocol :: PrtclState crypto
csProtocol :: forall crypto. ChainDepState crypto -> PrtclState crypto
csProtocol, TicknState
csTickn :: TicknState
csTickn :: forall crypto. ChainDepState crypto -> TicknState
csTickn} =
    ChainDepState crypto
cs
      { csProtocol :: PrtclState crypto
csProtocol = PrtclState crypto
res,
        csLabNonce :: Nonce
csLabNonce = PrevHash crypto -> Nonce
forall crypto. PrevHash crypto -> Nonce
prevHashToNonce (BHBody crypto -> PrevHash crypto
forall crypto. BHBody crypto -> PrevHash crypto
bheaderPrev (BHBody crypto -> PrevHash crypto)
-> (BHeader crypto -> BHBody crypto)
-> BHeader crypto
-> PrevHash crypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader crypto -> BHBody crypto
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
bhbody (BHeader crypto -> PrevHash crypto)
-> BHeader crypto -> PrevHash crypto
forall a b. (a -> b) -> a -> b
$ BHeader crypto
bh)
      }
    where
      res :: PrtclState crypto
res =
        (Reader Globals (PrtclState crypto)
 -> Globals -> PrtclState crypto)
-> Globals
-> Reader Globals (PrtclState crypto)
-> PrtclState crypto
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader Globals (PrtclState crypto) -> Globals -> PrtclState crypto
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader Globals (PrtclState crypto) -> PrtclState crypto)
-> (TRC (PRTCL crypto) -> Reader Globals (PrtclState crypto))
-> TRC (PRTCL crypto)
-> PrtclState crypto
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)
forall (m :: * -> *) (rtype :: RuleType).
(STS (PRTCL crypto), RuleTypeRep rtype,
 m ~ BaseM (PRTCL crypto)) =>
RuleContext rtype (PRTCL crypto) -> m (State (PRTCL crypto))
reapplySTS @(STS.Prtcl.PRTCL crypto)
          (TRC (PRTCL crypto) -> PrtclState crypto)
-> TRC (PRTCL crypto) -> PrtclState crypto
forall a b. (a -> b) -> a -> b
$ (Environment (PRTCL crypto), State (PRTCL crypto),
 Signal (PRTCL crypto))
-> TRC (PRTCL crypto)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
            ( LedgerView crypto -> Nonce -> PrtclEnv crypto
forall crypto. LedgerView crypto -> Nonce -> PrtclEnv crypto
mkPrtclEnv LedgerView crypto
lv Nonce
epochNonce,
              State (PRTCL crypto)
PrtclState crypto
csProtocol,
              Signal (PRTCL crypto)
BHeader crypto
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 ::
  ( Era era,
    VRF.Signable
      (CC.VRF (Crypto era))
      Seed,
    HasField "_d" (Core.PParams era) UnitInterval
  ) =>
  Globals ->
  NewEpochState era ->
  ChainDepState (Crypto era) ->
  KeyHash 'StakePool (Crypto era) ->
  SignKeyVRF (Crypto era) ->
  Core.PParams era ->
  Set SlotNo
getLeaderSchedule :: Globals
-> NewEpochState era
-> ChainDepState (Crypto era)
-> KeyHash 'StakePool (Crypto era)
-> SignKeyVRF (Crypto era)
-> PParams era
-> Set SlotNo
getLeaderSchedule Globals
globals NewEpochState era
ss ChainDepState (Crypto era)
cds KeyHash 'StakePool (Crypto era)
poolHash SignKeyVRF (Crypto era)
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 (VRF (Crypto era)) Seed
y = ContextVRF (VRF (Crypto era))
-> Seed
-> SignKeyVRF (Crypto era)
-> CertifiedVRF (VRF (Crypto era)) 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 (Crypto era)
key
       in Bool -> Bool
not (SlotNo -> UnitInterval -> SlotNo -> Bool
isOverlaySlot SlotNo
a (PParams era -> UnitInterval
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_d" PParams era
pp) SlotNo
slotNo)
            Bool -> Bool -> Bool
&& OutputVRF (VRF (Crypto era)) -> Rational -> ActiveSlotCoeff -> Bool
forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue (CertifiedVRF (VRF (Crypto era)) Seed
-> OutputVRF (VRF (Crypto era))
forall v a. CertifiedVRF v a -> OutputVRF v
VRF.certifiedOutput CertifiedVRF (VRF (Crypto era)) Seed
y) Rational
stake ActiveSlotCoeff
f
    stake :: Rational
stake = Rational
-> (IndividualPoolStake (Crypto era) -> Rational)
-> Maybe (IndividualPoolStake (Crypto era))
-> Rational
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rational
0 IndividualPoolStake (Crypto era) -> Rational
forall crypto. IndividualPoolStake crypto -> Rational
individualPoolStake (Maybe (IndividualPoolStake (Crypto era)) -> Rational)
-> Maybe (IndividualPoolStake (Crypto era)) -> Rational
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool (Crypto era)
-> Map
     (KeyHash 'StakePool (Crypto era))
     (IndividualPoolStake (Crypto era))
-> Maybe (IndividualPoolStake (Crypto era))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool (Crypto era)
poolHash Map
  (KeyHash 'StakePool (Crypto era))
  (IndividualPoolStake (Crypto era))
poolDistr
    poolDistr :: Map
  (KeyHash 'StakePool (Crypto era))
  (IndividualPoolStake (Crypto era))
poolDistr = PoolDistr (Crypto era)
-> Map
     (KeyHash 'StakePool (Crypto era))
     (IndividualPoolStake (Crypto era))
forall crypto.
PoolDistr crypto
-> Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
unPoolDistr (PoolDistr (Crypto era)
 -> Map
      (KeyHash 'StakePool (Crypto era))
      (IndividualPoolStake (Crypto era)))
-> PoolDistr (Crypto era)
-> Map
     (KeyHash 'StakePool (Crypto era))
     (IndividualPoolStake (Crypto era))
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> PoolDistr (Crypto era)
forall era. NewEpochState era -> PoolDistr (Crypto era)
nesPd NewEpochState era
ss
    STS.Tickn.TicknState Nonce
epochNonce Nonce
_ = ChainDepState (Crypto era) -> TicknState
forall crypto. ChainDepState crypto -> TicknState
csTickn ChainDepState (Crypto era)
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 ::
  forall c.
  ShelleyGenesis (ShelleyEra c) ->
  LedgerView c
mkInitialShelleyLedgerView :: ShelleyGenesis (ShelleyEra c) -> LedgerView c
mkInitialShelleyLedgerView ShelleyGenesis (ShelleyEra c)
genesisShelley =
  let !ee :: Nonce
ee = PParams' Identity (ShelleyEra c) -> Nonce
forall (f :: * -> *) era. PParams' f era -> HKD f Nonce
_extraEntropy (PParams' Identity (ShelleyEra c) -> Nonce)
-> (ShelleyGenesis (ShelleyEra c)
    -> PParams' Identity (ShelleyEra c))
-> ShelleyGenesis (ShelleyEra c)
-> Nonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis (ShelleyEra c) -> PParams' Identity (ShelleyEra c)
forall era. ShelleyGenesis era -> PParams era
sgProtocolParams (ShelleyGenesis (ShelleyEra c) -> Nonce)
-> ShelleyGenesis (ShelleyEra c) -> Nonce
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra c)
genesisShelley
   in LedgerView :: forall crypto.
UnitInterval
-> Nonce
-> PoolDistr crypto
-> GenDelegs crypto
-> ChainChecksPParams
-> LedgerView crypto
LedgerView
        { lvD :: UnitInterval
lvD = PParams' Identity (ShelleyEra c) -> UnitInterval
forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval
_d (PParams' Identity (ShelleyEra c) -> UnitInterval)
-> (ShelleyGenesis (ShelleyEra c)
    -> PParams' Identity (ShelleyEra c))
-> ShelleyGenesis (ShelleyEra c)
-> UnitInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis (ShelleyEra c) -> PParams' Identity (ShelleyEra c)
forall era. ShelleyGenesis era -> PParams era
sgProtocolParams (ShelleyGenesis (ShelleyEra c) -> UnitInterval)
-> ShelleyGenesis (ShelleyEra c) -> UnitInterval
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra c)
genesisShelley,
          lvExtraEntropy :: Nonce
lvExtraEntropy = Nonce
ee,
          lvPoolDistr :: PoolDistr c
lvPoolDistr = Map (KeyHash 'StakePool c) (IndividualPoolStake c) -> PoolDistr c
forall crypto.
Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
-> PoolDistr crypto
PoolDistr Map (KeyHash 'StakePool c) (IndividualPoolStake c)
forall k a. Map k a
Map.empty,
          lvGenDelegs :: GenDelegs c
lvGenDelegs = Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
forall crypto.
Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> GenDelegs crypto
GenDelegs (Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c)
-> Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra c)
-> Map
     (KeyHash 'Genesis (Crypto (ShelleyEra c)))
     (GenDelegPair (Crypto (ShelleyEra c)))
forall era.
ShelleyGenesis era
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
sgGenDelegs ShelleyGenesis (ShelleyEra c)
genesisShelley,
          lvChainChecks :: ChainChecksPParams
lvChainChecks = PParams' Identity (ShelleyEra c) -> ChainChecksPParams
forall pp.
(HasField "_maxBHSize" pp Natural,
 HasField "_maxBBSize" pp Natural,
 HasField "_protocolVersion" pp ProtVer) =>
pp -> ChainChecksPParams
pparamsToChainChecksPParams (PParams' Identity (ShelleyEra c) -> ChainChecksPParams)
-> (ShelleyGenesis (ShelleyEra c)
    -> PParams' Identity (ShelleyEra c))
-> ShelleyGenesis (ShelleyEra c)
-> ChainChecksPParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis (ShelleyEra c) -> PParams' Identity (ShelleyEra c)
forall era. ShelleyGenesis era -> PParams era
sgProtocolParams (ShelleyGenesis (ShelleyEra c) -> ChainChecksPParams)
-> ShelleyGenesis (ShelleyEra c) -> ChainChecksPParams
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra c)
genesisShelley
        }