{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Eras (
    -- * Eras based on the Shelley ledger
    AllegraEra
  , AlonzoEra
  , BabbageEra
  , ConwayEra
  , MaryEra
  , ShelleyEra
    -- * Eras instantiated with standard crypto
  , StandardAllegra
  , StandardAlonzo
  , StandardBabbage
  , StandardConway
  , StandardMary
  , StandardShelley
    -- * Shelley-based era
  , ConwayEraGovDict (..)
  , ShelleyBasedEra (..)
  , WrapTx (..)
    -- * 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 qualified Cardano.Ledger.Alonzo.Rules as Alonzo
import qualified Cardano.Ledger.Alonzo.Translation 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 qualified Cardano.Ledger.Babbage.Translation 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.Translation as Conway
import           Cardano.Ledger.Core as Core
import           Cardano.Ledger.Mary (MaryEra)
import           Cardano.Ledger.Mary.Translation ()
import           Cardano.Ledger.Shelley (ShelleyEra)
import qualified Cardano.Ledger.Shelley.API as SL
import           Cardano.Ledger.Shelley.Core as Core
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           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.Ledger.SupportsMempool
                     (WhetherToIntervene (..))
import           Ouroboros.Consensus.Protocol.TPraos (StandardCrypto)

{-------------------------------------------------------------------------------
  Eras instantiated with standard crypto
-------------------------------------------------------------------------------}

-- | The Shelley era with standard crypto
type StandardShelley = ShelleyEra
{-# DEPRECATED StandardShelley "In favor of `ShelleyEra`" #-}

-- | The Allegra era with standard crypto
type StandardAllegra = AllegraEra
{-# DEPRECATED StandardAllegra "In favor of `AllegraEra`" #-}

-- | The Mary era with standard crypto
type StandardMary = MaryEra
{-# DEPRECATED StandardMary "In favor of `MaryEra`" #-}

-- | The Alonzo era with standard crypto
type StandardAlonzo = AlonzoEra
{-# DEPRECATED StandardAlonzo "In favor of `AlonzoEra`" #-}

-- | The Babbage era with standard crypto
type StandardBabbage = BabbageEra
{-# DEPRECATED StandardBabbage "In favor of `BabbageEra`" #-}

-- | The Conway era with standard crypto
type StandardConway = ConwayEra
{-# DEPRECATED StandardConway "In favor of `ConwayEra`" #-}

{-------------------------------------------------------------------------------
  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.EraSegWits 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 => 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))
Globals
-> LedgerEnv AlonzoEra
-> LedgerState AlonzoEra
-> WhetherToIntervene
-> AlonzoTx AlonzoEra
-> Except
     (ApplyTxError AlonzoEra)
     (LedgerState AlonzoEra, Validated (AlonzoTx AlonzoEra))
forall era.
(ShelleyBasedEra era, SupportsTwoPhaseValidation era,
 Tx era ~ AlonzoTx era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> AlonzoTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (AlonzoTx 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))
Globals
-> LedgerEnv BabbageEra
-> LedgerState BabbageEra
-> WhetherToIntervene
-> AlonzoTx BabbageEra
-> Except
     (ApplyTxError BabbageEra)
     (LedgerState BabbageEra, Validated (AlonzoTx BabbageEra))
forall era.
(ShelleyBasedEra era, SupportsTwoPhaseValidation era,
 Tx era ~ AlonzoTx era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> AlonzoTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (AlonzoTx 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))
Globals
-> LedgerEnv ConwayEra
-> LedgerState ConwayEra
-> WhetherToIntervene
-> AlonzoTx ConwayEra
-> Except
     (ApplyTxError ConwayEra)
     (LedgerState ConwayEra, Validated (AlonzoTx ConwayEra))
forall era.
(ShelleyBasedEra era, SupportsTwoPhaseValidation era,
 Tx era ~ AlonzoTx era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> AlonzoTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (AlonzoTx 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 => ConwayEraGovDict era
ConwayEraGovDict

applyAlonzoBasedTx :: forall era.
  ( ShelleyBasedEra era,
    SupportsTwoPhaseValidation era,
    Core.Tx era ~ Alonzo.AlonzoTx era
  ) =>
  Globals ->
  SL.LedgerEnv era ->
  SL.LedgerState era ->
  WhetherToIntervene ->
  Alonzo.AlonzoTx era ->
  Except
    (SL.ApplyTxError era)
    ( SL.LedgerState era,
      SL.Validated (Alonzo.AlonzoTx era)
    )
applyAlonzoBasedTx :: forall era.
(ShelleyBasedEra era, SupportsTwoPhaseValidation era,
 Tx era ~ AlonzoTx era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> AlonzoTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (AlonzoTx era))
applyAlonzoBasedTx Globals
globals LedgerEnv era
ledgerEnv LedgerState era
mempoolState WhetherToIntervene
wti AlonzoTx era
tx = do
      (LedgerState era
mempoolState', Validated (AlonzoTx era)
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
AlonzoTx era
intervenedTx
      (LedgerState era, Validated (AlonzoTx era))
-> Except
     (ApplyTxError era) (LedgerState era, Validated (AlonzoTx era))
forall a. a -> ExceptT (ApplyTxError era) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerState era
mempoolState', Validated (AlonzoTx era)
vtx)
    where
      intervenedTx :: AlonzoTx era
intervenedTx = case WhetherToIntervene
wti of
        WhetherToIntervene
DoNotIntervene -> AlonzoTx era
tx { Alonzo.isValid = Alonzo.IsValid True }
        WhetherToIntervene
Intervene      -> AlonzoTx 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
              AlonzoTx era
tx{Alonzo.isValid = Alonzo.IsValid False}
        (WhetherToIntervene, ApplyTxError era)
_ -> ApplyTxError era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (AlonzoTx 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

{-------------------------------------------------------------------------------
  Tx family wrapper
-------------------------------------------------------------------------------}

-- | Wrapper for partially applying the 'Tx' type family
--
-- For generality, Consensus uses that type family as eg the index of
-- 'Core.TranslateEra'. We thus need to partially apply it.
--
-- @cardano-ledger-specs@ also declares such a newtype, but currently it's only
-- defined in the Alonzo translation module, which seems somewhat inappropriate
-- to use for previous eras. Also, we use a @Wrap@ prefix in Consensus. Hence
-- this minor mediating definition. TODO I'm not even fully persuading myself
-- with this justification.
newtype WrapTx era = WrapTx {forall era. WrapTx era -> Tx era
unwrapTx :: Core.Tx era}

instance Core.TranslateEra AllegraEra WrapTx where
  type TranslationError AllegraEra WrapTx = Core.TranslationError AllegraEra SL.ShelleyTx
  translateEra :: TranslationContext AllegraEra
-> WrapTx (PreviousEra AllegraEra)
-> Except (TranslationError AllegraEra WrapTx) (WrapTx AllegraEra)
translateEra TranslationContext AllegraEra
ctxt = (ShelleyTx AllegraEra -> WrapTx AllegraEra)
-> ExceptT DecoderError Identity (ShelleyTx AllegraEra)
-> ExceptT DecoderError Identity (WrapTx AllegraEra)
forall a b.
(a -> b)
-> ExceptT DecoderError Identity a
-> ExceptT DecoderError Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tx AllegraEra -> WrapTx AllegraEra
ShelleyTx AllegraEra -> WrapTx AllegraEra
forall era. Tx era -> WrapTx era
WrapTx (ExceptT DecoderError Identity (ShelleyTx AllegraEra)
 -> ExceptT DecoderError Identity (WrapTx AllegraEra))
-> (WrapTx ShelleyEra
    -> ExceptT DecoderError Identity (ShelleyTx AllegraEra))
-> WrapTx ShelleyEra
-> ExceptT DecoderError Identity (WrapTx AllegraEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext AllegraEra
-> ShelleyTx (PreviousEra AllegraEra)
-> Except
     (TranslationError AllegraEra ShelleyTx) (ShelleyTx AllegraEra)
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
Core.translateEra TranslationContext AllegraEra
ctxt (ShelleyTx ShelleyEra
 -> ExceptT DecoderError Identity (ShelleyTx AllegraEra))
-> (WrapTx ShelleyEra -> ShelleyTx ShelleyEra)
-> WrapTx ShelleyEra
-> ExceptT DecoderError Identity (ShelleyTx AllegraEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx ShelleyEra -> Tx ShelleyEra
WrapTx ShelleyEra -> ShelleyTx ShelleyEra
forall era. WrapTx era -> Tx era
unwrapTx

instance Core.TranslateEra MaryEra WrapTx where
  type TranslationError MaryEra WrapTx = Core.TranslationError MaryEra SL.ShelleyTx
  translateEra :: TranslationContext MaryEra
-> WrapTx (PreviousEra MaryEra)
-> Except (TranslationError MaryEra WrapTx) (WrapTx MaryEra)
translateEra TranslationContext MaryEra
ctxt = (ShelleyTx MaryEra -> WrapTx MaryEra)
-> ExceptT DecoderError Identity (ShelleyTx MaryEra)
-> ExceptT DecoderError Identity (WrapTx MaryEra)
forall a b.
(a -> b)
-> ExceptT DecoderError Identity a
-> ExceptT DecoderError Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tx MaryEra -> WrapTx MaryEra
ShelleyTx MaryEra -> WrapTx MaryEra
forall era. Tx era -> WrapTx era
WrapTx (ExceptT DecoderError Identity (ShelleyTx MaryEra)
 -> ExceptT DecoderError Identity (WrapTx MaryEra))
-> (WrapTx AllegraEra
    -> ExceptT DecoderError Identity (ShelleyTx MaryEra))
-> WrapTx AllegraEra
-> ExceptT DecoderError Identity (WrapTx MaryEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext MaryEra
-> ShelleyTx (PreviousEra MaryEra)
-> Except (TranslationError MaryEra ShelleyTx) (ShelleyTx MaryEra)
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
Core.translateEra TranslationContext MaryEra
ctxt (ShelleyTx AllegraEra
 -> ExceptT DecoderError Identity (ShelleyTx MaryEra))
-> (WrapTx AllegraEra -> ShelleyTx AllegraEra)
-> WrapTx AllegraEra
-> ExceptT DecoderError Identity (ShelleyTx MaryEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx AllegraEra -> Tx AllegraEra
WrapTx AllegraEra -> ShelleyTx AllegraEra
forall era. WrapTx era -> Tx era
unwrapTx

instance Core.TranslateEra AlonzoEra WrapTx where
  type TranslationError AlonzoEra WrapTx = Core.TranslationError AlonzoEra Alonzo.Tx
  translateEra :: TranslationContext AlonzoEra
-> WrapTx (PreviousEra AlonzoEra)
-> Except (TranslationError AlonzoEra WrapTx) (WrapTx AlonzoEra)
translateEra TranslationContext AlonzoEra
ctxt =
        (Tx AlonzoEra -> WrapTx AlonzoEra)
-> ExceptT DecoderError Identity (Tx AlonzoEra)
-> ExceptT DecoderError Identity (WrapTx AlonzoEra)
forall a b.
(a -> b)
-> ExceptT DecoderError Identity a
-> ExceptT DecoderError Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tx AlonzoEra -> WrapTx AlonzoEra
AlonzoTx AlonzoEra -> WrapTx AlonzoEra
forall era. Tx era -> WrapTx era
WrapTx (AlonzoTx AlonzoEra -> WrapTx AlonzoEra)
-> (Tx AlonzoEra -> AlonzoTx AlonzoEra)
-> Tx AlonzoEra
-> WrapTx AlonzoEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx AlonzoEra -> Tx AlonzoEra
Tx AlonzoEra -> AlonzoTx AlonzoEra
forall era. Tx era -> Tx era
Alonzo.unTx)
      (ExceptT DecoderError Identity (Tx AlonzoEra)
 -> ExceptT DecoderError Identity (WrapTx AlonzoEra))
-> (WrapTx MaryEra -> ExceptT DecoderError Identity (Tx AlonzoEra))
-> WrapTx MaryEra
-> ExceptT DecoderError Identity (WrapTx AlonzoEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
Core.translateEra @AlonzoEra TranslationContext AlonzoEra
ctxt
      (Tx MaryEra -> ExceptT DecoderError Identity (Tx AlonzoEra))
-> (WrapTx MaryEra -> Tx MaryEra)
-> WrapTx MaryEra
-> ExceptT DecoderError Identity (Tx AlonzoEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx MaryEra -> Tx MaryEra
ShelleyTx MaryEra -> Tx MaryEra
forall era. Tx era -> Tx era
Alonzo.Tx (ShelleyTx MaryEra -> Tx MaryEra)
-> (WrapTx MaryEra -> ShelleyTx MaryEra)
-> WrapTx MaryEra
-> Tx MaryEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx MaryEra -> Tx MaryEra
WrapTx MaryEra -> ShelleyTx MaryEra
forall era. WrapTx era -> Tx era
unwrapTx

instance Core.TranslateEra BabbageEra WrapTx where
  type TranslationError BabbageEra WrapTx = Core.TranslationError BabbageEra Babbage.Tx
  translateEra :: TranslationContext BabbageEra
-> WrapTx (PreviousEra BabbageEra)
-> Except (TranslationError BabbageEra WrapTx) (WrapTx BabbageEra)
translateEra TranslationContext BabbageEra
ctxt =
        (Tx BabbageEra -> WrapTx BabbageEra)
-> ExceptT DecoderError Identity (Tx BabbageEra)
-> ExceptT DecoderError Identity (WrapTx BabbageEra)
forall a b.
(a -> b)
-> ExceptT DecoderError Identity a
-> ExceptT DecoderError Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tx BabbageEra -> WrapTx BabbageEra
AlonzoTx BabbageEra -> WrapTx BabbageEra
forall era. Tx era -> WrapTx era
WrapTx (AlonzoTx BabbageEra -> WrapTx BabbageEra)
-> (Tx BabbageEra -> AlonzoTx BabbageEra)
-> Tx BabbageEra
-> WrapTx BabbageEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx BabbageEra -> Tx BabbageEra
Tx BabbageEra -> AlonzoTx BabbageEra
forall era. Tx era -> Tx era
Babbage.unTx)
      (ExceptT DecoderError Identity (Tx BabbageEra)
 -> ExceptT DecoderError Identity (WrapTx BabbageEra))
-> (WrapTx AlonzoEra
    -> ExceptT DecoderError Identity (Tx BabbageEra))
-> WrapTx AlonzoEra
-> ExceptT DecoderError Identity (WrapTx BabbageEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
Core.translateEra @BabbageEra TranslationContext BabbageEra
ctxt
      (Tx AlonzoEra -> ExceptT DecoderError Identity (Tx BabbageEra))
-> (WrapTx AlonzoEra -> Tx AlonzoEra)
-> WrapTx AlonzoEra
-> ExceptT DecoderError Identity (Tx BabbageEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx AlonzoEra -> Tx AlonzoEra
AlonzoTx AlonzoEra -> Tx AlonzoEra
forall era. Tx era -> Tx era
Babbage.Tx (AlonzoTx AlonzoEra -> Tx AlonzoEra)
-> (WrapTx AlonzoEra -> AlonzoTx AlonzoEra)
-> WrapTx AlonzoEra
-> Tx AlonzoEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx AlonzoEra -> Tx AlonzoEra
WrapTx AlonzoEra -> AlonzoTx AlonzoEra
forall era. WrapTx era -> Tx era
unwrapTx

instance Core.TranslateEra ConwayEra WrapTx where
  type TranslationError ConwayEra WrapTx = Core.TranslationError ConwayEra Conway.Tx
  translateEra :: TranslationContext ConwayEra
-> WrapTx (PreviousEra ConwayEra)
-> Except (TranslationError ConwayEra WrapTx) (WrapTx ConwayEra)
translateEra TranslationContext ConwayEra
ctxt =
        (Tx ConwayEra -> WrapTx ConwayEra)
-> ExceptT DecoderError Identity (Tx ConwayEra)
-> ExceptT DecoderError Identity (WrapTx ConwayEra)
forall a b.
(a -> b)
-> ExceptT DecoderError Identity a
-> ExceptT DecoderError Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tx ConwayEra -> WrapTx ConwayEra
AlonzoTx ConwayEra -> WrapTx ConwayEra
forall era. Tx era -> WrapTx era
WrapTx (AlonzoTx ConwayEra -> WrapTx ConwayEra)
-> (Tx ConwayEra -> AlonzoTx ConwayEra)
-> Tx ConwayEra
-> WrapTx ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx ConwayEra -> Tx ConwayEra
Tx ConwayEra -> AlonzoTx ConwayEra
forall era. Tx era -> Tx era
Conway.unTx)
      (ExceptT DecoderError Identity (Tx ConwayEra)
 -> ExceptT DecoderError Identity (WrapTx ConwayEra))
-> (WrapTx BabbageEra
    -> ExceptT DecoderError Identity (Tx ConwayEra))
-> WrapTx BabbageEra
-> ExceptT DecoderError Identity (WrapTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
Core.translateEra @ConwayEra TranslationContext ConwayEra
ctxt
      (Tx BabbageEra -> ExceptT DecoderError Identity (Tx ConwayEra))
-> (WrapTx BabbageEra -> Tx BabbageEra)
-> WrapTx BabbageEra
-> ExceptT DecoderError Identity (Tx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx BabbageEra -> Tx BabbageEra
AlonzoTx BabbageEra -> Tx BabbageEra
forall era. Tx era -> Tx era
Conway.Tx (AlonzoTx BabbageEra -> Tx BabbageEra)
-> (WrapTx BabbageEra -> AlonzoTx BabbageEra)
-> WrapTx BabbageEra
-> Tx BabbageEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx BabbageEra -> Tx BabbageEra
WrapTx BabbageEra -> AlonzoTx BabbageEra
forall era. WrapTx era -> Tx era
unwrapTx