{-# LANGUAGE DefaultSignatures #-}
{-# 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 Shelley.Spec.Ledger.API.Validation
  ( ApplyBlock (..),
    TickTransitionError (..),
    BlockTransitionError (..),
    chainChecks,
  )
where

import Cardano.Ledger.Core (AnnotatedData, ChainData, SerialisableData)
import Cardano.Ledger.Era (Crypto, Era)
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
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Shelley.Spec.Ledger.API.Protocol (PraosCrypto)
import Shelley.Spec.Ledger.BaseTypes (Globals (..))
import Shelley.Spec.Ledger.BlockChain
import Shelley.Spec.Ledger.LedgerState (NewEpochState)
import qualified Shelley.Spec.Ledger.LedgerState as LedgerState
import qualified Shelley.Spec.Ledger.STS.Bbody as STS
import qualified Shelley.Spec.Ledger.STS.Chain as STS
import qualified Shelley.Spec.Ledger.STS.Tick as STS
import Shelley.Spec.Ledger.Slot (SlotNo)

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

class
  ( ChainData (Block era),
    AnnotatedData (Block era),
    ChainData (BHeader (Crypto era)),
    AnnotatedData (BHeader (Crypto era)),
    ChainData (NewEpochState era),
    SerialisableData (NewEpochState era),
    ChainData (BlockTransitionError era),
    ChainData (STS.PredicateFailure (STS.CHAIN 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.
  applyTick ::
    Globals ->
    NewEpochState era ->
    SlotNo ->
    NewEpochState era
  default applyTick ::
    ShelleyBased era =>
    Globals ->
    NewEpochState era ->
    SlotNo ->
    NewEpochState era
  applyTick Globals
globals NewEpochState era
state SlotNo
hdr =
    (([[TickPredicateFailure era]] -> NewEpochState era)
-> (NewEpochState era -> NewEpochState era)
-> Either [[TickPredicateFailure era]] (NewEpochState era)
-> NewEpochState era
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [[TickPredicateFailure era]] -> NewEpochState era
forall a b. Show a => a -> b
err NewEpochState era -> NewEpochState era
forall a. a -> a
id) (Either [[TickPredicateFailure era]] (NewEpochState era)
 -> NewEpochState era)
-> (TRC (TICK era)
    -> Either [[TickPredicateFailure era]] (NewEpochState era))
-> TRC (TICK era)
-> NewEpochState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reader
   Globals (Either [[TickPredicateFailure era]] (NewEpochState era))
 -> Globals
 -> Either [[TickPredicateFailure era]] (NewEpochState era))
-> Globals
-> Reader
     Globals (Either [[TickPredicateFailure era]] (NewEpochState era))
-> Either [[TickPredicateFailure era]] (NewEpochState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals (Either [[TickPredicateFailure era]] (NewEpochState era))
-> Globals
-> Either [[TickPredicateFailure era]] (NewEpochState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals
      (Reader
   Globals (Either [[TickPredicateFailure era]] (NewEpochState era))
 -> Either [[TickPredicateFailure era]] (NewEpochState era))
-> (TRC (TICK era)
    -> Reader
         Globals (Either [[TickPredicateFailure era]] (NewEpochState era)))
-> TRC (TICK era)
-> Either [[TickPredicateFailure 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 (TICK era), RuleTypeRep rtype, m ~ BaseM (TICK era)) =>
RuleContext rtype (TICK era)
-> m (Either [[PredicateFailure (TICK era)]] (State (TICK era)))
applySTS @(STS.TICK era)
      (TRC (TICK era) -> NewEpochState era)
-> TRC (TICK era) -> NewEpochState era
forall a b. (a -> b) -> a -> b
$ (Environment (TICK era), State (TICK era), Signal (TICK era))
-> TRC (TICK era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (TICK era)
NewEpochState era
state, SlotNo
Signal (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.
  applyBlock ::
    MonadError (BlockTransitionError era) m =>
    Globals ->
    NewEpochState era ->
    Block era ->
    m (NewEpochState era)
  default applyBlock ::
    ( STS (STS.BBODY era),
      MonadError (BlockTransitionError era) m
    ) =>
    Globals ->
    NewEpochState era ->
    Block era ->
    m (NewEpochState era)
  applyBlock Globals
globals NewEpochState era
state Block era
blk =
    Either (BlockTransitionError era) (NewEpochState era)
-> m (NewEpochState era)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      (Either (BlockTransitionError era) (NewEpochState era)
 -> m (NewEpochState era))
-> (Either [[BbodyPredicateFailure era]] (BbodyState era)
    -> Either (BlockTransitionError era) (NewEpochState era))
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
-> m (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BbodyState era -> NewEpochState era)
-> Either (BlockTransitionError era) (BbodyState era)
-> Either (BlockTransitionError era) (NewEpochState era)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right (NewEpochState era -> BbodyState era -> NewEpochState era
forall era.
NewEpochState era -> BbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
state)
      (Either (BlockTransitionError era) (BbodyState era)
 -> Either (BlockTransitionError era) (NewEpochState era))
-> (Either [[BbodyPredicateFailure era]] (BbodyState era)
    -> Either (BlockTransitionError era) (BbodyState era))
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
-> Either (BlockTransitionError era) (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[BbodyPredicateFailure era]] -> BlockTransitionError era)
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
-> Either (BlockTransitionError era) (BbodyState era)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ([BbodyPredicateFailure era] -> BlockTransitionError era
forall era.
[PredicateFailure (BBODY era)] -> BlockTransitionError era
BlockTransitionError ([BbodyPredicateFailure era] -> BlockTransitionError era)
-> ([[BbodyPredicateFailure era]] -> [BbodyPredicateFailure era])
-> [[BbodyPredicateFailure era]]
-> BlockTransitionError era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[BbodyPredicateFailure era]] -> [BbodyPredicateFailure era]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join)
      (Either [[BbodyPredicateFailure era]] (BbodyState era)
 -> m (NewEpochState era))
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
-> m (NewEpochState era)
forall a b. (a -> b) -> a -> b
$ Either [[BbodyPredicateFailure era]] (BbodyState era)
res
    where
      res :: Either [[BbodyPredicateFailure era]] (BbodyState era)
res =
        (Reader
   Globals (Either [[BbodyPredicateFailure era]] (BbodyState era))
 -> Globals
 -> Either [[BbodyPredicateFailure era]] (BbodyState era))
-> Globals
-> Reader
     Globals (Either [[BbodyPredicateFailure era]] (BbodyState era))
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals (Either [[BbodyPredicateFailure era]] (BbodyState era))
-> Globals -> Either [[BbodyPredicateFailure era]] (BbodyState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals (Reader
   Globals (Either [[BbodyPredicateFailure era]] (BbodyState era))
 -> Either [[BbodyPredicateFailure era]] (BbodyState era))
-> (TRC (BBODY era)
    -> Reader
         Globals (Either [[BbodyPredicateFailure era]] (BbodyState era)))
-> TRC (BBODY era)
-> Either [[BbodyPredicateFailure 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 (Either [[PredicateFailure s]] (State s))
forall (m :: * -> *) (rtype :: RuleType).
(STS (BBODY era), RuleTypeRep rtype, m ~ BaseM (BBODY era)) =>
RuleContext rtype (BBODY era)
-> m (Either [[PredicateFailure (BBODY era)]] (State (BBODY era)))
applySTS @(STS.BBODY era) (TRC (BBODY era)
 -> Either [[BbodyPredicateFailure era]] (BbodyState era))
-> TRC (BBODY era)
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
forall a b. (a -> b) -> a -> b
$
          (Environment (BBODY era), State (BBODY era), Signal (BBODY era))
-> TRC (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 (BBODY era)
BbodyState era
bbs, Signal (BBODY era)
Block era
blk)
      bbs :: BbodyState era
bbs =
        LedgerState era -> BlocksMade era -> BbodyState era
forall era. LedgerState era -> BlocksMade 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 era
forall era. NewEpochState era -> BlocksMade 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 era ->
    NewEpochState era
  default reapplyBlock ::
    STS (STS.BBODY era) =>
    Globals ->
    NewEpochState era ->
    Block era ->
    NewEpochState era
  reapplyBlock Globals
globals NewEpochState era
state Block 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 (BBODY era) -> Reader Globals (BbodyState era))
-> TRC (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 (BBODY era), RuleTypeRep rtype, m ~ BaseM (BBODY era)) =>
RuleContext rtype (BBODY era) -> m (State (BBODY era))
reapplySTS @(STS.BBODY era) (TRC (BBODY era) -> BbodyState era)
-> TRC (BBODY era) -> BbodyState era
forall a b. (a -> b) -> a -> b
$
          (Environment (BBODY era), State (BBODY era), Signal (BBODY era))
-> TRC (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 (BBODY era)
BbodyState era
bbs, Signal (BBODY era)
Block era
blk)
      bbs :: BbodyState era
bbs =
        LedgerState era -> BlocksMade era -> BbodyState era
forall era. LedgerState era -> BlocksMade 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 era
forall era. NewEpochState era -> BlocksMade era
LedgerState.nesBcur NewEpochState era
state)

instance PraosCrypto crypto => ApplyBlock (ShelleyEra crypto)

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

chainChecks ::
  forall era m.
  ( Era era,
    MonadError (STS.PredicateFailure (STS.CHAIN era)) m
  ) =>
  Globals ->
  STS.ChainChecksData ->
  BHeader (Crypto era) ->
  m ()
chainChecks :: Globals -> ChainChecksData -> BHeader (Crypto era) -> m ()
chainChecks Globals
globals ChainChecksData
ccd BHeader (Crypto era)
bh = Natural -> ChainChecksData -> BHeader (Crypto era) -> m ()
forall era (m :: * -> *).
(Era era, MonadError (PredicateFailure (CHAIN era)) m) =>
Natural -> ChainChecksData -> BHeader (Crypto era) -> m ()
STS.chainChecks (Globals -> Natural
maxMajorPV Globals
globals) ChainChecksData
ccd BHeader (Crypto era)
bh

{-------------------------------------------------------------------------------
  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 era
bcur) =
  NewEpochState era
-> BlocksMade era -> LedgerState era -> NewEpochState era
forall era.
NewEpochState era
-> BlocksMade era -> LedgerState era -> NewEpochState era
LedgerState.updateNES NewEpochState era
ss BlocksMade era
bcur LedgerState era
ls

newtype TickTransitionError era
  = TickTransitionError [STS.PredicateFailure (STS.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 (STS.TICK era))) =>
  NoThunks (TickTransitionError era)

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

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

newtype BlockTransitionError era
  = BlockTransitionError [STS.PredicateFailure (STS.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 (STS.BBODY era))) =>
  Eq (BlockTransitionError era)

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

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