{-# 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.PoolDistr (PoolDistr (..), individualPoolStake)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core (EraGov)
import Cardano.Ledger.Shelley.LedgerState (
  EpochState (..),
  NewEpochState (..),
  certDState,
  curPParamsEpochStateL,
  dsGenDelegs,
  lsCertState,
 )
import Cardano.Ledger.Shelley.Translation (FromByronTranslationContext (..))
import Cardano.Ledger.Slot (SlotNo)
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
  ) =>
  GetLedgerView era
  where
  currentLedgerView ::
    NewEpochState era ->
    LedgerView
  default currentLedgerView ::
    ProtVerAtMost era 6 =>
    NewEpochState era ->
    LedgerView
  currentLedgerView = forall era.
(ProtVerAtMost era 6, EraGov 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 = 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) =>
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 forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG
        , lvExtraEntropy :: Nonce
lvExtraEntropy = forall a. HasCallStack => [Char] -> a
error [Char]
"Extra entropy is not set in the Babbage era"
        , lvPoolDistr :: PoolDistr
lvPoolDistr = PoolDistr
pd
        , lvGenDelegs :: GenDelegs
lvGenDelegs =
            forall era. DState era -> GenDelegs
dsGenDelegs
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> DState era
certDState
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState
              forall a b. (a -> b) -> a -> b
$ forall era. EpochState era -> LedgerState era
esLState EpochState BabbageEra
es
        , lvChainChecks :: ChainChecksPParams
lvChainChecks = forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams forall a b. (a -> b) -> a -> b
$ EpochState BabbageEra
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
        }

  futureLedgerView :: forall (m :: * -> *).
MonadError (FutureLedgerViewError BabbageEra) m =>
Globals -> NewEpochState BabbageEra -> SlotNo -> m LedgerView
futureLedgerView Globals
globals NewEpochState BabbageEra
ss SlotNo
slot =
    forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      forall b c a. (b -> c) -> (a -> b) -> a -> 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)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall era.
NonEmpty (PredicateFailure (EraRule "TICKF" era))
-> FutureLedgerViewError era
FutureLedgerViewError
      forall a b. (a -> b) -> a -> b
$ Either
  (NonEmpty (ShelleyTickfPredFailure BabbageEra))
  (NewEpochState BabbageEra)
res
    where
      res :: Either
  (NonEmpty (ShelleyTickfPredFailure BabbageEra))
  (NewEpochState BabbageEra)
res =
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals
          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)
          forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), NewEpochState BabbageEra
ss, SlotNo
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 forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG
        , lvExtraEntropy :: Nonce
lvExtraEntropy = forall a. HasCallStack => [Char] -> a
error [Char]
"Extra entropy is not set in the Conway era"
        , lvPoolDistr :: PoolDistr
lvPoolDistr = PoolDistr
pd
        , lvGenDelegs :: GenDelegs
lvGenDelegs =
            forall era. DState era -> GenDelegs
dsGenDelegs
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> DState era
certDState
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState
              forall a b. (a -> b) -> a -> b
$ forall era. EpochState era -> LedgerState era
esLState EpochState ConwayEra
es
        , lvChainChecks :: ChainChecksPParams
lvChainChecks = forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams forall a b. (a -> b) -> a -> b
$ EpochState ConwayEra
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
        }

  futureLedgerView :: forall (m :: * -> *).
MonadError (FutureLedgerViewError ConwayEra) m =>
Globals -> NewEpochState ConwayEra -> SlotNo -> m LedgerView
futureLedgerView Globals
globals NewEpochState ConwayEra
ss SlotNo
slot =
    forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      forall b c a. (b -> c) -> (a -> b) -> a -> 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
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall era.
NonEmpty (PredicateFailure (EraRule "TICKF" era))
-> FutureLedgerViewError era
FutureLedgerViewError
      forall a b. (a -> b) -> a -> b
$ Either
  (NonEmpty (ConwayTickfPredFailure ConwayEra))
  (NewEpochState ConwayEra)
res
    where
      res :: Either
  (NonEmpty (ConwayTickfPredFailure ConwayEra))
  (NewEpochState ConwayEra)
res =
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals
          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)
          forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), NewEpochState ConwayEra
ss, SlotNo
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LedgerView -> LedgerView -> Bool
$c/= :: LedgerView -> LedgerView -> Bool
== :: LedgerView -> LedgerView -> Bool
$c== :: LedgerView -> LedgerView -> Bool
Eq, Int -> LedgerView -> ShowS
[LedgerView] -> ShowS
LedgerView -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LedgerView] -> ShowS
$cshowList :: [LedgerView] -> ShowS
show :: LedgerView -> [Char]
$cshow :: LedgerView -> [Char]
showsPrec :: Int -> LedgerView -> ShowS
$cshowsPrec :: Int -> LedgerView -> ShowS
Show, 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
$cto :: forall x. Rep LedgerView x -> LedgerView
$cfrom :: forall x. LedgerView -> Rep LedgerView x
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 :: UnitInterval
lvD :: LedgerView -> UnitInterval
lvD
    , PoolDistr
