{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Eras
  ( -- * Eras based on the Shelley ledger
    ShelleyEra
  , AllegraEra
  , MaryEra
  , AlonzoEra
  , BabbageEra
  , ConwayEra
  , DijkstraEra

    -- * Shelley-based era
  , ConwayEraGovDict (..)
  , ShelleyBasedEra (..)

    -- * Convenience functions
  , isBeforeConway

    -- * Re-exports
  , StandardCrypto
  ) where

import Cardano.Binary (FromCBOR, ToCBOR)
import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Allegra.Translation ()
import Cardano.Ledger.Alonzo (AlonzoEra, ApplyTxError (AlonzoApplyTxError))
import Cardano.Ledger.Alonzo.Core as Core
import qualified Cardano.Ledger.Alonzo.Rules as Alonzo
import qualified Cardano.Ledger.Api as L
import Cardano.Ledger.Babbage (ApplyTxError (BabbageApplyTxError), BabbageEra)
import qualified Cardano.Ledger.Babbage.Rules as Babbage
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
import Cardano.Ledger.Conway (ApplyTxError (ConwayApplyTxError), ConwayEra)
import qualified Cardano.Ledger.Conway.Governance as CG
import qualified Cardano.Ledger.Conway.Rules as Conway
import qualified Cardano.Ledger.Conway.Rules as SL
  ( ConwayLedgerPredFailure (..)
  )
import qualified Cardano.Ledger.Conway.State as CG
import Cardano.Ledger.Dijkstra (ApplyTxError (DijkstraApplyTxError), DijkstraEra)
import Cardano.Ledger.Dijkstra.BlockBody (leiosCertBlockBodyL)
import qualified Cardano.Ledger.Dijkstra.Rules as Dijkstra
import qualified Cardano.Ledger.Dijkstra.Rules as SL
  ( DijkstraLedgerPredFailure (..)
  )
import Cardano.Ledger.Mary (MaryEra)
import Cardano.Ledger.Shelley (ShelleyEra)
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.LedgerState as SL
import qualified Cardano.Ledger.Shelley.Rules as SL
import qualified Cardano.Ledger.Shelley.Transition as SL
import Control.Monad.Except
import Control.State.Transition (PredicateFailure)
import Data.Data (Proxy (Proxy))
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import Lens.Micro
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Ledger.SupportsMempool
  ( WhetherToIntervene (..)
  )
import Ouroboros.Consensus.Peras.Params
  ( PerasEnabled
  , PerasRoundLength
  , dijkstraPerasRoundLength
  , pattern NoPerasEnabled
  )
import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto)

{-------------------------------------------------------------------------------
  Era polymorphism
-------------------------------------------------------------------------------}

-- | Consensus often needs some more functionality than the ledger currently
-- provides.
--
-- Either the functionality shouldn't or can't live in the ledger, in which case
-- it can be part and remain part of 'ShelleyBasedEra'. Or, the functionality
-- /should/ live in the ledger, but hasn't yet been added to the ledger, or it
-- hasn't yet been propagated to this repository, in which case it can be added
-- to this class until that is the case.
--
-- If this class becomes redundant, We can move it to ledger and re-export it
-- from here.
--
-- TODO Currently we include some constraints on the update state which are
-- needed to determine the hard fork point. In the future this should be
-- replaced with an appropriate API - see
-- https://github.com/IntersectMBO/ouroboros-network/issues/2890
class
  ( Core.EraBlockBody era
  , Core.EraGov era
  , SL.ApplyTx era
  , SL.ApplyTick era
  , SL.EraTransition era
  , SL.EraForecast era
  , NoThunks (SL.StashedAVVMAddresses era)
  , EncCBOR (SL.StashedAVVMAddresses era)
  , DecCBOR (SL.StashedAVVMAddresses era)
  , Show (SL.StashedAVVMAddresses era)
  , Eq (SL.StashedAVVMAddresses era)
  , DecCBOR (PredicateFailure (EraRule "LEDGER" era))
  , EncCBOR (PredicateFailure (EraRule "LEDGER" era))
  , DecCBOR (PredicateFailure (EraRule "UTXOW" era))
  , EncCBOR (PredicateFailure (EraRule "UTXOW" era))
  , Eq (PredicateFailure (EraRule "BBODY" era))
  , Show (PredicateFailure (EraRule "BBODY" era))
  , NoThunks (Core.TranslationContext era)
  , ToCBOR (Core.TranslationContext era)
  , FromCBOR (Core.TranslationContext era)
  ) =>
  ShelleyBasedEra era
  where
  applyShelleyBasedTx ::
    SL.Globals ->
    SL.LedgerEnv era ->
    SL.LedgerState era ->
    WhetherToIntervene ->
    Core.Tx TopTx era ->
    Except
      (SL.ApplyTxError era)
      ( SL.LedgerState era
      , SL.ValidatedTx era
      )

  -- | Whether the era has an instance of 'CG.ConwayEraGov'
  getConwayEraGovDict :: proxy era -> Maybe (ConwayEraGovDict era)

  mkEraMkMempoolApplyTxError ::
    proxy era -> Maybe (Text -> SL.ApplyTxError era)

  -- | Retrieve the optionally enabled Peras round length of this epoch.
  --
  -- Defaults to 'NoPerasEnabled' for eras that don't explictily support Peras.
  getShelleyEraPerasRoundLength :: proxy era -> PerasEnabled PerasRoundLength
  getShelleyEraPerasRoundLength proxy era
