{-# 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 #-}
{-# LANGUAGE UndecidableSuperClasses #-}

-- | Interface to the block validation and chain extension logic in the Shelley
-- API.
module Cardano.Ledger.Shelley.API.Validation (
  ApplyBlock (..),
  applyBlockEither,
  applyBlockEitherNoEvents,
  applyBlockNoValidaton,
  applyTickNoEvents,
  TickTransitionError (..),
  BlockTransitionError (..),
  chainChecks,
)
where

import Cardano.Ledger.BHeaderView (BHeaderView)
import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase, Version)
import Cardano.Ledger.Block (Block)
import qualified Cardano.Ledger.Chain as STS
import Cardano.Ledger.Core
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.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 (EraGov era, EraSegWits era) => ApplyBlock era where
  -- | Run the `BBODY` rule with `globalAssertionPolicy`. This function always succeeds, but
  -- whenever validation is turned on it is necessary to check for presence of predicate failures
  -- before a call can be marked successful. Therefore it is recommended to call `applyBlockEither`
  -- instead.
  applyBlock ::
    SingEP ep ->
    ValidationPolicy ->
    Globals ->
    NewEpochState era ->
    Block BHeaderView era ->
    (NewEpochState era, [PredicateFailure (EraRule "BBODY" era)], [Event (EraRule "BBODY" era)])
  default applyBlock ::
    ( 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 era
    , State (EraRule "LEDGERS" era) ~ LedgerState era
    ) =>
    SingEP ep ->
    ValidationPolicy ->
    Globals ->
    NewEpochState era ->
    Block BHeaderView era ->
    (NewEpochState era, [PredicateFailure (EraRule "BBODY" era)], [Event (EraRule "BBODY" era)])
  applyBlock SingEP ep
eventsPolicy ValidationPolicy
validationPolicy Globals
globals NewEpochState era
newEpochState Block BHeaderView era
block =
    (forall era.
(LedgerState era ~ State (EraRule "LEDGERS" era), EraGov era) =>
NewEpochState era -> ShelleyBbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
newEpochState State (EraRule "BBODY" era)
stsResultState, [PredicateFailure (EraRule "BBODY" era)]
stsResultFailures, [Event (EraRule "BBODY" era)]
stsResultEvents)
    where
      opts :: ApplySTSOpts ep
opts =
        ApplySTSOpts
          { asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
globalAssertionPolicy
          , asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
validationPolicy
          , asoEvents :: SingEP ep
asoEvents = SingEP ep
eventsPolicy
          }
      STSResult {State (EraRule "BBODY" era)
stsResultState :: forall s. STSResult s -> State s
stsResultState :: State (EraRule "BBODY" era)
stsResultState, [PredicateFailure (EraRule "BBODY" era)]
stsResultFailures :: forall s. STSResult s -> [PredicateFailure s]
stsResultFailures :: [PredicateFailure (EraRule "BBODY" era)]
stsResultFailures, [Event (EraRule "BBODY" era)]
stsResultEvents :: forall s. STSResult s -> [Event s]
stsResultEvents :: [Event (EraRule "BBODY" era)]
stsResultEvents} =
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals forall a b. (a -> b) -> a -> b
$
          forall s (m :: * -> *) (rtype :: RuleType) (ep :: EventPolicy).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
ApplySTSOpts ep -> RuleContext rtype s -> m (STSResult s)
applySTSOptsResult @(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
newEpochState, ShelleyBbodyState era
bBodyState, Block BHeaderView era
block)
      bBodyState :: ShelleyBbodyState era
bBodyState =
        forall era.
State (EraRule "LEDGERS" era)
-> BlocksMade -> 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
newEpochState)
          (forall era. NewEpochState era -> BlocksMade
LedgerState.nesBcur NewEpochState era
newEpochState)

  -- | Run the `TICK` rule with `globalAssertionPolicy` and without any validation, since it can't
  -- fail anyways.
  applyTick ::
    SingEP ep ->
    Globals ->
    NewEpochState era ->
    SlotNo ->
    (NewEpochState era, [Event (EraRule "TICK" era)])
  default applyTick ::
    ( STS (EraRule "TICK" era)
    , BaseM (EraRule "TICK" era) ~ ShelleyBase
    , Environment (EraRule "TICK" era) ~ ()
    , State (EraRule "TICK" era) ~ NewEpochState era
    , Signal (EraRule "TICK" era) ~ SlotNo
    ) =>
    SingEP ep ->
    Globals ->
    NewEpochState era ->
    SlotNo ->
    (NewEpochState era, [Event (EraRule "TICK" era)])
  applyTick SingEP ep
eventsPolicy Globals
globals NewEpochState era
newEpochState SlotNo
slotNo = (State (EraRule "TICK" era)
stsResultState, [Event (EraRule "TICK" era)]
stsResultEvents)
    where
      opts :: ApplySTSOpts ep
opts =
        ApplySTSOpts
          { asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
globalAssertionPolicy
          , asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
ValidateNone
          , asoEvents :: SingEP ep
asoEvents = SingEP ep
eventsPolicy
          }
      STSResult {State (EraRule "TICK" era)
stsResultState :: State (EraRule "TICK" era)
stsResultState :: forall s. STSResult s -> State s
stsResultState, [Event (EraRule "TICK" era)]
stsResultEvents :: [Event (EraRule "TICK" era)]
stsResultEvents :: forall s. STSResult s -> [Event s]
stsResultEvents} =
        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 (STSResult s)
applySTSOptsResult @(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
newEpochState, SlotNo
slotNo)