lvPoolDistr :: PoolDistr
lvPoolDistr :: LedgerView -> PoolDistr
lvPoolDistr
    , GenDelegs
lvGenDelegs :: GenDelegs
lvGenDelegs :: LedgerView -> GenDelegs
lvGenDelegs
    } =
    UnitInterval -> PoolDistr -> GenDelegs -> Nonce -> PrtclEnv
STS.Prtcl.PrtclEnv
      UnitInterval
lvD
      PoolDistr
lvPoolDistr
      GenDelegs
lvGenDelegs

view ::
  (ProtVerAtMost era 6, EraGov era) =>
  NewEpochState era ->
  LedgerView
view :: forall era.
(ProtVerAtMost era 6, EraGov 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 forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) Nonce
ppExtraEntropyL
     in LedgerView
          { lvD :: UnitInterval
lvD = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG
          , lvExtraEntropy :: Nonce
lvExtraEntropy = Nonce
ee
          , lvPoolDistr :: PoolDistr
lvPoolDistr = PoolDistr
pd
          , lvGenDelegs :: GenDelegs
lvGenDelegs =
              forall era. DState era -> GenDelegs
dsGenDelegs
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> DState era
certDState
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState
                forall a b. (a -> b) -> a -> b
$ forall era. EpochState era -> LedgerState era
esLState EpochState era
es
          , lvChainChecks :: ChainChecksPParams
lvChainChecks = forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams forall a b. (a -> b) -> a -> b
$ EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov 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
  ) =>
  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) =>
Globals -> NewEpochState era -> SlotNo -> m LedgerView
futureView Globals
globals NewEpochState era
ss SlotNo
slot =
  forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right forall era.
(ProtVerAtMost era 6, EraGov era) =>
NewEpochState era -> LedgerView
view
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall era.
NonEmpty (PredicateFailure (EraRule "TICKF" era))
-> FutureLedgerViewError era
FutureLedgerViewError
    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 =
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals
        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)
        forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), NewEpochState era
