{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Interface to the block validation and chain extension logic in the Shelley
-- API.
module Cardano.Ledger.Shelley.API.Validation
  ( ApplyBlock (..),
    applyBlock,
    applyTick,
    TickTransitionError (..),
    BlockTransitionError (..),
    chainChecks,
    ShelleyEraCrypto,
  )
where

import Cardano.Ledger.BHeaderView (BHeaderView)
import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase)
import Cardano.Ledger.Block (Block)
import qualified Cardano.Ledger.Chain as STS
import Cardano.Ledger.Core (ChainData, SerialisableData)
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Crypto as CC (Crypto)
import Cardano.Ledger.Era (Crypto, TxSeq)
import Cardano.Ledger.Hashes (EraIndependentTxBody)
import Cardano.Ledger.Keys (DSignable, Hash)
import Cardano.Ledger.Serialization (ToCBORGroup)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.LedgerState (NewEpochState)
import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState
import Cardano.Ledger.Shelley.PParams (PParams' (..))
import qualified Cardano.Ledger.Shelley.Rules.Bbody as STS
import Cardano.Ledger.Shelley.Rules.EraMapping ()
import Cardano.Ledger.Slot (SlotNo)
import Control.Arrow (left, right)
import Control.Monad.Except
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)

{-------------------------------------------------------------------------------
  Block validation API
-------------------------------------------------------------------------------}

class
  ( ChainData (NewEpochState era),
    SerialisableData (NewEpochState era),
    ChainData (BlockTransitionError era),
    ChainData STS.ChainPredicateFailure,
    STS (Core.EraRule "TICK" era),
    BaseM (Core.EraRule "TICK" era) ~ ShelleyBase,
    Environment (Core.EraRule "TICK" era) ~ (),
    State (Core.EraRule "TICK" era) ~ NewEpochState era,
    Signal (Core.EraRule "TICK" era) ~ SlotNo,
    STS (Core.EraRule "BBODY" era),
    BaseM (Core.EraRule "BBODY" era) ~ ShelleyBase,
    Environment (Core.EraRule "BBODY" era) ~ STS.BbodyEnv era,
    State (Core.EraRule "BBODY" era) ~ STS.BbodyState era,
    Signal (Core.EraRule "BBODY" era) ~ Block (BHeaderView (Crypto era)) era,
    ToCBORGroup (TxSeq era)
  ) =>
  ApplyBlock era
  where
  -- | Apply the header level ledger transition.
  --
  -- This handles checks and updates that happen on a slot tick, as well as a
  -- few header level checks, such as size constraints.
  applyTickOpts ::
    ApplySTSOpts ep ->
    Globals ->
    NewEpochState era ->
    SlotNo ->
    EventReturnType ep (Core.EraRule "TICK" era) (NewEpochState era)
  applyTickOpts ApplySTSOpts ep
opts Globals
globals NewEpochState era
state SlotNo
hdr =
    ([PredicateFailure (EraRule "TICK" era)]
 -> EventReturnType ep (EraRule "TICK" era) (NewEpochState era))
-> (EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
    -> EventReturnType ep (EraRule "TICK" era) (NewEpochState era))
-> Either
     [PredicateFailure (EraRule "TICK" era)]
     (EventReturnType ep (EraRule "TICK" era) (NewEpochState era))
-> EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [PredicateFailure (EraRule "TICK" era)]
-> EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
forall a b. Show a => a -> b
err EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
-> EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
forall a. a -> a
id
      (Either
   [PredicateFailure (EraRule "TICK" era)]
   (EventReturnType ep (EraRule "TICK" era) (NewEpochState era))
 -> EventReturnType ep (EraRule "TICK" era) (NewEpochState era))
-> (TRC (EraRule "TICK" era)
    -> Either
         [PredicateFailure (EraRule "TICK" era)]
         (EventReturnType ep (EraRule "TICK" era) (NewEpochState era)))
-> TRC (EraRule "TICK" era)
-> EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reader
   Globals
   (Either
      [PredicateFailure (EraRule "TICK" era)]
      (EventReturnType ep (EraRule "TICK" era) (NewEpochState era)))
 -> Globals
 -> Either
      [PredicateFailure (EraRule "TICK" era)]
      (EventReturnType ep (EraRule "TICK" era) (NewEpochState era)))
