{-# 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.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.Crypto (Crypto, StandardCrypto, VRF)
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.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.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.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
  , DSignable c (OCertSignable c)
  , KESignable c (BHBody c)
  , VRFSignable c Seed
  ) =>
  PraosCrypto c

instance PraosCrypto StandardCrypto

class
  ( Eq (ChainTransitionError (EraCrypto era))
  , Show (ChainTransitionError (EraCrypto era))
  , Show (LedgerView (EraCrypto era))
  , Show (FutureLedgerViewError era)
  , 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 (EraCrypto era)
  default currentLedgerView ::
    ProtVerAtMost era 6 =>
    NewEpochState era ->
    LedgerView (EraCrypto era)
  currentLedgerView = forall era.
(ProtVerAtMost era 6, EraGov era) =>
NewEpochState era -> LedgerView (EraCrypto era)
view

  -- $timetravel
  futureLedgerView ::
    MonadError (FutureLedgerViewError era) m =>
    Globals ->
    NewEpochState era ->
    SlotNo ->
    m (LedgerView (EraCrypto era))
  default futureLedgerView ::
    ( MonadError (FutureLedgerViewError era) m
    , ProtVerAtMost era 6
    ) =>
    Globals ->
    NewEpochState era ->
    SlotNo ->
    m (LedgerView (EraCrypto era))
  futureLedgerView = 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 (EraCrypto era))
futureView

instance Crypto c => GetLedgerView (ShelleyEra c)

instance Crypto c => GetLedgerView (AllegraEra c)

instance Crypto c => GetLedgerView (MaryEra c)

instance 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 Crypto c => GetLedgerView (BabbageEra c) where
  currentLedgerView :: NewEpochState (BabbageEra c)
-> LedgerView (EraCrypto (BabbageEra c))
currentLedgerView
    NewEpochState {nesPd :: forall era. NewEpochState era -> PoolDistr (EraCrypto era)
nesPd = PoolDistr (EraCrypto (BabbageEra c))
pd, nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState (BabbageEra c)
es} =
      LedgerView
        { lvD :: UnitInterval
lvD = EpochState (BabbageEra c)
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 c
lvPoolDistr = PoolDistr (EraCrypto (BabbageEra c))
pd
        , lvGenDelegs :: GenDelegs c
lvGenDelegs =
            forall era. DState era -> GenDelegs (EraCrypto era)
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 c)
es
        , lvChainChecks :: ChainChecksPParams
lvChainChecks = forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams forall a b. (a -> b) -> a -> b
$ EpochState (BabbageEra c)
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 c)) m =>
Globals
-> NewEpochState (BabbageEra c)
-> SlotNo
-> m (LedgerView (EraCrypto (BabbageEra c)))
futureLedgerView Globals
globals NewEpochState (BabbageEra c)
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 (EraCrypto era)
currentLedgerView @(BabbageEra c))
      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 c)))
  (NewEpochState (BabbageEra c))
res
    where
      res :: Either
  (NonEmpty (ShelleyTickfPredFailure (BabbageEra c)))
  (NewEpochState (BabbageEra c))
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 c))
          forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), NewEpochState (BabbageEra c)
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 Crypto c => GetLedgerView (ConwayEra c) where
  currentLedgerView :: NewEpochState (ConwayEra c) -> LedgerView (EraCrypto (ConwayEra c))
currentLedgerView
    NewEpochState {nesPd :: forall era. NewEpochState era -> PoolDistr (EraCrypto era)
nesPd = PoolDistr (EraCrypto (ConwayEra c))
pd, nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState (ConwayEra c)
es} =
      LedgerView
        { lvD :: UnitInterval
lvD = EpochState (ConwayEra c)
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 c
lvPoolDistr = PoolDistr (EraCrypto (ConwayEra c))
pd
        , lvGenDelegs :: GenDelegs c
lvGenDelegs =
            forall era. DState era -> GenDelegs (EraCrypto era)
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 c)
es
        , lvChainChecks :: ChainChecksPParams
lvChainChecks = forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams forall a b. (a -> b) -> a -> b
$ EpochState (ConwayEra c)
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 c)) m =>
Globals
-> NewEpochState (ConwayEra c)
-> SlotNo
-> m (LedgerView (EraCrypto (ConwayEra c)))
futureLedgerView Globals
globals NewEpochState (ConwayEra c)
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 (EraCrypto era)
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 c)))
  (NewEpochState (ConwayEra c))
res
    where
      res :: Either
  (NonEmpty (ConwayTickfPredFailure (ConwayEra c)))
  (NewEpochState (ConwayEra c))
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 c))
          forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), NewEpochState (ConwayEra c)
ss, SlotNo
slot)

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

instance NoThunks (LedgerView c)

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

view ::
  (ProtVerAtMost era 6, EraGov era) =>
  NewEpochState era ->
  LedgerView (EraCrypto era)