ss, SlotNo
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainDepState -> ChainDepState -> Bool
$c/= :: ChainDepState -> ChainDepState -> Bool
== :: ChainDepState -> ChainDepState -> Bool
$c== :: ChainDepState -> ChainDepState -> Bool
Eq, Int -> ChainDepState -> ShowS
[ChainDepState] -> ShowS
ChainDepState -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ChainDepState] -> ShowS
$cshowList :: [ChainDepState] -> ShowS
show :: ChainDepState -> [Char]
$cshow :: ChainDepState -> [Char]
showsPrec :: Int -> ChainDepState -> ShowS
$cshowsPrec :: Int -> ChainDepState -> ShowS
Show, 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
$cto :: forall x. Rep ChainDepState x -> ChainDepState
$cfrom :: forall x. ChainDepState -> Rep ChainDepState x
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 =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        ( forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (\(GenDelegPair KeyHash 'GenesisDelegate
hk VRFVerKeyHash 'GenDelegVRF
_) -> (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'GenesisDelegate
hk, Word64
0))
            (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 =
    forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed
      Text
"ChainDepState"
      (forall a b. a -> b -> a
const Int
3)
      ( PrtclState -> TicknState -> Nonce -> ChainDepState
ChainDepState
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. FromCBOR a => Decoder s a
fromCBOR
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. FromCBOR a => Decoder s a
fromCBOR
      )

instance EncCBOR ChainDepState

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

newtype ChainTransitionError c
  = ChainTransitionError (NonEmpty (PredicateFailure (STS.Prtcl.PRTCL c)))
  deriving (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
$cto :: forall c x.
Rep (ChainTransitionError c) x -> ChainTransitionError c
$cfrom :: forall c x.
ChainTransitionError c -> Rep (ChainTransitionError c) x
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 :: Nonce
lvExtraEntropy :: LedgerView -> Nonce
lvExtraEntropy}
  Bool
isNewEpoch
  cs :: ChainDepState
cs@ChainDepState {PrtclState
csProtocol :: PrtclState
csProtocol :: ChainDepState -> PrtclState
csProtocol, TicknState
csTickn :: TicknState
csTickn :: ChainDepState -> TicknState
csTickn, Nonce
csLabNonce :: Nonce
csLabNonce :: ChainDepState -> Nonce
csLabNonce} = ChainDepState
cs {csTickn :: TicknState
csTickn = TicknState
newTickState}
    where
      STS.Prtcl.PrtclState Map (KeyHash 'BlockIssuer) Word64
_ Nonce
_ Nonce
candidateNonce = PrtclState
csProtocol
      err :: a
err = forall a. HasCallStack => [Char] -> a
error [Char]
"Panic! tickChainDepState failed."
      newTickState :: TicknState
newTickState =
        forall b a. b -> Either a b -> b
fromRight forall {a}. a
err
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals
          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
          forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
            ( Nonce -> Nonce -> Nonce -> TicknEnv
STS.Tickn.TicknEnv
                Nonce
lvExtraEntropy
                Nonce
candidateNonce
                Nonce
csLabNonce
            , TicknState
csTickn
            , Bool
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 :: PrtclState
csProtocol :: ChainDepState -> PrtclState
csProtocol, TicknState
csTickn :: TicknState
csTickn :: ChainDepState -> TicknState
csTickn} =
    forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right
        ( \PrtclState
newPrtclState ->
            ChainDepState
cs
              { csProtocol :: PrtclState
csProtocol = PrtclState
newPrtclState
              , csLabNonce :: Nonce
csLabNonce = PrevHash -> Nonce
prevHashToNonce (forall c. BHBody c -> PrevHash
bheaderPrev forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => BHeader c -> BHBody c
bhbody forall a b. (a -> b) -> a -> b
$ BHeader c
bh)
              }
        )
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall c.
NonEmpty (PredicateFailure (PRTCL c)) -> ChainTransitionError c
ChainTransitionError
      forall a b. (a -> b) -> a -> b
$ Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
res
    where
      res :: Either (NonEmpty (PrtclPredicateFailure c)) PrtclState
res =
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals
          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)
          forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
            ( LedgerView -> Nonce -> PrtclEnv
mkPrtclEnv LedgerView
lv Nonce
epochNonce
            , PrtclState
csProtocol
            , 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 :: PrtclState
csProtocol :: ChainDepState -> PrtclState
csProtocol, TicknState
csTickn :: TicknState
csTickn :: ChainDepState -> TicknState
csTickn} =
    ChainDepState
cs
      { csProtocol :: PrtclState
csProtocol = PrtclState
res
      , csLabNonce :: Nonce
csLabNonce = PrevHash -> Nonce
prevHashToNonce (forall c. BHBody c -> PrevHash
bheaderPrev forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => BHeader c -> BHBody c
bhbody forall a b. (a -> b) -> a -> b
$ BHeader c
bh)
      }
    where
      res :: PrtclState
res =
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals
          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)
          forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
            ( LedgerView -> Nonce -> PrtclEnv
mkPrtclEnv LedgerView
lv Nonce
epochNonce
            , PrtclState
csProtocol
            , 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 = 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 = 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 forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG) SlotNo
slotNo)
            Bool -> Bool -> Bool
&& forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue (forall v a. CertifiedVRF v a -> OutputVRF v
VRF.certifiedOutput CertifiedVRF v Seed
y) Rational
stake ActiveSlotCoeff
f
    stake :: Rational
stake = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rational
0 IndividualPoolStake -> Rational
individualPoolStake forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall era. NewEpochState era -> PoolDistr
nesPd NewEpochState era
ss
    STS.Tickn.TicknState Nonce
epochNonce Nonce
_ = ChainDepState -> TicknState
csTickn ChainDepState
cds
    currentEpoch :: EpochNo
currentEpoch = 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 = forall a. Ord a => [a] -> Set a
Set.fromList [SlotNo
a .. SlotNo
b]
    (SlotNo
a, SlotNo
b) = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ 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 forall s a. s -> Getting a s a -> a
^. forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) Nonce
ppExtraEntropyL
   in LedgerView
        { lvD :: UnitInterval
lvD = FromByronTranslationContext -> PParams ShelleyEra
fbtcProtocolParams FromByronTranslationContext
transCtxt forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG
        , lvExtraEntropy :: Nonce
lvExtraEntropy = Nonce
ee
        , lvPoolDistr :: PoolDistr
lvPoolDistr = Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr forall k a. Map k a
Map.empty forall a. Monoid a => a
mempty
        , lvGenDelegs :: GenDelegs
lvGenDelegs = Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs forall a b. (a -> b) -> a -> b
$ FromByronTranslationContext -> Map (KeyHash 'Genesis) GenDelegPair
fbtcGenDelegs FromByronTranslationContext
transCtxt
        , lvChainChecks :: ChainChecksPParams
lvChainChecks = forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromByronTranslationContext -> PParams ShelleyEra
fbtcProtocolParams forall a b. (a -> b) -> a -> b
$ FromByronTranslationContext
transCtxt
        }