-> Globals
-> Reader
     Globals
     (Either
        [PredicateFailure (EraRule "TICK" era)]
        (EventReturnType ep (EraRule "TICK" era) (NewEpochState era)))
-> Either
     [PredicateFailure (EraRule "TICK" era)]
     (EventReturnType ep (EraRule "TICK" era) (NewEpochState era))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals
  (Either
     [PredicateFailure (EraRule "TICK" era)]
     (EventReturnType ep (EraRule "TICK" era) (NewEpochState era)))
-> Globals
-> Either
     [PredicateFailure (EraRule "TICK" era)]
     (EventReturnType ep (EraRule "TICK" era) (NewEpochState era))
forall r a. Reader r a -> r -> a
runReader Globals
globals
      (Reader
   Globals
   (Either
      [PredicateFailure (EraRule "TICK" era)]
      (EventReturnType ep (EraRule "TICK" era) (NewEpochState era)))
 -> Either
      [PredicateFailure (EraRule "TICK" era)]
      (EventReturnType ep (EraRule "TICK" era) (NewEpochState era)))
-> (TRC (EraRule "TICK" era)
    -> Reader
         Globals
         (Either
            [PredicateFailure (EraRule "TICK" era)]
            (EventReturnType ep (EraRule "TICK" era) (NewEpochState era))))
-> TRC (EraRule "TICK" era)
-> Either
     [PredicateFailure (EraRule "TICK" era)]
     (EventReturnType ep (EraRule "TICK" era) (NewEpochState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplySTSOpts ep
-> RuleContext 'Transition (EraRule "TICK" era)
-> ReaderT
     Globals
     Identity
     (Either
        [PredicateFailure (EraRule "TICK" era)]
        (EventReturnType
           ep (EraRule "TICK" era) (State (EraRule "TICK" era))))
forall s (m :: * -> *) (rtype :: RuleType) (ep :: EventPolicy).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
ApplySTSOpts ep
-> RuleContext rtype s
-> m (Either [PredicateFailure s] (EventReturnType ep s (State s)))
applySTSOptsEither @(Core.EraRule "TICK" era) ApplySTSOpts ep
opts
      (TRC (EraRule "TICK" era)
 -> EventReturnType ep (EraRule "TICK" era) (NewEpochState era))
-> TRC (EraRule "TICK" era)
-> EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule "TICK" era), State (EraRule "TICK" era),
 Signal (EraRule "TICK" era))
-> TRC (EraRule "TICK" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (EraRule "TICK" era)
NewEpochState era
state, SlotNo
Signal (EraRule "TICK" era)
hdr)
    where
      err :: Show a => a -> b
      err :: a -> b