_ = PerasEnabled PerasRoundLength
forall a. PerasEnabled a
NoPerasEnabled

  -- | Whether this block body carries a Leios certificate.
  --
  -- Eras that don't support Leios define this as
  -- 'defaultBlockBodyContainsLeiosCert'.
  blockBodyContainsLeiosCert :: Core.BlockBody era -> Bool

data ConwayEraGovDict era where
  ConwayEraGovDict :: (CG.ConwayEraGov era, CG.ConwayEraCertState era) => ConwayEraGovDict era

isBeforeConway :: forall era. L.Era era => Proxy era -> Bool
isBeforeConway :: forall era. Era era => Proxy era -> Bool
isBeforeConway Proxy era
_ =
  forall era. Era era => Version
L.eraProtVerLow @era Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall era. Era era => Version
L.eraProtVerLow @L.ConwayEra

-- | The default implementation of 'applyShelleyBasedTx', a thin wrapper around
-- 'SL.applyTx'
defaultApplyShelleyBasedTx ::
  ShelleyBasedEra era =>
  SL.Globals ->
  SL.LedgerEnv era ->
  SL.LedgerState era ->
  WhetherToIntervene ->
  Core.Tx TopTx era ->
  Except
    (SL.ApplyTxError era)
    ( SL.LedgerState era
    , SL.ValidatedTx era
    )
defaultApplyShelleyBasedTx :: forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
defaultApplyShelleyBasedTx Globals
globals LedgerEnv era
ledgerEnv LedgerState era
mempoolState WhetherToIntervene
_wti Tx TopTx era
tx =
  Either (ApplyTxError era) (LedgerState era, ValidatedTx era)
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either (ApplyTxError era) (LedgerState era, ValidatedTx era)
 -> ExceptT
      (ApplyTxError era) Identity (LedgerState era, ValidatedTx era))
-> Either (ApplyTxError era) (LedgerState era, ValidatedTx era)
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
forall a b. (a -> b) -> a -> b
$
    Globals
-> LedgerEnv era
-> LedgerState era
-> Tx TopTx era
-> Either (ApplyTxError era) (LedgerState era, ValidatedTx era)
forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
SL.applyTxWithFullValidation
      Globals
globals
      LedgerEnv era
ledgerEnv
      LedgerState era
mempoolState
      Tx TopTx era
tx

defaultGetConwayEraGovDict :: proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict :: forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict proxy era
_ = Maybe (ConwayEraGovDict era)
forall a. Maybe a
Nothing

defaultBlockBodyContainsLeiosCert :: Core.BlockBody era -> Bool
defaultBlockBodyContainsLeiosCert :: forall era. BlockBody era -> Bool
defaultBlockBodyContainsLeiosCert BlockBody era
_ = Bool
False

instance ShelleyBasedEra ShelleyEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv ShelleyEra
-> LedgerState ShelleyEra
-> WhetherToIntervene
-> Tx TopTx ShelleyEra
-> Except
     (ApplyTxError ShelleyEra)
     (LedgerState ShelleyEra, ValidatedTx ShelleyEra)
applyShelleyBasedTx = Globals
-> LedgerEnv ShelleyEra
-> LedgerState ShelleyEra
-> WhetherToIntervene
-> Tx TopTx ShelleyEra
-> Except
     (ApplyTxError ShelleyEra)
     (LedgerState ShelleyEra, ValidatedTx ShelleyEra)
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
defaultApplyShelleyBasedTx

  getConwayEraGovDict :: forall (proxy :: * -> *).
