{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# 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)
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 (BabbageEra)
import qualified Cardano.Ledger.Babbage.Rules as Babbage
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
import Cardano.Ledger.Conway (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 (DijkstraEra)
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 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 era ->
    Except
      (SL.ApplyTxError era)
      ( SL.LedgerState era
      , SL.Validated (Core.Tx era)
      )

  -- | Whether the era has an instance of 'CG.ConwayEraGov'
  getConwayEraGovDict :: proxy era -> Maybe (ConwayEraGovDict 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 era ->
  Except
    (SL.ApplyTxError era)
    ( SL.LedgerState era
    , SL.Validated (Core.Tx era)
    )
defaultApplyShelleyBasedTx :: forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (LedgerState era, Validated (Tx era))
defaultApplyShelleyBasedTx Globals
globals LedgerEnv era
ledgerEnv LedgerState era
mempoolState WhetherToIntervene
_wti Tx era
tx =
  Either (ApplyTxError era) (LedgerState era, Validated (Tx era))
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, Validated (Tx era))
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either (ApplyTxError era) (LedgerState era, Validated (Tx era))
 -> ExceptT
      (ApplyTxError era) Identity (LedgerState era, Validated (Tx era)))
-> Either (ApplyTxError era) (LedgerState era, Validated (Tx era))
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, Validated (Tx era))
forall a b. (a -> b) -> a -> b
$
    Globals
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> Either (ApplyTxError era) (LedgerState era, Validated (Tx era))
forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
SL.applyTx
      Globals
globals
      LedgerEnv era
ledgerEnv
      LedgerState era
mempoolState
      Tx 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 ShelleyEra
-> Except
     (ApplyTxError ShelleyEra)
     (LedgerState ShelleyEra, Validated (Tx ShelleyEra))
applyShelleyBasedTx = Globals
-> LedgerEnv ShelleyEra
-> LedgerState ShelleyEra
-> WhetherToIntervene
-> Tx ShelleyEra
-> Except
     (ApplyTxError ShelleyEra)
     (LedgerState ShelleyEra, Validated (Tx ShelleyEra))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (LedgerState era, Validated (Tx 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

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

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

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

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

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

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

applyAlonzoBasedTx ::
  forall era.
  ( AlonzoEraTx era
  , ShelleyBasedEra era
  , SupportsTwoPhaseValidation era
  ) =>
  Globals ->
  SL.LedgerEnv era ->
  SL.LedgerState era ->
  WhetherToIntervene ->
  Core.Tx era ->
  Except
    (SL.ApplyTxError era)
    ( SL.LedgerState era
    , SL.Validated (Core.Tx era)
    )
applyAlonzoBasedTx :: forall era.
(AlonzoEraTx era, ShelleyBasedEra era,
 SupportsTwoPhaseValidation era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (LedgerState era, Validated (Tx era))
applyAlonzoBasedTx Globals
globals LedgerEnv era
ledgerEnv LedgerState era
mempoolState WhetherToIntervene
wti Tx era
tx = do
  (mempoolState', vtx) <-
    (ExceptT
  (ApplyTxError era) Identity (LedgerState era, Validated (Tx era))
-> (ApplyTxError era
    -> ExceptT
         (ApplyTxError era) Identity (LedgerState era, Validated (Tx era)))
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, Validated (Tx 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 era))
handler) (ExceptT
   (ApplyTxError era) Identity (LedgerState era, Validated (Tx era))
 -> ExceptT
      (ApplyTxError era) Identity (LedgerState era, Validated (Tx era)))
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, Validated (Tx era))
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, Validated (Tx era))
forall a b. (a -> b) -> a -> b
$
      Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx era
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, Validated (Tx era))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (LedgerState era, Validated (Tx era))
defaultApplyShelleyBasedTx
        Globals
globals
        LedgerEnv era
ledgerEnv
        LedgerState era
mempoolState
        WhetherToIntervene
wti
        Tx era
intervenedTx
  pure (mempoolState', vtx)
 where
  intervenedTx :: Tx era
intervenedTx = case WhetherToIntervene
wti of
    WhetherToIntervene
DoNotIntervene -> Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (IsValid -> Identity IsValid) -> Tx era -> Identity (Tx era)
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx era) IsValid
Core.isValidTxL ((IsValid -> Identity IsValid) -> Tx era -> Identity (Tx era))
-> IsValid -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> IsValid
Alonzo.IsValid Bool
True
    WhetherToIntervene
