{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# 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,
)
where

import Cardano.Ledger.BHeaderView (BHeaderView)
import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase, Version)
import Cardano.Ledger.Binary (EncCBORGroup)
import Cardano.Ledger.Block (Block)
import qualified Cardano.Ledger.Chain as STS
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Keys (DSignable, Hash)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core (EraGov)
import Cardano.Ledger.Shelley.LedgerState (LedgerState (..), NewEpochState, curPParamsEpochStateL)
import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState
import Cardano.Ledger.Shelley.PParams ()
import Cardano.Ledger.Shelley.Rules ()
import qualified Cardano.Ledger.Shelley.Rules as STS
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 Data.List.NonEmpty (NonEmpty)
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))

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

class
  ( STS (EraRule "TICK" era)
  , BaseM (EraRule "TICK" era) ~ ShelleyBase
  , Environment (EraRule "TICK" era) ~ ()
  , State (EraRule "TICK" era) ~ NewEpochState era
  , Signal (EraRule "TICK" era) ~ SlotNo
  , STS (EraRule "BBODY" era)
  , BaseM (EraRule "BBODY" era) ~ ShelleyBase
  , Environment (EraRule "BBODY" era) ~ STS.BbodyEnv era
  , State (EraRule "BBODY" era) ~ STS.ShelleyBbodyState era
  , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era
  , EncCBORGroup (TxSeq era)
  , State (EraRule "LEDGERS" era) ~ LedgerState 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 (EraRule "TICK" era) (NewEpochState era)
  applyTickOpts ApplySTSOpts ep
opts Globals
globals NewEpochState era
state SlotNo
hdr =
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. Show a => a -> b
err forall a. a -> a
id
      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) (ep :: EventPolicy).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
ApplySTSOpts ep
-> RuleContext rtype s
-> m (Either
        (NonEmpty (PredicateFailure s)) (EventReturnType ep s (State s)))
applySTSOptsEither @(EraRule "TICK" era) ApplySTSOpts ep
opts
      forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), NewEpochState era
state, SlotNo
hdr)
    where
      err :: Show a => a -> b
      err :: forall a b. Show a => a -> b
err a
msg = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Panic! applyTick failed: " forall a. Semigroup a => a -> a -> a
<> 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 (EraCrypto era)) era ->
    m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
  default applyBlockOpts ::
    forall ep m.
    (EventReturnTypeRep ep, MonadError (BlockTransitionError era) m, EraGov era) =>
    ApplySTSOpts ep ->
    Globals ->
    NewEpochState era ->
    Block (BHeaderView (EraCrypto era)) era ->
    m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
  applyBlockOpts ApplySTSOpts ep
opts Globals
globals NewEpochState era
state Block (BHeaderView (EraCrypto era)) era
blk =
    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 b d) (Either c d)
left forall era.
NonEmpty (PredicateFailure (EraRule "BBODY" era))
-> BlockTransitionError era
BlockTransitionError
      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 (ep :: EventPolicy) sts a b.
EventReturnTypeRep ep =>
(a -> b) -> EventReturnType ep sts a -> EventReturnType ep sts b
mapEventReturn @ep @(EraRule "BBODY" era) forall a b. (a -> b) -> a -> b
$
            forall era.
(LedgerState era ~ State (EraRule "LEDGERS" era), EraGov era) =>
NewEpochState era -> ShelleyBbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
state
        )
      forall a b. (a -> b) -> a -> b