proxy ShelleyEra -> Maybe (ConwayEraGovDict ShelleyEra)
getConwayEraGovDict = proxy ShelleyEra -> Maybe (ConwayEraGovDict ShelleyEra)
forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict

  mkEraMkMempoolApplyTxError :: forall (proxy :: * -> *).
proxy ShelleyEra -> Maybe (Text -> ApplyTxError ShelleyEra)
mkEraMkMempoolApplyTxError proxy ShelleyEra
_prx = Maybe (Text -> ApplyTxError ShelleyEra)
forall a. Maybe a
Nothing

  blockBodyContainsLeiosCert :: BlockBody ShelleyEra -> Bool
blockBodyContainsLeiosCert = BlockBody ShelleyEra -> Bool
forall era. BlockBody era -> Bool
defaultBlockBodyContainsLeiosCert

instance ShelleyBasedEra AllegraEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv AllegraEra
-> LedgerState AllegraEra
-> WhetherToIntervene
-> Tx TopTx AllegraEra
-> Except
     (ApplyTxError AllegraEra)
     (LedgerState AllegraEra, ValidatedTx AllegraEra)
applyShelleyBasedTx = Globals
-> LedgerEnv AllegraEra
-> LedgerState AllegraEra
-> WhetherToIntervene
-> Tx TopTx AllegraEra
-> Except
     (ApplyTxError AllegraEra)
     (LedgerState AllegraEra, ValidatedTx AllegraEra)
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
defaultApplyShelleyBasedTx

  getConwayEraGovDict :: forall (proxy :: * -> *).
proxy AllegraEra -> Maybe (ConwayEraGovDict AllegraEra)
getConwayEraGovDict = proxy AllegraEra -> Maybe (ConwayEraGovDict AllegraEra)
forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict

  mkEraMkMempoolApplyTxError :: forall (proxy :: * -> *).
proxy AllegraEra -> Maybe (Text -> ApplyTxError AllegraEra)
mkEraMkMempoolApplyTxError proxy AllegraEra
_prx = Maybe (Text -> ApplyTxError AllegraEra)
forall a. Maybe a
Nothing

  blockBodyContainsLeiosCert :: BlockBody AllegraEra -> Bool
blockBodyContainsLeiosCert = BlockBody AllegraEra -> Bool
forall era. BlockBody era -> Bool
defaultBlockBodyContainsLeiosCert

instance ShelleyBasedEra MaryEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv MaryEra
-> LedgerState MaryEra
-> WhetherToIntervene
-> Tx TopTx MaryEra
-> Except
     (ApplyTxError MaryEra) (LedgerState MaryEra, ValidatedTx MaryEra)
applyShelleyBasedTx = Globals
-> LedgerEnv MaryEra
-> LedgerState MaryEra
-> WhetherToIntervene
-> Tx TopTx MaryEra
-> Except
     (ApplyTxError MaryEra) (LedgerState MaryEra, ValidatedTx MaryEra)
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
defaultApplyShelleyBasedTx

  getConwayEraGovDict :: forall (proxy :: * -> *).
proxy MaryEra -> Maybe (ConwayEraGovDict MaryEra)
getConwayEraGovDict = proxy MaryEra -> Maybe (ConwayEraGovDict MaryEra)
forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict

  mkEraMkMempoolApplyTxError :: forall (proxy :: * -> *).
proxy MaryEra -> Maybe (Text -> ApplyTxError MaryEra)
mkEraMkMempoolApplyTxError proxy MaryEra
_prx = Maybe (Text -> ApplyTxError MaryEra)
forall a. Maybe a
Nothing

  blockBodyContainsLeiosCert :: BlockBody MaryEra -> Bool
blockBodyContainsLeiosCert = BlockBody MaryEra -> Bool
forall era. BlockBody era -> Bool
defaultBlockBodyContainsLeiosCert

instance ShelleyBasedEra AlonzoEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv AlonzoEra
-> LedgerState AlonzoEra
-> WhetherToIntervene
-> Tx TopTx AlonzoEra
-> Except
     (ApplyTxError AlonzoEra)
     (LedgerState AlonzoEra, ValidatedTx AlonzoEra)