err a
msg = [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"Panic! applyTick failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> a -> [Char]
forall a. Show a => a -> [Char]
show a
msg

  -- | Apply the block level ledger transition.
  applyBlockOpts ::
    forall ep m.
    (EventReturnTypeRep ep, MonadError (BlockTransitionError era) m) =>
    ApplySTSOpts ep ->
    Globals ->
    NewEpochState era ->
    Block (BHeaderView (Crypto era)) era ->
    m (EventReturnType ep (Core.EraRule "BBODY" era) (NewEpochState era))
  applyBlockOpts ApplySTSOpts ep
opts Globals
globals NewEpochState era
state Block (BHeaderView (Crypto era)) era
blk =
    Either
  (BlockTransitionError era)
  (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      (Either
   (BlockTransitionError era)
   (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
 -> m (EventReturnType
         ep (EraRule "BBODY" era) (NewEpochState era)))
-> (Either
      [PredicateFailure (EraRule "BBODY" era)]
      (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
    -> Either
         (BlockTransitionError era)
         (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era)))
-> Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PredicateFailure (EraRule "BBODY" era)]
 -> BlockTransitionError era)
-> Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
-> Either
     (BlockTransitionError era)
     (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left [PredicateFailure (EraRule "BBODY" era)]
-> BlockTransitionError era
forall era.
[PredicateFailure (EraRule "BBODY" era)]
-> BlockTransitionError era
BlockTransitionError
      (Either
   [PredicateFailure (EraRule "BBODY" era)]
   (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
 -> Either
      (BlockTransitionError era)
      (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era)))
-> (Either
      [PredicateFailure (EraRule "BBODY" era)]
      (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
    -> Either
         [PredicateFailure (EraRule "BBODY" era)]
         (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era)))
-> Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
-> Either
     (BlockTransitionError era)
     (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EventReturnType ep (EraRule "BBODY" era) (BbodyState era)
 -> EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
-> Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
-> Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right
        ( forall a b.
EventReturnTypeRep ep =>
(a -> b)
-> EventReturnType ep (EraRule "BBODY" era) a
-> EventReturnType ep (EraRule "BBODY" era) b
forall (ep :: EventPolicy) sts a b.
EventReturnTypeRep ep =>
(a -> b) -> EventReturnType ep sts a -> EventReturnType ep sts b
mapEventReturn @ep @(Core.EraRule "BBODY" era) ((BbodyState era -> NewEpochState era)
 -> EventReturnType ep (EraRule "BBODY" era) (BbodyState era)
 -> EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
-> (BbodyState era -> NewEpochState era)
-> EventReturnType ep (EraRule "BBODY" era) (BbodyState era)
-> EventReturnType ep (EraRule "BBODY" era) (NewEpochState era)
forall a b. (a -> b) -> a -> b
$
            NewEpochState era -> BbodyState era -> NewEpochState era
forall era.
NewEpochState era -> BbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
state
        )
      (Either
   [PredicateFailure (EraRule "BBODY" era)]
   (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
 -> m (EventReturnType
         ep (EraRule "BBODY" era) (NewEpochState era)))
-> Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
forall a b. (a -> b) -> a -> b
$ Either
  [PredicateFailure (EraRule "BBODY" era)]
  (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
res
    where
      res :: Either
  [PredicateFailure (EraRule "BBODY" era)]
  (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
res =
        (Reader
   Globals
   (Either
      [PredicateFailure (EraRule "BBODY" era)]
      (EventReturnType ep (EraRule "BBODY" era) (BbodyState era)))
 -> Globals
 -> Either
      [PredicateFailure (EraRule "BBODY" era)]
      (EventReturnType ep (EraRule "BBODY" era) (BbodyState era)))
-> Globals
-> Reader
     Globals
     (Either
        [PredicateFailure (EraRule "BBODY" era)]
        (EventReturnType ep (EraRule "BBODY" era) (BbodyState era)))
-> Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals
  (Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (BbodyState era)))
-> Globals
-> Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader
   Globals
   (Either
      [PredicateFailure (EraRule "BBODY" era)]
      (EventReturnType ep (EraRule "BBODY" era) (BbodyState era)))
 -> Either
      [PredicateFailure (EraRule "BBODY" era)]
      (EventReturnType ep (EraRule "BBODY" era) (BbodyState era)))
-> (TRC (EraRule "BBODY" era)
    -> Reader
         Globals
         (Either
            [PredicateFailure (EraRule "BBODY" era)]
            (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))))
-> TRC (EraRule "BBODY" era)
-> Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplySTSOpts ep
-> RuleContext 'Transition (EraRule "BBODY" era)
-> ReaderT
     Globals
     Identity
     (Either
        [PredicateFailure (EraRule "BBODY" era)]
        (EventReturnType
           ep (EraRule "BBODY" era) (State (EraRule "BBODY" era))))
forall s (m :: * -> *) (rtype :: RuleType) (ep :: EventPolicy).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
ApplySTSOpts ep
-> RuleContext rtype s
-> m (Either [PredicateFailure s] (EventReturnType ep s (State s)))
applySTSOptsEither @(Core.EraRule "BBODY" era)
            ApplySTSOpts ep
opts
          (TRC (EraRule "BBODY" era)
 -> Either
      [PredicateFailure (EraRule "BBODY" era)]
      (EventReturnType ep (EraRule "BBODY" era) (BbodyState era)))
-> TRC (EraRule "BBODY" era)
-> Either
     [PredicateFailure (EraRule "BBODY" era)]
     (EventReturnType ep (EraRule "BBODY" era) (BbodyState era))
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule "BBODY" era), State (EraRule "BBODY" era),
 Signal (EraRule "BBODY" era))
-> TRC (EraRule "BBODY" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (NewEpochState era -> BbodyEnv era
forall era. NewEpochState era -> BbodyEnv era
mkBbodyEnv NewEpochState era
state, State (EraRule "BBODY" era)
BbodyState era
bbs, Block (BHeaderView (Crypto era)) era
Signal (EraRule "BBODY" era)
blk)
      bbs :: BbodyState era
bbs =
        LedgerState era -> BlocksMade (Crypto era) -> BbodyState era
forall era.
LedgerState era -> BlocksMade (Crypto era) -> BbodyState era
STS.BbodyState
          (EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
LedgerState.esLState (EpochState era -> LedgerState era)
-> EpochState era -> LedgerState era
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
state)
          (NewEpochState era -> BlocksMade (Crypto era)
forall era. NewEpochState era -> BlocksMade (Crypto era)
LedgerState.nesBcur NewEpochState era
state)

  -- | Re-apply a ledger block to the same state it has been applied to before.
  --
  -- This function does no validation of whether the block applies successfully;
  -- the caller implicitly guarantees that they have previously called
  -- 'applyBlockTransition' on the same block and that this was successful.
  reapplyBlock ::
    Globals ->
    NewEpochState era ->
    Block (BHeaderView (Crypto era)) era ->
    NewEpochState era
  reapplyBlock Globals
globals NewEpochState era
state Block (BHeaderView (Crypto era)) era
blk =
    NewEpochState era -> BbodyState era -> NewEpochState era
forall era.
NewEpochState era -> BbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
state BbodyState era
res
    where
      res :: BbodyState era
res =
        (Reader Globals (BbodyState era) -> Globals -> BbodyState era)
-> Globals -> Reader Globals (BbodyState era) -> BbodyState era
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader Globals (BbodyState era) -> Globals -> BbodyState era
forall r a. Reader r a -> r -> a
runReader Globals
globals (Reader Globals (BbodyState era) -> BbodyState era)
-> (TRC (EraRule "BBODY" era) -> Reader Globals (BbodyState era))
-> TRC (EraRule "BBODY" era)
-> BbodyState 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 (State s)
forall (m :: * -> *) (rtype :: RuleType).
(STS (EraRule "BBODY" era), RuleTypeRep rtype,
 m ~ BaseM (EraRule "BBODY" era)) =>
RuleContext rtype (EraRule "BBODY" era)
-> m (State (EraRule "BBODY" era))
reapplySTS @(Core.EraRule "BBODY" era) (TRC (EraRule "BBODY" era) -> BbodyState era)
-> TRC (EraRule "BBODY" era) -> BbodyState era
forall a b. (a -> b) -> a -> b
$
          (Environment (EraRule "BBODY" era), State (EraRule "BBODY" era),
 Signal (EraRule "BBODY" era))
-> TRC (EraRule "BBODY" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (NewEpochState era -> BbodyEnv era
forall era. NewEpochState era -> BbodyEnv era
mkBbodyEnv NewEpochState era
state, State (EraRule "BBODY" era)
BbodyState era
bbs, Block (BHeaderView (Crypto era)) era
Signal (EraRule "BBODY" era)
blk)
      bbs :: BbodyState era
bbs =
        LedgerState era -> BlocksMade (Crypto era) -> BbodyState era
forall era.
LedgerState era -> BlocksMade (Crypto era) -> BbodyState era
STS.BbodyState
          (EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
LedgerState.esLState (EpochState era -> LedgerState era)
-> EpochState era -> LedgerState era
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
state)
          (NewEpochState era -> BlocksMade (Crypto era)
forall era. NewEpochState era -> BlocksMade (Crypto era)
LedgerState.nesBcur NewEpochState era
state)

applyTick ::
  ApplyBlock era =>
  Globals ->
  NewEpochState era ->
  SlotNo ->
  NewEpochState era
applyTick :: Globals -> NewEpochState era -> SlotNo -> NewEpochState era
applyTick =
  ApplySTSOpts 'EventPolicyDiscard
-> Globals
-> NewEpochState era
-> SlotNo
-> EventReturnType
     'EventPolicyDiscard (EraRule "TICK" era) (NewEpochState era)
forall era (ep :: EventPolicy).
ApplyBlock era =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> SlotNo
-> EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
applyTickOpts (ApplySTSOpts 'EventPolicyDiscard
 -> Globals
 -> NewEpochState era
 -> SlotNo
 -> EventReturnType
      'EventPolicyDiscard (EraRule "TICK" era) (NewEpochState era))
-> ApplySTSOpts 'EventPolicyDiscard
-> Globals
-> NewEpochState era
-> SlotNo
-> EventReturnType
     'EventPolicyDiscard (EraRule "TICK" era) (NewEpochState era)
forall a b. (a -> b) -> a -> b
$
    ApplySTSOpts :: forall (ep :: EventPolicy).
AssertionPolicy -> ValidationPolicy -> SingEP ep -> ApplySTSOpts ep
ApplySTSOpts
      { asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
globalAssertionPolicy,
        asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
ValidateAll,
        asoEvents :: SingEP 'EventPolicyDiscard
asoEvents = SingEP 'EventPolicyDiscard
EPDiscard
      }

applyBlock ::
  ( ApplyBlock era,
    MonadError (BlockTransitionError era) m
  ) =>
  Globals ->
  NewEpochState era ->
  Block (BHeaderView (Crypto era)) era ->
  m (NewEpochState era)
applyBlock :: Globals
-> NewEpochState era
-> Block (BHeaderView (Crypto era)) era
-> m (NewEpochState era)
applyBlock =
  ApplySTSOpts 'EventPolicyDiscard
-> Globals
-> NewEpochState era
-> Block (BHeaderView (Crypto era)) era
-> m (EventReturnType
        'EventPolicyDiscard (EraRule "BBODY" era) (NewEpochState era))
forall era (ep :: EventPolicy) (m :: * -> *).
(ApplyBlock era, EventReturnTypeRep ep,
 MonadError (BlockTransitionError era) m) =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> Block (BHeaderView (Crypto era)) era
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
applyBlockOpts (ApplySTSOpts 'EventPolicyDiscard
 -> Globals
 -> NewEpochState era
 -> Block (BHeaderView (Crypto era)) era
 -> m (EventReturnType
         'EventPolicyDiscard (EraRule "BBODY" era) (NewEpochState era)))
-> ApplySTSOpts 'EventPolicyDiscard
-> Globals
-> NewEpochState era
-> Block (BHeaderView (Crypto era)) era
-> m (EventReturnType
        'EventPolicyDiscard (EraRule "BBODY" era) (NewEpochState era))
forall a b. (a -> b) -> a -> b
$
    ApplySTSOpts :: forall (ep :: EventPolicy).
AssertionPolicy -> ValidationPolicy -> SingEP ep -> ApplySTSOpts ep
ApplySTSOpts
      { asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
globalAssertionPolicy,
        asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
ValidateAll,
        asoEvents :: SingEP 'EventPolicyDiscard
asoEvents = SingEP 'EventPolicyDiscard
EPDiscard
      }

type ShelleyEraCrypto crypto =
  ( CC.Crypto crypto,
    DSignable crypto (Hash crypto EraIndependentTxBody)
  )

instance ShelleyEraCrypto crypto => ApplyBlock (ShelleyEra crypto)

{-------------------------------------------------------------------------------
  CHAIN Transition checks
-------------------------------------------------------------------------------}

chainChecks ::
  forall crypto m.
  MonadError STS.ChainPredicateFailure m =>
  -- | Max major protocol version
  Natural ->
  STS.ChainChecksPParams ->
  BHeaderView crypto ->
  m ()
chainChecks :: Natural -> ChainChecksPParams -> BHeaderView crypto -> m ()
chainChecks = Natural -> ChainChecksPParams -> BHeaderView crypto -> m ()
forall (m :: * -> *) crypto.
MonadError ChainPredicateFailure m =>
Natural -> ChainChecksPParams -> BHeaderView crypto -> m ()
STS.chainChecks

{-------------------------------------------------------------------------------
  Applying blocks
-------------------------------------------------------------------------------}

mkBbodyEnv ::
  NewEpochState era ->
  STS.BbodyEnv era
mkBbodyEnv :: NewEpochState era -> BbodyEnv era
mkBbodyEnv
  LedgerState.NewEpochState
    { EpochState era
nesEs :: EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
LedgerState.nesEs
    } =
    BbodyEnv :: forall era. PParams era -> AccountState -> BbodyEnv era
STS.BbodyEnv
      { bbodyPp :: PParams era
STS.bbodyPp = EpochState era -> PParams era
forall era. EpochState era -> PParams era
LedgerState.esPp EpochState era
nesEs,
        bbodyAccount :: AccountState
STS.bbodyAccount = EpochState era -> AccountState
forall era. EpochState era -> AccountState
LedgerState.esAccountState EpochState era
nesEs
      }

updateNewEpochState ::
  NewEpochState era ->
  STS.BbodyState era ->
  NewEpochState era
updateNewEpochState :: NewEpochState era -> BbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
ss (STS.BbodyState LedgerState era
ls BlocksMade (Crypto era)
bcur) =
  NewEpochState era
-> BlocksMade (Crypto era) -> LedgerState era -> NewEpochState era
forall era.
NewEpochState era
-> BlocksMade (Crypto era) -> LedgerState era -> NewEpochState era
LedgerState.updateNES NewEpochState era
ss BlocksMade (Crypto era)
bcur LedgerState era
ls

newtype TickTransitionError era
  = TickTransitionError [STS.PredicateFailure (Core.EraRule "TICK" era)]
  deriving ((forall x.
 TickTransitionError era -> Rep (TickTransitionError era) x)
-> (forall x.
    Rep (TickTransitionError era) x -> TickTransitionError era)
-> Generic (TickTransitionError era)
forall x.
Rep (TickTransitionError era) x -> TickTransitionError era
forall x.
TickTransitionError era -> Rep (TickTransitionError era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (TickTransitionError era) x -> TickTransitionError era
forall era x.
TickTransitionError era -> Rep (TickTransitionError era) x
$cto :: forall era x.
Rep (TickTransitionError era) x -> TickTransitionError era
$cfrom :: forall era x.
TickTransitionError era -> Rep (TickTransitionError era) x
Generic)

instance
  (NoThunks (STS.PredicateFailure (Core.EraRule "TICK" era))) =>
  NoThunks (TickTransitionError era)

deriving stock instance
  (Eq (STS.PredicateFailure (Core.EraRule "TICK" era))) =>
  Eq (TickTransitionError era)

deriving stock instance
  (Show (STS.PredicateFailure (Core.EraRule "TICK" era))) =>
  Show (TickTransitionError era)

newtype BlockTransitionError era
  = BlockTransitionError [STS.PredicateFailure (Core.EraRule "BBODY" era)]
  deriving ((forall x.
 BlockTransitionError era -> Rep (BlockTransitionError era) x)
-> (forall x.
    Rep (BlockTransitionError era) x -> BlockTransitionError era)
-> Generic (BlockTransitionError era)
forall x.
Rep (BlockTransitionError era) x -> BlockTransitionError era
forall x.
BlockTransitionError era -> Rep (BlockTransitionError era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (BlockTransitionError era) x -> BlockTransitionError era
forall era x.
BlockTransitionError era -> Rep (BlockTransitionError era) x
$cto :: forall era x.
Rep (BlockTransitionError era) x -> BlockTransitionError era
$cfrom :: forall era x.
BlockTransitionError era -> Rep (BlockTransitionError era) x
Generic)

deriving stock instance
  (Eq (STS.PredicateFailure (Core.EraRule "BBODY" era))) =>
  Eq (BlockTransitionError era)

deriving stock instance
  (Show (STS.PredicateFailure (Core.EraRule "BBODY" era))) =>
  Show (BlockTransitionError era)

instance
  (NoThunks (STS.PredicateFailure (Core.EraRule "BBODY" era))) =>
  NoThunks (BlockTransitionError era)