{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# 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
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.Alonzo.Tx as Alonzo
import qualified Cardano.Ledger.Api.Era 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 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 qualified Cardano.Protocol.TPraos.API 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.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.ApplyBlock era
  , SL.EraTransition era
  , -- TODO This constraint is quite tight, since it fixes things to the
    -- original TPraos ledger view. We would like to ultimately remove it.
    SL.GetLedgerView 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 (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.Validated (Core.Tx TopTx era)
      )

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

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

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.Validated (Core.Tx TopTx era)
    )
defaultApplyShelleyBasedTx :: forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx era))
defaultApplyShelleyBasedTx Globals
globals LedgerEnv era
ledgerEnv LedgerState era
mempoolState WhetherToIntervene
_wti Tx TopTx era
tx =
  Either
  (ApplyTxError era) (LedgerState era, Validated (Tx TopTx era))
-> ExceptT
     (ApplyTxError era)
     Identity
     (LedgerState era, Validated (Tx TopTx era))
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either
   (ApplyTxError era) (LedgerState era, Validated (Tx TopTx era))
 -> ExceptT
      (ApplyTxError era)
      Identity
      (LedgerState era, Validated (Tx TopTx era)))
-> Either
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx era))
-> ExceptT
     (ApplyTxError era)
     Identity
     (LedgerState era, Validated (Tx TopTx era))
forall a b. (a -> b) -> a -> b
$
    Globals
-> LedgerEnv era
-> LedgerState era
-> Tx TopTx era
-> Either
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx era))
forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either
     (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
SL.applyTx
      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

instance ShelleyBasedEra ShelleyEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv ShelleyEra
-> LedgerState ShelleyEra
-> WhetherToIntervene
-> Tx TopTx ShelleyEra
-> Except
     (ApplyTxError ShelleyEra)
     (LedgerState ShelleyEra, Validated (Tx TopTx ShelleyEra))
applyShelleyBasedTx = Globals
-> LedgerEnv ShelleyEra
-> LedgerState ShelleyEra
-> WhetherToIntervene
-> Tx TopTx ShelleyEra
-> Except
     (ApplyTxError ShelleyEra)
     (LedgerState ShelleyEra, Validated (Tx TopTx ShelleyEra))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx 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

instance ShelleyBasedEra AllegraEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv AllegraEra
-> LedgerState AllegraEra
-> WhetherToIntervene
-> Tx TopTx AllegraEra
-> Except
     (ApplyTxError AllegraEra)
     (LedgerState AllegraEra, Validated (Tx TopTx AllegraEra))
applyShelleyBasedTx = Globals
-> LedgerEnv AllegraEra
-> LedgerState AllegraEra
-> WhetherToIntervene
-> Tx TopTx AllegraEra
-> Except
     (ApplyTxError AllegraEra)
     (LedgerState AllegraEra, Validated (Tx TopTx AllegraEra))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx 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

instance ShelleyBasedEra MaryEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv MaryEra
-> LedgerState MaryEra
-> WhetherToIntervene
-> Tx TopTx MaryEra
-> Except
     (ApplyTxError MaryEra)
     (LedgerState MaryEra, Validated (Tx TopTx MaryEra))
applyShelleyBasedTx = Globals
-> LedgerEnv MaryEra
-> LedgerState MaryEra
-> WhetherToIntervene
-> Tx TopTx MaryEra
-> Except
     (ApplyTxError MaryEra)
     (LedgerState MaryEra, Validated (Tx TopTx MaryEra))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx 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

instance ShelleyBasedEra AlonzoEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv AlonzoEra
-> LedgerState AlonzoEra
-> WhetherToIntervene
-> Tx TopTx AlonzoEra
-> Except
     (ApplyTxError AlonzoEra)
     (LedgerState AlonzoEra, Validated (Tx TopTx AlonzoEra))
applyShelleyBasedTx = Globals
-> LedgerEnv AlonzoEra
-> LedgerState AlonzoEra
-> WhetherToIntervene
-> Tx TopTx AlonzoEra
-> Except
     (ApplyTxError AlonzoEra)
     (LedgerState AlonzoEra, Validated (Tx TopTx AlonzoEra))
forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx 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

instance ShelleyBasedEra BabbageEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv BabbageEra
-> LedgerState BabbageEra
-> WhetherToIntervene
-> Tx TopTx BabbageEra
-> Except
     (ApplyTxError BabbageEra)
     (LedgerState BabbageEra, Validated (Tx TopTx BabbageEra))
applyShelleyBasedTx = Globals
-> LedgerEnv BabbageEra
-> LedgerState BabbageEra
-> WhetherToIntervene
-> Tx TopTx BabbageEra
-> Except
     (ApplyTxError BabbageEra)
     (LedgerState BabbageEra, Validated (Tx TopTx BabbageEra))
forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx 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

instance ShelleyBasedEra ConwayEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv ConwayEra
-> LedgerState ConwayEra
-> WhetherToIntervene
-> Tx TopTx ConwayEra
-> Except
     (ApplyTxError ConwayEra)
     (LedgerState ConwayEra, Validated (Tx TopTx ConwayEra))
applyShelleyBasedTx = Globals
-> LedgerEnv ConwayEra
-> LedgerState ConwayEra
-> WhetherToIntervene
-> Tx TopTx ConwayEra
-> Except
     (ApplyTxError ConwayEra)
     (LedgerState ConwayEra, Validated (Tx TopTx ConwayEra))
forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx 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))