applyShelleyBasedTx = Globals
-> LedgerEnv AlonzoEra
-> LedgerState AlonzoEra
-> WhetherToIntervene
-> Tx TopTx AlonzoEra
-> Except
     (ApplyTxError AlonzoEra)
     (LedgerState AlonzoEra, ValidatedTx AlonzoEra)
forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
applyAlonzoBasedTx

  getConwayEraGovDict :: forall (proxy :: * -> *).
proxy AlonzoEra -> Maybe (ConwayEraGovDict AlonzoEra)
getConwayEraGovDict = proxy AlonzoEra -> Maybe (ConwayEraGovDict AlonzoEra)
forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict

  mkEraMkMempoolApplyTxError :: forall (proxy :: * -> *).
proxy AlonzoEra -> Maybe (Text -> ApplyTxError AlonzoEra)
mkEraMkMempoolApplyTxError proxy AlonzoEra
_prx = Maybe (Text -> ApplyTxError AlonzoEra)
forall a. Maybe a
Nothing

  blockBodyContainsLeiosCert :: BlockBody AlonzoEra -> Bool
blockBodyContainsLeiosCert = BlockBody AlonzoEra -> Bool
forall era. BlockBody era -> Bool
defaultBlockBodyContainsLeiosCert

instance ShelleyBasedEra BabbageEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv BabbageEra
-> LedgerState BabbageEra
-> WhetherToIntervene
-> Tx TopTx BabbageEra
-> Except
     (ApplyTxError BabbageEra)
     (LedgerState BabbageEra, ValidatedTx BabbageEra)
applyShelleyBasedTx = Globals
-> LedgerEnv BabbageEra
-> LedgerState BabbageEra
-> WhetherToIntervene
-> Tx TopTx BabbageEra
-> Except
     (ApplyTxError BabbageEra)
     (LedgerState BabbageEra, ValidatedTx BabbageEra)
forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
applyAlonzoBasedTx

  getConwayEraGovDict :: forall (proxy :: * -> *).
proxy BabbageEra -> Maybe (ConwayEraGovDict BabbageEra)
getConwayEraGovDict = proxy BabbageEra -> Maybe (ConwayEraGovDict BabbageEra)
forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict

  mkEraMkMempoolApplyTxError :: forall (proxy :: * -> *).
proxy BabbageEra -> Maybe (Text -> ApplyTxError BabbageEra)
mkEraMkMempoolApplyTxError proxy BabbageEra
_prx = Maybe (Text -> ApplyTxError BabbageEra)
forall a. Maybe a
Nothing

  blockBodyContainsLeiosCert :: BlockBody BabbageEra -> Bool
blockBodyContainsLeiosCert = BlockBody BabbageEra -> Bool
forall era. BlockBody era -> Bool
defaultBlockBodyContainsLeiosCert

instance ShelleyBasedEra ConwayEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv ConwayEra
-> LedgerState ConwayEra
-> WhetherToIntervene
-> Tx TopTx ConwayEra
-> Except
     (ApplyTxError ConwayEra)
     (LedgerState ConwayEra, ValidatedTx ConwayEra)
applyShelleyBasedTx = Globals
-> LedgerEnv ConwayEra
-> LedgerState ConwayEra
-> WhetherToIntervene
-> Tx TopTx ConwayEra
-> Except
     (ApplyTxError ConwayEra)
     (LedgerState ConwayEra, ValidatedTx ConwayEra)
forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
applyAlonzoBasedTx

  getConwayEraGovDict :: forall (proxy :: * -> *).
proxy ConwayEra -> Maybe (ConwayEraGovDict ConwayEra)
getConwayEraGovDict proxy ConwayEra
_ = ConwayEraGovDict ConwayEra -> Maybe (ConwayEraGovDict ConwayEra)
forall a. a -> Maybe a
Just ConwayEraGovDict ConwayEra
forall era.
(ConwayEraGov era, ConwayEraCertState era) =>
ConwayEraGovDict era
ConwayEraGovDict

  mkEraMkMempoolApplyTxError :: forall (proxy :: * -> *).
proxy ConwayEra -> Maybe (Text -> ApplyTxError ConwayEra)
mkEraMkMempoolApplyTxError proxy ConwayEra
_prx =
    (Text -> ApplyTxError ConwayEra)
-> Maybe (Text -> ApplyTxError ConwayEra)
forall a. a -> Maybe a
Just ((Text -> ApplyTxError ConwayEra)
 -> Maybe (Text -> ApplyTxError ConwayEra))