view :: forall era.
(ProtVerAtMost era 6, EraGov era) =>
NewEpochState era -> LedgerView (EraCrypto era)
view
  NewEpochState
    { nesPd :: forall era. NewEpochState era -> PoolDistr (EraCrypto era)
nesPd = PoolDistr (EraCrypto era)
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 (EraCrypto era)
lvPoolDistr = PoolDistr (EraCrypto era)
pd
          , lvGenDelegs :: GenDelegs (EraCrypto era)
lvGenDelegs =
              forall era. DState era -> GenDelegs (EraCrypto era)
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 (EraCrypto era))
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 (EraCrypto era))
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 (EraCrypto era)
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 c = ChainDepState
  { forall c. ChainDepState c -> PrtclState c
csProtocol :: !(STS.Prtcl.PrtclState c)
  , forall c. ChainDepState c -> TicknState
csTickn :: !STS.Tickn.TicknState
  , forall c. ChainDepState c -> Nonce
csLabNonce :: !Nonce
  -- ^ Nonce constructed from the hash of the last applied block header.
  }
  deriving (ChainDepState c -> ChainDepState c -> Bool
forall c. ChainDepState c -> ChainDepState c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainDepState c -> ChainDepState c -> Bool
$c/= :: forall c. ChainDepState c -> ChainDepState c -> Bool
== :: ChainDepState c -> ChainDepState c -> Bool
$c== :: forall c. ChainDepState c -> ChainDepState c -> Bool
Eq, Int -> ChainDepState c -> ShowS
forall c. Int -> ChainDepState c -> ShowS
forall c. [ChainDepState c] -> ShowS
forall c. ChainDepState c -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ChainDepState c] -> ShowS
$cshowList :: forall c. [ChainDepState c] -> ShowS
show :: ChainDepState c -> [Char]
$cshow :: forall c. ChainDepState c -> [Char]
showsPrec :: Int -> ChainDepState c -> ShowS
$cshowsPrec :: forall c. Int -> ChainDepState c -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (ChainDepState c) x -> ChainDepState c
forall c x. ChainDepState c -> Rep (ChainDepState c) x
$cto :: forall c x. Rep (ChainDepState c) x -> ChainDepState c
$cfrom :: forall c x. ChainDepState c -> Rep (ChainDepState c) x
Generic)

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

instance Crypto c => NoThunks (ChainDepState c)

instance Crypto c => DecCBOR (ChainDepState c)