instance ShelleyBasedEra DijkstraEra where
  applyShelleyBasedTx :: Globals
-> LedgerEnv DijkstraEra
-> LedgerState DijkstraEra
-> WhetherToIntervene
-> Tx TopTx DijkstraEra
-> Except
     (ApplyTxError DijkstraEra)
     (LedgerState DijkstraEra, Validated (Tx TopTx DijkstraEra))
applyShelleyBasedTx = Globals
-> LedgerEnv DijkstraEra
-> LedgerState DijkstraEra
-> WhetherToIntervene
-> Tx TopTx DijkstraEra
-> Except
     (ApplyTxError DijkstraEra)
     (LedgerState DijkstraEra, Validated (Tx TopTx DijkstraEra))
forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx 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

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.Validated (Core.Tx TopTx era)
    )
applyAlonzoBasedTx :: forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx 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, Validated (Tx TopTx era))
-> (ApplyTxError era
    -> ExceptT
         (ApplyTxError era)
         Identity
         (LedgerState era, Validated (Tx TopTx era)))
-> ExceptT
     (ApplyTxError era)
     Identity
     (LedgerState era, Validated (Tx TopTx 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, Validated (Tx TopTx era))
handler) (ExceptT
   (ApplyTxError era)
   Identity
   (LedgerState era, Validated (Tx TopTx era))
 -> ExceptT
      (ApplyTxError era)
      Identity
      (LedgerState era, Validated (Tx TopTx era)))
-> ExceptT
     (ApplyTxError era)
     Identity
     (LedgerState era, Validated (Tx TopTx era))
-> ExceptT
     (ApplyTxError era)
     Identity
     (LedgerState era, Validated (Tx TopTx era))
forall a b. (a -> b) -> a -> b
$
      Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> ExceptT
     (ApplyTxError era)
     Identity
     (LedgerState era, Validated (Tx TopTx era))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx 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
& (IsValid -> Identity IsValid)
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
Core.isValidTxL ((IsValid -> Identity IsValid)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> IsValid -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> IsValid
Alonzo.IsValid Bool
True
    WhetherToIntervene
Intervene -> Tx TopTx era
tx

  handler :: ApplyTxError era
-> ExceptT
     (ApplyTxError era)
     Identity
     (LedgerState era, Validated (Tx TopTx 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, Validated (Tx TopTx era))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx TopTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (Tx TopTx 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
& (IsValid -> Identity IsValid)
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
Core.isValidTxL ((IsValid -> Identity IsValid)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> IsValid -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> IsValid
Alonzo.IsValid Bool
False)
    (WhetherToIntervene, ApplyTxError era)
_ -> ApplyTxError era
-> ExceptT
     (ApplyTxError era)
     Identity
     (LedgerState era, Validated (Tx TopTx 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
                      (Alonzo.IsValid Bool
_claimedFlag)
                      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
                              (Alonzo.IsValid Bool
_claimedFlag)
                              TagMismatchDescription
_validationErrs
                            )
                        )
                    )
                )
            )
        ) -> Bool
True
    SL.UtxowFailure
      ( Babbage.UtxoFailure
          ( Babbage.AlonzoInBabbageUtxoPredFailure
              ( Alonzo.UtxosFailure
                  ( Alonzo.ValidationTagMismatch
                      (Alonzo.IsValid Bool
_claimedFlag)
                      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
                  (Alonzo.IsValid Bool
_claimedFlag)
                  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
                      (Alonzo.IsValid Bool
_claimedFlag)
                      TagMismatchDescription
_validationErrs
                    )
                )
            )
        ) -> Bool
True
    DijkstraMempoolPredFailure DijkstraEra
_ -> Bool
False
  isIncorrectClaimedFlag proxy DijkstraEra
_ ApplyTxError DijkstraEra
_ = Bool
False