-> (Text -> ApplyTxError ConwayEra)
-> Maybe (Text -> ApplyTxError ConwayEra)
forall a b. (a -> b) -> a -> b
$ \Text
txt -> NonEmpty (ConwayLedgerPredFailure ConwayEra)
-> ApplyTxError ConwayEra
ConwayApplyTxError (ConwayLedgerPredFailure ConwayEra
-> NonEmpty (ConwayLedgerPredFailure ConwayEra)
forall a. a -> NonEmpty a
NE.singleton (Text -> ConwayLedgerPredFailure ConwayEra
forall era. Text -> ConwayLedgerPredFailure era
Conway.ConwayMempoolFailure Text
txt))

  blockBodyContainsLeiosCert :: BlockBody ConwayEra -> Bool
blockBodyContainsLeiosCert = BlockBody ConwayEra -> Bool
forall era. BlockBody era -> Bool
defaultBlockBodyContainsLeiosCert

instance ShelleyBasedEra DijkstraEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv DijkstraEra
-> LedgerState DijkstraEra
-> WhetherToIntervene
-> Tx TopTx DijkstraEra
-> Except
     (ApplyTxError DijkstraEra)
     (LedgerState DijkstraEra, ValidatedTx DijkstraEra)
applyShelleyBasedTx = Globals
-> LedgerEnv DijkstraEra
-> LedgerState DijkstraEra
-> WhetherToIntervene
-> Tx TopTx DijkstraEra
-> Except
     (ApplyTxError DijkstraEra)
     (LedgerState DijkstraEra, ValidatedTx DijkstraEra)
forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
applyAlonzoBasedTx

  getConwayEraGovDict :: forall (proxy :: * -> *).
proxy DijkstraEra -> Maybe (ConwayEraGovDict DijkstraEra)
getConwayEraGovDict proxy DijkstraEra
_ = ConwayEraGovDict DijkstraEra
-> Maybe (ConwayEraGovDict DijkstraEra)
forall a. a -> Maybe a
Just ConwayEraGovDict DijkstraEra
forall era.
(ConwayEraGov era, ConwayEraCertState era) =>
ConwayEraGovDict era
ConwayEraGovDict

  -- TODO we'll need to change the mini protocol (backwards-incompatibly?) to
  -- use MempoolFailure type family instead of just PredicateFailure type
  -- family
  mkEraMkMempoolApplyTxError :: forall (proxy :: * -> *).
proxy DijkstraEra -> Maybe (Text -> ApplyTxError DijkstraEra)
mkEraMkMempoolApplyTxError proxy DijkstraEra
_prx = Maybe (Text -> ApplyTxError DijkstraEra)
forall a. Maybe a
Nothing

  getShelleyEraPerasRoundLength :: forall (proxy :: * -> *).
proxy DijkstraEra -> PerasEnabled PerasRoundLength
getShelleyEraPerasRoundLength proxy DijkstraEra
_ = PerasEnabled PerasRoundLength
dijkstraPerasRoundLength

  blockBodyContainsLeiosCert :: BlockBody DijkstraEra -> Bool
blockBodyContainsLeiosCert BlockBody DijkstraEra
bb = StrictMaybe LeiosCert -> Bool
forall a. StrictMaybe a -> Bool
isSJust (BlockBody DijkstraEra
DijkstraBlockBody DijkstraEra
bb DijkstraBlockBody DijkstraEra
-> Getting
     (StrictMaybe LeiosCert)
     (DijkstraBlockBody DijkstraEra)
     (StrictMaybe LeiosCert)
-> StrictMaybe LeiosCert
forall s a. s -> Getting a s a -> a
^. (StrictMaybe LeiosCert
 -> Const (StrictMaybe LeiosCert) (StrictMaybe LeiosCert))
-> BlockBody DijkstraEra
-> Const (StrictMaybe LeiosCert) (BlockBody DijkstraEra)
Getting
  (StrictMaybe LeiosCert)
  (DijkstraBlockBody DijkstraEra)
  (StrictMaybe LeiosCert)
forall era.
DijkstraEraBlockBody era =>
Lens' (BlockBody era) (StrictMaybe LeiosCert)
Lens' (BlockBody DijkstraEra) (StrictMaybe LeiosCert)
leiosCertBlockBodyL)

