{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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 Shelley.Spec.Ledger.API.Protocol
  ( PraosCrypto,
    GetLedgerView (..),
    LedgerView (..),
    FutureLedgerViewError (..),
    -- $chainstate
    ChainDepState (..),
    ChainTransitionError (..),
    tickChainDepState,
    updateChainDepState,
    reupdateChainDepState,
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen)
import Cardano.Ledger.Core (ChainData, SerialisableData)
import qualified Cardano.Ledger.Crypto as CC (Crypto)
import Cardano.Ledger.Era (Crypto)
import Cardano.Ledger.Shelley (ShelleyBased, ShelleyEra)
import Control.Arrow (left, right)
import Control.Monad.Except
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
  ( PredicateFailure,
    TRC (..),
    applySTS,
    reapplySTS,
  )
import Data.Either (fromRight)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Shelley.Spec.Ledger.BaseTypes
  ( Globals,
    Nonce,
    Seed,
    UnitInterval,
  )
import Shelley.Spec.Ledger.BlockChain
  ( BHBody,
    BHeader,
    bhbody,
    bheaderPrev,
    prevHashToNonce,
  )
import Shelley.Spec.Ledger.Delegation.Certificates (PoolDistr)
import Shelley.Spec.Ledger.Hashing (EraIndependentTxBody)
import Shelley.Spec.Ledger.Keys (DSignable, GenDelegs, Hash, KESignable, VRFSignable)
import Shelley.Spec.Ledger.LedgerState
  ( EpochState (..),
    NewEpochState (..),
    _delegationState,
    _dstate,
    _genDelegs,
  )
import Shelley.Spec.Ledger.OCert (OCertSignable)
import Shelley.Spec.Ledger.PParams (PParams' (..))
import Shelley.Spec.Ledger.STS.Chain (ChainChecksData, pparamsToChainChecksData)
import qualified Shelley.Spec.Ledger.STS.Prtcl as STS.Prtcl
import Shelley.Spec.Ledger.STS.Tick (TICKF)
import qualified Shelley.Spec.Ledger.STS.Tickn as STS.Tickn
import Shelley.Spec.Ledger.Serialization (decodeRecordNamed)
import Shelley.Spec.Ledger.Slot (SlotNo)

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

class
  ( ChainData (ChainDepState (Crypto era)),
    SerialisableData (ChainDepState (Crypto era)),
    Eq (ChainTransitionError (Crypto era)),
    Show (ChainTransitionError (Crypto era)),
    Show (LedgerView (Crypto era)),
    Show (FutureLedgerViewError era)
  ) =>
  GetLedgerView era
  where
  currentLedgerView ::
    NewEpochState era ->
    LedgerView (Crypto era)
  currentLedgerView = NewEpochState era -> LedgerView (Crypto era)
forall era. NewEpochState era -> LedgerView (Crypto era)
view

  -- $timetravel
  futureLedgerView ::
    MonadError (FutureLedgerViewError era) m =>
    Globals ->
    NewEpochState era ->
    SlotNo ->
    m (LedgerView (Crypto era))
  default futureLedgerView ::
    (ShelleyBased era, MonadError (FutureLedgerViewError era) m) =>
    Globals ->
    NewEpochState era ->
    SlotNo ->
    m (LedgerView (Crypto era))
  futureLedgerView = Globals
-> NewEpochState era -> SlotNo -> m (LedgerView (Crypto era))
forall era (m :: * -> *).
(ShelleyBased era, MonadError (FutureLedgerViewError era) m) =>
Globals
-> NewEpochState era -> SlotNo -> m (LedgerView (Crypto era))
futureView

instance PraosCrypto crypto => GetLedgerView (ShelleyEra crypto)

-- | Data required by the Transitional Praos protocol from the Shelley ledger.
data LedgerView crypto = LedgerView
  { LedgerView crypto -> UnitInterval
lvD :: UnitInterval,
    LedgerView crypto -> Nonce
lvExtraEntropy :: Nonce,
    LedgerView crypto -> PoolDistr crypto
lvPoolDistr :: PoolDistr crypto,
    LedgerView crypto -> GenDelegs crypto
lvGenDelegs :: GenDelegs crypto,
    LedgerView crypto -> ChainChecksData
lvChainChecks :: ChainChecksData
  }
  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 -> String
(Int -> LedgerView crypto -> ShowS)
-> (LedgerView crypto -> String)
-> ([LedgerView crypto] -> ShowS)
-> Show (LedgerView crypto)
forall crypto. Int -> LedgerView crypto -> ShowS
forall crypto. [LedgerView crypto] -> ShowS
forall crypto. LedgerView crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LedgerView crypto] -> ShowS
$cshowList :: forall crypto. [LedgerView crypto] -> ShowS
show :: LedgerView crypto -> String
$cshow :: forall crypto. LedgerView crypto -> String
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 :: NewEpochState era -> LedgerView (Crypto era)
view :: NewEpochState era -> LedgerView (Crypto era)
view
  NewEpochState
    { PoolDistr (Crypto era)
nesPd :: forall era. NewEpochState era -> PoolDistr (Crypto era)
nesPd :: PoolDistr (Crypto era)
nesPd,
      EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
nesEs :: EpochState era
nesEs
    } =
    LedgerView :: forall crypto.
UnitInterval
-> Nonce
-> PoolDistr crypto
-> GenDelegs crypto
-> ChainChecksData
-> LedgerView crypto
LedgerView
      { lvD :: UnitInterval
lvD = PParams' Identity era -> UnitInterval
forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval
_d (PParams' Identity era -> UnitInterval)
-> (EpochState era -> PParams' Identity era)
-> EpochState era
-> UnitInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> PParams' Identity era
forall era. EpochState era -> PParams era
esPp (EpochState era -> UnitInterval) -> EpochState era -> UnitInterval
forall a b. (a -> b) -> a -> b
$ EpochState era
nesEs,
        lvExtraEntropy :: Nonce
lvExtraEntropy = PParams' Identity era -> Nonce
forall (f :: * -> *) era. PParams' f era -> HKD f Nonce
_extraEntropy (PParams' Identity era -> Nonce)
-> (EpochState era -> PParams' Identity era)
-> EpochState era
-> Nonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> PParams' Identity era
forall era. EpochState era -> PParams era
esPp (EpochState era -> Nonce) -> EpochState era -> Nonce
forall a b. (a -> b) -> a -> b
$ EpochState era
nesEs,
        lvPoolDistr :: PoolDistr (Crypto era)
lvPoolDistr = PoolDistr (Crypto era)
nesPd,
        lvGenDelegs :: GenDelegs (Crypto era)
lvGenDelegs =
          DState era -> GenDelegs (Crypto era)
forall era. DState era -> GenDelegs (Crypto era)
_genDelegs (DState era -> GenDelegs (Crypto era))
-> (LedgerState era -> DState era)
-> LedgerState era
-> GenDelegs (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DPState era -> DState era
forall era. DPState era -> DState era
_dstate
            (DPState era -> DState era)
-> (LedgerState era -> DPState era)
-> LedgerState era
-> DState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState era -> DPState era
forall era. LedgerState era -> DPState era
_delegationState
            (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
nesEs,
        lvChainChecks :: ChainChecksData
lvChainChecks = PParams' Identity era -> ChainChecksData
forall era. PParams era -> ChainChecksData
pparamsToChainChecksData (PParams' Identity era -> ChainChecksData)
-> (EpochState era -> PParams' Identity era)
-> EpochState era
-> ChainChecksData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> PParams' Identity era
forall era. EpochState era -> PParams era
esPp (EpochState era -> ChainChecksData)
-> EpochState era -> ChainChecksData
forall a b. (a -> b) -> a -> b
$ EpochState era
nesEs
      }

-- $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 (TICKF era)]

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

deriving stock instance
  (Show (PredicateFailure (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.
  ( ShelleyBased era,
    MonadError (FutureLedgerViewError era) m
  ) =>
  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. 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
. ([[TickfPredicateFailure era]] -> FutureLedgerViewError era)
-> Either [[TickfPredicateFailure 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 ([TickfPredicateFailure era] -> FutureLedgerViewError era
forall era.
[PredicateFailure (TICKF era)] -> FutureLedgerViewError era
FutureLedgerViewError ([TickfPredicateFailure era] -> FutureLedgerViewError era)
-> ([[TickfPredicateFailure era]] -> [TickfPredicateFailure era])
-> [[TickfPredicateFailure era]]
-> FutureLedgerViewError era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TickfPredicateFailure era]] -> [TickfPredicateFailure era]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join)
    (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 (TICKF era)
    -> Reader
         Globals (Either [[TickfPredicateFailure era]] (NewEpochState era)))
-> TRC (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 (TICKF era), RuleTypeRep rtype, m ~ BaseM (TICKF era)) =>
RuleContext rtype (TICKF era)
-> m (Either [[PredicateFailure (TICKF era)]] (State (TICKF era)))
applySTS @(TICKF era)
        (TRC (TICKF era)
 -> Either [[TickfPredicateFailure era]] (NewEpochState era))
-> TRC (TICKF era)
-> Either [[TickfPredicateFailure era]] (NewEpochState era)
forall a b. (a -> b) -> a -> b
$ (Environment (TICKF era), State (TICKF era), Signal (TICKF era))
-> TRC (TICKF era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (TICKF era)
NewEpochState era
ss, SlotNo
Signal (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 -> String
(Int -> ChainDepState crypto -> ShowS)
-> (ChainDepState crypto -> String)
-> ([ChainDepState crypto] -> ShowS)
-> Show (ChainDepState crypto)
forall crypto. Int -> ChainDepState crypto -> ShowS
forall crypto. [ChainDepState crypto] -> ShowS
forall crypto. ChainDepState crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainDepState crypto] -> ShowS
$cshowList :: forall crypto. [ChainDepState crypto] -> ShowS
show :: ChainDepState crypto -> String
$cshow :: forall crypto. ChainDepState crypto -> String
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)

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 = String -> a
forall a. HasCallStack => String -> a
error String
"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 ([PrtclPredicateFailure crypto] -> ChainTransitionError crypto)
-> ([[PrtclPredicateFailure crypto]]
    -> [PrtclPredicateFailure crypto])
-> [[PrtclPredicateFailure crypto]]
-> ChainTransitionError crypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[PrtclPredicateFailure crypto]] -> [PrtclPredicateFailure crypto]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join)
      (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