$ Either
  (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
  (EventReturnType ep (EraRule "BBODY" era) (ShelleyBbodyState era))
res
    where
      res :: Either
  (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
  (EventReturnType ep (EraRule "BBODY" era) (ShelleyBbodyState 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) (ep :: EventPolicy).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
ApplySTSOpts ep
-> RuleContext rtype s
-> m (Either
        (NonEmpty (PredicateFailure s)) (EventReturnType ep s (State s)))
applySTSOptsEither @(EraRule "BBODY" era)
            ApplySTSOpts ep
opts
          forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era. EraGov era => NewEpochState era -> BbodyEnv era
mkBbodyEnv NewEpochState era
state, ShelleyBbodyState era
bbs, Block (BHeaderView (EraCrypto era)) era
blk)
      bbs :: ShelleyBbodyState era
bbs =
        forall era.
State (EraRule "LEDGERS" era)
-> BlocksMade (EraCrypto era) -> ShelleyBbodyState era
STS.BbodyState
          (forall era. EpochState era -> LedgerState era
LedgerState.esLState forall a b. (a -> b) -> a -> b
$ forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
state)
          (forall era. NewEpochState era -> BlocksMade (EraCrypto 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 (EraCrypto era)) era ->
    NewEpochState era
  default reapplyBlock ::
    EraGov era =>
    Globals ->
    NewEpochState era ->
    Block (BHeaderView (EraCrypto era)) era ->
    NewEpochState era
  reapplyBlock Globals
globals NewEpochState era
state Block (BHeaderView (EraCrypto era)) era
blk =
    forall era.
(LedgerState era ~ State (EraRule "LEDGERS" era), EraGov era) =>
NewEpochState era -> ShelleyBbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
state ShelleyBbodyState era
res
    where
      res :: ShelleyBbodyState 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 (State s)
reapplySTS @(EraRule "BBODY" era) forall a b. (a -> b) -> a -> b
$
          forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era. EraGov era => NewEpochState era -> BbodyEnv era
mkBbodyEnv NewEpochState era
state, ShelleyBbodyState era
bbs, Block (BHeaderView (EraCrypto era)) era
blk)
      bbs :: ShelleyBbodyState era
bbs =
        forall era.
State (EraRule "LEDGERS" era)
-> BlocksMade (EraCrypto era) -> ShelleyBbodyState era
STS.BbodyState
          (forall era. EpochState era -> LedgerState era
LedgerState.esLState forall a b. (a -> b) -> a -> b
$ forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
state)
          (forall era. NewEpochState era -> BlocksMade (EraCrypto era)
LedgerState.nesBcur NewEpochState era
state)

applyTick ::
  ApplyBlock era =>
  Globals ->
  NewEpochState era ->
  SlotNo ->
  NewEpochState era
applyTick :: forall era.
ApplyBlock era =>
Globals -> NewEpochState era -> SlotNo -> NewEpochState era
applyTick =
  forall era (ep :: EventPolicy).
ApplyBlock era =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> SlotNo
-> EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
applyTickOpts forall a b. (a -> b) -> a -> b
$
    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 (EraCrypto era)) era ->
  m (NewEpochState era)
applyBlock :: forall era (m :: * -> *).
(ApplyBlock era, MonadError (BlockTransitionError era) m) =>
Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> m (NewEpochState era)
applyBlock =
  forall era (ep :: EventPolicy) (m :: * -> *).
(ApplyBlock era, EventReturnTypeRep ep,
 MonadError (BlockTransitionError era) m) =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
applyBlockOpts forall a b. (a -> b) -> a -> b
$
    ApplySTSOpts
      { asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
globalAssertionPolicy
      , asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
ValidateAll
      , asoEvents :: SingEP 'EventPolicyDiscard
asoEvents = SingEP 'EventPolicyDiscard
EPDiscard
      }

instance
  ( Crypto c
  , DSignable c (Hash c EraIndependentTxBody)
  ) =>
  ApplyBlock (ShelleyEra c)

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

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

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

mkBbodyEnv ::
  EraGov era =>
  NewEpochState era ->
  STS.BbodyEnv era
mkBbodyEnv :: forall era. EraGov era => NewEpochState era -> BbodyEnv era
mkBbodyEnv
  LedgerState.NewEpochState
    { EpochState era
nesEs :: EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
LedgerState.nesEs
    } =
    STS.BbodyEnv
      { bbodyPp :: PParams era
STS.bbodyPp = EpochState era
nesEs forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
      , bbodyAccount :: AccountState
STS.bbodyAccount = forall era. EpochState era -> AccountState
LedgerState.esAccountState EpochState era
nesEs
      }

updateNewEpochState ::
  (LedgerState era ~ State (EraRule "LEDGERS" era), EraGov era) =>
  NewEpochState era ->
  STS.ShelleyBbodyState era ->
  NewEpochState era
updateNewEpochState :: forall era.
(LedgerState era ~ State (EraRule "LEDGERS" era), EraGov era) =>
NewEpochState era -> ShelleyBbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
ss (STS.BbodyState State (EraRule "LEDGERS" era)
ls BlocksMade (EraCrypto era)
bcur) =
  forall era.
EraGov era =>
NewEpochState era
-> BlocksMade (EraCrypto era)
-> LedgerState era
-> NewEpochState era
LedgerState.updateNES NewEpochState era
ss BlocksMade (EraCrypto era)
bcur State (EraRule "LEDGERS" era)
ls

newtype TickTransitionError era
  = TickTransitionError (NonEmpty (STS.PredicateFailure (EraRule "TICK" era)))
  deriving (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 (EraRule "TICK" era)) =>
  NoThunks (TickTransitionError era)

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

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

newtype BlockTransitionError era
  = BlockTransitionError (NonEmpty (STS.PredicateFailure (EraRule "BBODY" era)))
  deriving (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 (EraRule "BBODY" era)) =>
  Eq (BlockTransitionError era)

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

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