applyAlonzoBasedTx ::
  forall era.
  ( AlonzoEraTx era
  , ShelleyBasedEra era
  , SupportsTwoPhaseValidation era
  ) =>
  Globals ->
  SL.LedgerEnv era ->
  SL.LedgerState era ->
  WhetherToIntervene ->
  Core.Tx TopTx era ->
  Except
    (SL.ApplyTxError era)
    ( SL.LedgerState era
    , SL.ValidatedTx era
    )
applyAlonzoBasedTx :: forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
applyAlonzoBasedTx Globals
globals LedgerEnv era
ledgerEnv LedgerState era
mempoolState WhetherToIntervene
wti Tx TopTx era
tx = do
  (mempoolState', vtx) <-
    (ExceptT
  (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
-> (ApplyTxError era
    -> ExceptT
         (ApplyTxError era) Identity (LedgerState era, ValidatedTx era))
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
forall a.
ExceptT (ApplyTxError era) Identity a
-> (ApplyTxError era -> ExceptT (ApplyTxError era) Identity a)
-> ExceptT (ApplyTxError era) Identity a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` ApplyTxError era
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
handler) (ExceptT
   (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
 -> ExceptT
      (ApplyTxError era) Identity (LedgerState era, ValidatedTx era))
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
forall a b. (a -> b) -> a -> b
$
      Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
defaultApplyShelleyBasedTx
        Globals
globals
        LedgerEnv era
ledgerEnv
        LedgerState era
mempoolState
        WhetherToIntervene
wti
        Tx TopTx era
intervenedTx
  pure (mempoolState', vtx)
 where
  intervenedTx :: Tx TopTx era
intervenedTx = case WhetherToIntervene
wti of
    WhetherToIntervene
DoNotIntervene -> Tx TopTx era
tx Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (IsPhase2Valid -> Identity IsPhase2Valid)
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsPhase2Valid
Lens' (Tx TopTx era) IsPhase2Valid
Core.isPhase2ValidTxL ((IsPhase2Valid -> Identity IsPhase2Valid)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> IsPhase2Valid -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ IsPhase2Valid
L.Phase2Valid
    WhetherToIntervene
Intervene -> Tx TopTx era
tx

  handler :: ApplyTxError era
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
handler ApplyTxError era
e = case (WhetherToIntervene
wti, ApplyTxError era
e) of
    (WhetherToIntervene
DoNotIntervene, ApplyTxError era
err)
      | Proxy era -> ApplyTxError era -> Bool
forall era (proxy :: * -> *).
SupportsTwoPhaseValidation era =>
proxy era -> ApplyTxError era -> Bool
forall (proxy :: * -> *). proxy era -> ApplyTxError era -> Bool
isIncorrectClaimedFlag (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @era) ApplyTxError era
err ->
          -- rectify the flag and include the transaction
          --
          -- This either lets the ledger punish the script author for sending
          -- a bad script or else prevents our peer's buggy script validator
          -- from preventing inclusion of a valid script.
          --
          -- TODO 'applyTx' et al needs to include a return value indicating
          -- whether we took this branch; it's a reason to disconnect from
          -- the peer who sent us the incorrect flag (ie Issue #3276)
          Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except (ApplyTxError era) (LedgerState era, ValidatedTx era)
defaultApplyShelleyBasedTx
            Globals
globals
            LedgerEnv era
ledgerEnv
            LedgerState era
mempoolState
            WhetherToIntervene
wti
            (Tx TopTx era
tx Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (IsPhase2Valid -> Identity IsPhase2Valid)
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsPhase2Valid
Lens' (Tx TopTx era) IsPhase2Valid
Core.isPhase2ValidTxL ((IsPhase2Valid -> Identity IsPhase2Valid)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> IsPhase2Valid -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ IsPhase2Valid
L.Phase2Invalid)
    (WhetherToIntervene, ApplyTxError era)
_ -> ApplyTxError era
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, ValidatedTx era)
forall a. ApplyTxError era -> ExceptT (ApplyTxError era) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ApplyTxError era
e

-- reject the transaction, protecting the local wallet

class SupportsTwoPhaseValidation era where
  -- NOTE: this class won't be needed once https://github.com/IntersectMBO/cardano-ledger/issues/4167 is implemented.
  isIncorrectClaimedFlag :: proxy era -> SL.ApplyTxError era -> Bool

instance SupportsTwoPhaseValidation AlonzoEra where
  isIncorrectClaimedFlag :: forall (proxy :: * -> *).
proxy AlonzoEra -> ApplyTxError AlonzoEra -> Bool
isIncorrectClaimedFlag proxy AlonzoEra
_ (AlonzoApplyTxError (ShelleyLedgerPredFailure AlonzoEra
err :| [])) = case ShelleyLedgerPredFailure AlonzoEra
err of
    SL.UtxowFailure
      ( Alonzo.ShelleyInAlonzoUtxowPredFailure
          ( SL.UtxoFailure
              ( Alonzo.UtxosFailure
                  ( Alonzo.ValidationTagMismatch
                      IsPhase2Valid
_isValid
                      TagMismatchDescription
_validationErrs
                    )
                )
            )
        ) -> Bool
True
    ShelleyLedgerPredFailure AlonzoEra
_ -> Bool
False
  isIncorrectClaimedFlag proxy AlonzoEra
_ ApplyTxError AlonzoEra
_ = Bool
False

instance SupportsTwoPhaseValidation BabbageEra where
  isIncorrectClaimedFlag :: forall (proxy :: * -> *).
proxy BabbageEra -> ApplyTxError BabbageEra -> Bool
isIncorrectClaimedFlag proxy BabbageEra
_ (BabbageApplyTxError (ShelleyLedgerPredFailure BabbageEra
err :| [])) = case ShelleyLedgerPredFailure BabbageEra
err of
    SL.UtxowFailure
      ( Babbage.AlonzoInBabbageUtxowPredFailure
          ( Alonzo.ShelleyInAlonzoUtxowPredFailure
              ( SL.UtxoFailure
                  ( Babbage.AlonzoInBabbageUtxoPredFailure
                      ( Alonzo.UtxosFailure
                          ( Alonzo.ValidationTagMismatch
                              IsPhase2Valid
_isValid
                              TagMismatchDescription
_validationErrs
                            )
                        )
                    )
                )
            )
        ) -> Bool
True
    SL.UtxowFailure
      ( Babbage.UtxoFailure
          ( Babbage.AlonzoInBabbageUtxoPredFailure
              ( Alonzo.UtxosFailure
                  ( Alonzo.ValidationTagMismatch
                      IsPhase2Valid
_isValid
                      TagMismatchDescription
_validationErrs
                    )
                )
            )
        ) -> Bool
True
    ShelleyLedgerPredFailure BabbageEra
_ -> Bool
False
  isIncorrectClaimedFlag proxy BabbageEra
_ ApplyTxError BabbageEra
_ = Bool
False

instance SupportsTwoPhaseValidation ConwayEra where
  isIncorrectClaimedFlag :: forall (proxy :: * -> *).
proxy ConwayEra -> ApplyTxError ConwayEra -> Bool
isIncorrectClaimedFlag proxy ConwayEra
_ (ConwayApplyTxError (ConwayLedgerPredFailure ConwayEra
err :| [])) = case ConwayLedgerPredFailure ConwayEra
err of
    SL.ConwayUtxowFailure
      ( Conway.UtxoFailure
          ( Conway.UtxosFailure
              ( Conway.ValidationTagMismatch
                  IsPhase2Valid
_isValid
                  TagMismatchDescription
_validationErrs
                )
            )
        ) -> Bool
True
    ConwayLedgerPredFailure ConwayEra
_ -> Bool
False
  isIncorrectClaimedFlag proxy ConwayEra
_ ApplyTxError ConwayEra
_ = Bool
False

instance SupportsTwoPhaseValidation DijkstraEra where
  isIncorrectClaimedFlag :: forall (proxy :: * -> *).
proxy DijkstraEra -> ApplyTxError DijkstraEra -> Bool
isIncorrectClaimedFlag proxy DijkstraEra
_ (DijkstraApplyTxError (DijkstraMempoolPredFailure DijkstraEra
err :| [])) = case DijkstraMempoolPredFailure DijkstraEra
err of
    Dijkstra.LedgerFailure
      ( SL.DijkstraUtxowFailure
          ( Dijkstra.UtxoFailure
              ( Dijkstra.UtxosFailure
                  ( Conway.ValidationTagMismatch
                      IsPhase2Valid
_isValid
                      TagMismatchDescription
_validationErrs
                    )
                )
            )
        ) -> Bool
True
    DijkstraMempoolPredFailure DijkstraEra
_ -> Bool
False
  isIncorrectClaimedFlag proxy DijkstraEra
_ ApplyTxError DijkstraEra
_ = Bool
False