instance Crypto c => FromCBOR (ChainDepState c) where
  fromCBOR :: forall s. Decoder s (ChainDepState c)
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)
      ( forall c. PrtclState c -> TicknState -> Nonce -> ChainDepState c
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 Crypto c => EncCBOR (ChainDepState c)

instance Crypto c => ToCBOR (ChainDepState c) where
  toCBOR :: ChainDepState c -> Encoding
toCBOR
    ChainDepState
      { PrtclState c
csProtocol :: PrtclState c
csProtocol :: forall c. ChainDepState c -> PrtclState c
csProtocol
      , TicknState
csTickn :: TicknState
csTickn :: forall c. ChainDepState c -> TicknState
csTickn
      , Nonce
csLabNonce :: Nonce
csLabNonce :: forall c. ChainDepState c -> Nonce
csLabNonce
      } =
      forall a. Monoid a => [a] -> a
mconcat
        [ Word -> Encoding
encodeListLen Word
3
        , forall a. ToCBOR a => a -> Encoding
toCBOR PrtclState c
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 c ->
  -- | Are we in a new epoch?
  Bool ->
  ChainDepState c ->
  ChainDepState c
tickChainDepState :: forall c.
Globals
-> LedgerView c -> Bool -> ChainDepState c -> ChainDepState c
tickChainDepState
  Globals
globals
  LedgerView {Nonce
lvExtraEntropy :: Nonce
lvExtraEntropy :: forall c. LedgerView c -> Nonce
lvExtraEntropy}
  Bool
isNewEpoch
  cs :: ChainDepState c
cs@ChainDepState {PrtclState c
csProtocol :: PrtclState c
csProtocol :: forall c. ChainDepState c -> PrtclState c
csProtocol, TicknState
csTickn :: TicknState
csTickn :: forall c. ChainDepState c -> TicknState
csTickn, Nonce
csLabNonce :: Nonce
csLabNonce :: forall c. ChainDepState c -> Nonce
csLabNonce} = ChainDepState c
cs {csTickn :: TicknState
csTickn = TicknState
newTickState}
    where
      STS.Prtcl.PrtclState Map (KeyHash 'BlockIssuer c) Word64
_ Nonce
_ Nonce
candidateNonce = PrtclState c
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 c ->
  BHeader c ->
  ChainDepState c ->
  m (ChainDepState c)
updateChainDepState :: forall c (m :: * -> *).
(PraosCrypto c, MonadError (ChainTransitionError c) m) =>
Globals
-> LedgerView c
-> BHeader c
-> ChainDepState c
-> m (ChainDepState c)
updateChainDepState
  Globals
globals
  LedgerView c
lv
  BHeader c
bh
  cs :: ChainDepState c
cs@ChainDepState {PrtclState c
csProtocol :: PrtclState c
csProtocol :: forall c. ChainDepState c -> PrtclState c
csProtocol, TicknState
csTickn :: TicknState
csTickn :: forall c. ChainDepState c -> 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 c
newPrtclState ->
            ChainDepState c
cs
              { csProtocol :: PrtclState c
csProtocol = PrtclState c
newPrtclState
              , csLabNonce :: Nonce
csLabNonce = forall c. PrevHash c -> Nonce
prevHashToNonce (forall c. BHBody c -> PrevHash c
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 c)
res
    where
      res :: Either (NonEmpty (PrtclPredicateFailure c)) (PrtclState c)
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
            ( forall c. LedgerView c -> Nonce -> PrtclEnv c
mkPrtclEnv LedgerView c
lv Nonce
epochNonce
            , PrtclState c
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 c ->
  BHeader c ->
  ChainDepState c ->
  ChainDepState c
reupdateChainDepState :: forall c.
PraosCrypto c =>
Globals
-> LedgerView c -> BHeader c -> ChainDepState c -> ChainDepState c
reupdateChainDepState
  Globals
globals
  LedgerView c
lv
  BHeader c
bh
  cs :: ChainDepState c
cs@ChainDepState {PrtclState c
csProtocol :: PrtclState c
csProtocol :: forall c. ChainDepState c -> PrtclState c
csProtocol, TicknState
csTickn :: TicknState
csTickn :: forall c. ChainDepState c -> TicknState
csTickn} =
    ChainDepState c
cs
      { csProtocol :: PrtclState c
csProtocol = PrtclState c
res
      , csLabNonce :: Nonce
csLabNonce = forall c. PrevHash c -> Nonce
prevHashToNonce (forall c. BHBody c -> PrevHash c
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 c
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
            ( forall c. LedgerView c -> Nonce -> PrtclEnv c
mkPrtclEnv LedgerView c
lv Nonce
epochNonce
            , PrtclState c
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.Signable (VRF (EraCrypto era)) Seed
  ) =>
  Globals ->
  NewEpochState era ->
  ChainDepState (EraCrypto era) ->
  KeyHash 'StakePool (EraCrypto era) ->
  SignKeyVRF (EraCrypto era) ->
  PParams era ->
  Set SlotNo
getLeaderSchedule :: forall era.
(EraPParams era, Signable (VRF (EraCrypto era)) Seed) =>
Globals
-> NewEpochState era
-> ChainDepState (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era)
-> SignKeyVRF (EraCrypto era)
-> PParams era
-> Set SlotNo
getLeaderSchedule Globals
globals NewEpochState era
ss ChainDepState (EraCrypto era)
cds KeyHash 'StakePool (EraCrypto era)
poolHash SignKeyVRF (EraCrypto era)
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 (VRF (EraCrypto era)) 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 (EraCrypto era)
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 (VRF (EraCrypto era)) Seed
y) Rational
stake ActiveSlotCoeff
f
    stake :: Rational
stake = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rational
0 forall c. IndividualPoolStake c -> Rational
individualPoolStake forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool (EraCrypto era)
poolHash Map
  (KeyHash 'StakePool (EraCrypto era))
  (IndividualPoolStake (EraCrypto era))
poolDistr
    poolDistr :: Map
  (KeyHash 'StakePool (EraCrypto era))
  (IndividualPoolStake (EraCrypto era))
poolDistr = forall c.
PoolDistr c -> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
unPoolDistr forall a b. (a -> b) -> a -> b
$ forall era. NewEpochState era -> PoolDistr (EraCrypto era)
nesPd NewEpochState era
ss
    STS.Tickn.TicknState Nonce
epochNonce Nonce
_ = forall c. ChainDepState c -> TicknState
csTickn ChainDepState (EraCrypto era)
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 ::
  Crypto c =>
  FromByronTranslationContext c ->
  LedgerView c
mkInitialShelleyLedgerView :: forall c. Crypto c => FromByronTranslationContext c -> LedgerView c
mkInitialShelleyLedgerView FromByronTranslationContext c
transCtxt =
  let !ee :: Nonce
ee = forall c. FromByronTranslationContext c -> PParams (ShelleyEra c)
fbtcProtocolParams FromByronTranslationContext c
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 = forall c. FromByronTranslationContext c -> PParams (ShelleyEra c)
fbtcProtocolParams FromByronTranslationContext c
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 c
lvPoolDistr = forall c.
Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> CompactForm Coin -> PoolDistr c
PoolDistr forall k a. Map k a
Map.empty forall a. Monoid a => a
mempty
        , lvGenDelegs :: GenDelegs c
lvGenDelegs = forall c. Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
GenDelegs forall a b. (a -> b) -> a -> b
$ forall c.
FromByronTranslationContext c
-> Map (KeyHash 'Genesis c) (GenDelegPair c)
fbtcGenDelegs FromByronTranslationContext c
transCtxt
        , lvChainChecks :: ChainChecksPParams
lvChainChecks = forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. FromByronTranslationContext c -> PParams (ShelleyEra c)
fbtcProtocolParams forall a b. (a -> b) -> a -> b
$ FromByronTranslationContext c
transCtxt
        }