Intervene -> Tx era
tx

  handler :: ApplyTxError era
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, Validated (Tx era))
handler ApplyTxError era
e = case (WhetherToIntervene
wti, ApplyTxError era
e) of
    (WhetherToIntervene
DoNotIntervene, SL.ApplyTxError (PredicateFailure (EraRule "LEDGER" era)
err :| []))
      | Proxy era -> PredicateFailure (EraRule "LEDGER" era) -> Bool
forall era (proxy :: * -> *).
SupportsTwoPhaseValidation era =>
proxy era -> PredicateFailure (EraRule "LEDGER" era) -> Bool
forall (proxy :: * -> *).
proxy era -> PredicateFailure (EraRule "LEDGER" era) -> Bool
isIncorrectClaimedFlag (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @era) PredicateFailure (EraRule "LEDGER" 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 era
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, Validated (Tx era))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (LedgerState era, Validated (Tx era))
defaultApplyShelleyBasedTx
            Globals
globals
            LedgerEnv era
ledgerEnv
            LedgerState era
mempoolState
            WhetherToIntervene
wti
            (Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (IsValid -> Identity IsValid) -> Tx era -> Identity (Tx era)
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx era) IsValid
Core.isValidTxL ((IsValid -> Identity IsValid) -> Tx era -> Identity (Tx era))
-> IsValid -> Tx era -> Tx 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 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.PredicateFailure (Core.EraRule "LEDGER" era) -> Bool

instance SupportsTwoPhaseValidation AlonzoEra where
  isIncorrectClaimedFlag :: forall (proxy :: * -> *).
proxy AlonzoEra
-> PredicateFailure (EraRule "LEDGER" AlonzoEra) -> Bool
isIncorrectClaimedFlag proxy AlonzoEra
_ = \case
    SL.UtxowFailure
      ( Alonzo.ShelleyInAlonzoUtxowPredFailure
          ( SL.UtxoFailure
              ( Alonzo.UtxosFailure
                  ( Alonzo.ValidationTagMismatch
                      (Alonzo.IsValid Bool
_claimedFlag)
                      TagMismatchDescription
_validationErrs
                    )
                )
            )
        ) ->
        Bool
True
    PredicateFailure (EraRule "LEDGER" AlonzoEra)
_ -> Bool
False

instance SupportsTwoPhaseValidation BabbageEra where
  isIncorrectClaimedFlag :: forall (proxy :: * -> *).
proxy BabbageEra
-> PredicateFailure (EraRule "LEDGER" BabbageEra) -> Bool
isIncorrectClaimedFlag proxy BabbageEra
_ = \case
    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
    PredicateFailure (EraRule "LEDGER" BabbageEra)
_ -> Bool
False

instance SupportsTwoPhaseValidation ConwayEra where
  isIncorrectClaimedFlag :: forall (proxy :: * -> *).
proxy ConwayEra
-> PredicateFailure (EraRule "LEDGER" ConwayEra) -> Bool
isIncorrectClaimedFlag proxy ConwayEra
_ = \case
    SL.ConwayUtxowFailure
      ( Conway.UtxoFailure
          ( Conway.UtxosFailure
              ( Conway.ValidationTagMismatch
                  (Alonzo.IsValid Bool
_claimedFlag)
                  TagMismatchDescription
_validationErrs
                )
            )
        ) -> Bool
True
    PredicateFailure (EraRule "LEDGER" ConwayEra)
_ -> Bool
False

instance SupportsTwoPhaseValidation DijkstraEra where
  isIncorrectClaimedFlag :: forall (proxy :: * -> *).
proxy DijkstraEra
-> PredicateFailure (EraRule "LEDGER" DijkstraEra) -> Bool
isIncorrectClaimedFlag proxy DijkstraEra
_ = \case
    SL.ConwayUtxowFailure
      ( Conway.UtxoFailure
          ( Conway.UtxosFailure
              ( Conway.ValidationTagMismatch
                  (Alonzo.IsValid Bool
_claimedFlag)
                  TagMismatchDescription
_validationErrs
                )
            )
        ) -> Bool
True
    PredicateFailure (EraRule "LEDGER" DijkstraEra)
_ -> Bool
False