-- | Same as `applyBlock`, except it produces a Left when there are failures present and `Right`
-- with result otherwise.
applyBlockEither ::
  ApplyBlock era =>
  SingEP ep ->
  ValidationPolicy ->
  Globals ->
  NewEpochState era ->
  Block BHeaderView era ->
  Either (BlockTransitionError era) (NewEpochState era, [Event (EraRule "BBODY" era)])
applyBlockEither :: forall era (ep :: EventPolicy).
ApplyBlock era =>
SingEP ep
-> ValidationPolicy
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [Event (EraRule "BBODY" era)])
applyBlockEither SingEP ep
eventsPolicy ValidationPolicy
validationPolicy Globals
globals NewEpochState era
newEpochState Block BHeaderView era
block =
  case [PredicateFailure (EraRule "BBODY" era)]
failure of
    [] -> forall a b. b -> Either a b
Right (NewEpochState era
newEpochStateResult, [Event (EraRule "BBODY" era)]
events)
    PredicateFailure (EraRule "BBODY" era)
f : [PredicateFailure (EraRule "BBODY" era)]
fs -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall era.
NonEmpty (PredicateFailure (EraRule "BBODY" era))
-> BlockTransitionError era
BlockTransitionError forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "BBODY" era)
f forall a. a -> [a] -> NonEmpty a
:| [PredicateFailure (EraRule "BBODY" era)]
fs
  where
    (NewEpochState era
newEpochStateResult, [PredicateFailure (EraRule "BBODY" era)]
failure, [Event (EraRule "BBODY" era)]
events) =
      forall era (ep :: EventPolicy).
ApplyBlock era =>
SingEP ep
-> ValidationPolicy
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> (NewEpochState era, [PredicateFailure (EraRule "BBODY" era)],
    [Event (EraRule "BBODY" era)])
applyBlock SingEP ep
eventsPolicy ValidationPolicy
validationPolicy Globals
globals NewEpochState era
newEpochState Block BHeaderView era
block

applyBlockEitherNoEvents ::
  ApplyBlock era =>
  ValidationPolicy ->
  Globals ->
  NewEpochState era ->
  Block BHeaderView era ->
  Either (BlockTransitionError era) (NewEpochState era)
applyBlockEitherNoEvents :: forall era.
ApplyBlock era =>
ValidationPolicy
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either (BlockTransitionError era) (NewEpochState era)
applyBlockEitherNoEvents ValidationPolicy
validationPolicy Globals
globals NewEpochState era
newEpochState Block BHeaderView era
block =
  forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (ep :: EventPolicy).
ApplyBlock era =>
SingEP ep
-> ValidationPolicy
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [Event (EraRule "BBODY" era)])
applyBlockEither SingEP 'EventPolicyDiscard
EPDiscard ValidationPolicy
validationPolicy Globals
globals NewEpochState era
newEpochState Block BHeaderView era
block

-- | 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.
applyBlockNoValidaton ::
  ApplyBlock era =>
  Globals ->
  NewEpochState era ->
  Block BHeaderView era ->
  NewEpochState era
applyBlockNoValidaton :: forall era.
ApplyBlock era =>
Globals
-> NewEpochState era -> Block BHeaderView era -> NewEpochState era
applyBlockNoValidaton Globals
globals NewEpochState era
newEpochState Block BHeaderView era
block = NewEpochState era
newEpochStateResult
  where
    (NewEpochState era
newEpochStateResult, [PredicateFailure (EraRule "BBODY" era)]
_failure, [Event (EraRule "BBODY" era)]
_events) =
      forall era (ep :: EventPolicy).
ApplyBlock era =>
SingEP ep
-> ValidationPolicy
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> (NewEpochState era, [PredicateFailure (EraRule "BBODY" era)],
    [Event (EraRule "BBODY" era)])
applyBlock SingEP 'EventPolicyDiscard
EPDiscard ValidationPolicy
ValidateNone Globals
globals NewEpochState era
newEpochState Block BHeaderView era
block

-- | Same as `applyTick`, but do not retain any ledger events
applyTickNoEvents ::
  ApplyBlock era =>
  Globals ->
  NewEpochState era ->
  SlotNo ->
  NewEpochState era
applyTickNoEvents :: forall era.
ApplyBlock era =>
Globals -> NewEpochState era -> SlotNo -> NewEpochState era
applyTickNoEvents Globals
globals NewEpochState era
newEpochState SlotNo
slotNo =
  forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall era (ep :: EventPolicy).
ApplyBlock era =>
SingEP ep
-> Globals
-> NewEpochState era
-> SlotNo
-> (NewEpochState era, [Event (EraRule "TICK" era)])
applyTick SingEP 'EventPolicyDiscard
EPDiscard Globals
globals NewEpochState era
newEpochState SlotNo
slotNo

instance ApplyBlock ShelleyEra

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

chainChecks ::
  forall m.
  MonadError STS.ChainPredicateFailure m =>
  -- | Max major protocol version
  Version ->
  STS.ChainChecksPParams ->
  BHeaderView ->
  m ()
chainChecks :: forall (m :: * -> *).
MonadError ChainPredicateFailure m =>
Version -> ChainChecksPParams -> BHeaderView -> m ()
chainChecks = forall (m :: * -> *).
MonadError ChainPredicateFailure m =>
Version -> ChainChecksPParams -> BHeaderView -> 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
bcur) =
  forall era.
EraGov era =>
NewEpochState era
-> BlocksMade -> LedgerState era -> NewEpochState era
LedgerState.updateNES NewEpochState era
ss BlocksMade
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)