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

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 (..)
    -- * Type synonyms for convenience
  , EraCrypto
    -- * Convenience functions
  , isBeforeConway
    -- * Re-exports
  , StandardCrypto
  ) where

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.Crypto (StandardCrypto)
import           Cardano.Ledger.Keys (DSignable, Hash)
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 qualified Ouroboros.Consensus.Protocol.Praos as Praos

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

-- | The Shelley era with standard crypto
type StandardShelley = ShelleyEra StandardCrypto

-- | The Allegra era with standard crypto
type StandardAllegra = AllegraEra StandardCrypto

-- | The Mary era with standard crypto
type StandardMary = MaryEra StandardCrypto

-- | The Alonzo era with standard crypto
type StandardAlonzo = AlonzoEra StandardCrypto

-- | The Babbage era with standard crypto
type StandardBabbage = BabbageEra StandardCrypto

-- | The Conway era with standard crypto
type StandardConway = ConwayEra 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.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))

      , DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)
      , NoThunks (PredicateFailure (Core.EraRule "BBODY" era))
      , NoThunks (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 (L.EraCrypto era))

-- | 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 = do
    Globals
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> Except (ApplyTxError era) (LedgerState era, Validated (Tx era))
forall era (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m) =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> m (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 (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
  => ShelleyBasedEra (ShelleyEra c) where
  applyShelleyBasedTx :: Globals
-> LedgerEnv (ShelleyEra c)
-> LedgerState (ShelleyEra c)
-> WhetherToIntervene
-> Tx (ShelleyEra c)
-> Except
     (ApplyTxError (ShelleyEra c))
     (LedgerState (ShelleyEra c), Validated (Tx (ShelleyEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (ShelleyEra c)
-> LedgerState (ShelleyEra c)
-> WhetherToIntervene
-> Tx (ShelleyEra c)
-> Except
     (ApplyTxError (ShelleyEra c))
     (LedgerState (ShelleyEra c), Validated (Tx (ShelleyEra c)))
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 c) -> Maybe (ConwayEraGovDict (ShelleyEra c))
getConwayEraGovDict = proxy (ShelleyEra c) -> Maybe (ConwayEraGovDict (ShelleyEra c))
forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict

instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
  => ShelleyBasedEra (AllegraEra c) where
  applyShelleyBasedTx :: Globals
-> LedgerEnv (AllegraEra c)
-> LedgerState (AllegraEra c)
-> WhetherToIntervene
-> Tx (AllegraEra c)
-> Except
     (ApplyTxError (AllegraEra c))
     (LedgerState (AllegraEra c), Validated (Tx (AllegraEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (AllegraEra c)
-> LedgerState (AllegraEra c)
-> WhetherToIntervene
-> Tx (AllegraEra c)
-> Except
     (ApplyTxError (AllegraEra c))
     (LedgerState (AllegraEra c), Validated (Tx (AllegraEra c)))
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 c) -> Maybe (ConwayEraGovDict (AllegraEra c))
getConwayEraGovDict = proxy (AllegraEra c) -> Maybe (ConwayEraGovDict (AllegraEra c))
forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict

instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
  => ShelleyBasedEra (MaryEra c) where
  applyShelleyBasedTx :: Globals
-> LedgerEnv (MaryEra c)
-> LedgerState (MaryEra c)
-> WhetherToIntervene
-> Tx (MaryEra c)
-> Except
     (ApplyTxError (MaryEra c))
     (LedgerState (MaryEra c), Validated (Tx (MaryEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (MaryEra c)
-> LedgerState (MaryEra c)
-> WhetherToIntervene
-> Tx (MaryEra c)
-> Except
     (ApplyTxError (MaryEra c))
     (LedgerState (MaryEra c), Validated (Tx (MaryEra c)))
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 c) -> Maybe (ConwayEraGovDict (MaryEra c))
getConwayEraGovDict = proxy (MaryEra c) -> Maybe (ConwayEraGovDict (MaryEra c))
forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict

instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
  => ShelleyBasedEra (AlonzoEra c) where
  applyShelleyBasedTx :: Globals
-> LedgerEnv (AlonzoEra c)
-> LedgerState (AlonzoEra c)
-> WhetherToIntervene
-> Tx (AlonzoEra c)
-> Except
     (ApplyTxError (AlonzoEra c))
     (LedgerState (AlonzoEra c), Validated (Tx (AlonzoEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (AlonzoEra c)
-> LedgerState (AlonzoEra c)
-> WhetherToIntervene
-> Tx (AlonzoEra c)
-> Except
     (ApplyTxError (AlonzoEra c))
     (LedgerState (AlonzoEra c), Validated (Tx (AlonzoEra c)))
Globals
-> LedgerEnv (AlonzoEra c)
-> LedgerState (AlonzoEra c)
-> WhetherToIntervene
-> AlonzoTx (AlonzoEra c)
-> Except
     (ApplyTxError (AlonzoEra c))
     (LedgerState (AlonzoEra c), Validated (AlonzoTx (AlonzoEra c)))
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 c) -> Maybe (ConwayEraGovDict (AlonzoEra c))
getConwayEraGovDict = proxy (AlonzoEra c) -> Maybe (ConwayEraGovDict (AlonzoEra c))
forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict

instance (Praos.PraosCrypto c) => ShelleyBasedEra (BabbageEra c) where
  applyShelleyBasedTx :: Globals
-> LedgerEnv (BabbageEra c)
-> LedgerState (BabbageEra c)
-> WhetherToIntervene
-> Tx (BabbageEra c)
-> Except
     (ApplyTxError (BabbageEra c))
     (LedgerState (BabbageEra c), Validated (Tx (BabbageEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (BabbageEra c)
-> LedgerState (BabbageEra c)
-> WhetherToIntervene
-> Tx (BabbageEra c)
-> Except
     (ApplyTxError (BabbageEra c))
     (LedgerState (BabbageEra c), Validated (Tx (BabbageEra c)))
Globals
-> LedgerEnv (BabbageEra c)
-> LedgerState (BabbageEra c)
-> WhetherToIntervene
-> AlonzoTx (BabbageEra c)
-> Except
     (ApplyTxError (BabbageEra c))
     (LedgerState (BabbageEra c), Validated (AlonzoTx (BabbageEra c)))
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 c) -> Maybe (ConwayEraGovDict (BabbageEra c))
getConwayEraGovDict = proxy (BabbageEra c) -> Maybe (ConwayEraGovDict (BabbageEra c))
forall (proxy :: * -> *) era.
proxy era -> Maybe (ConwayEraGovDict era)
defaultGetConwayEraGovDict

instance (Praos.PraosCrypto c) => ShelleyBasedEra (ConwayEra c) where
  applyShelleyBasedTx :: Globals
-> LedgerEnv (ConwayEra c)
-> LedgerState (ConwayEra c)
-> WhetherToIntervene
-> Tx (ConwayEra c)
-> Except
     (ApplyTxError (ConwayEra c))
     (LedgerState (ConwayEra c), Validated (Tx (ConwayEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (ConwayEra c)
-> LedgerState (ConwayEra c)
-> WhetherToIntervene
-> Tx (ConwayEra c)
-> Except
     (ApplyTxError (ConwayEra c))
     (LedgerState (ConwayEra c), Validated (Tx (ConwayEra c)))
Globals
-> LedgerEnv (ConwayEra c)
-> LedgerState (ConwayEra c)
-> WhetherToIntervene
-> AlonzoTx (ConwayEra c)
-> Except
     (ApplyTxError (ConwayEra c))
     (LedgerState (ConwayEra c), Validated (AlonzoTx (ConwayEra c)))
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 c) -> Maybe (ConwayEraGovDict (ConwayEra c))
getConwayEraGovDict proxy (ConwayEra c)
_ = ConwayEraGovDict (ConwayEra c)
-> Maybe (ConwayEraGovDict (ConwayEra c))
forall a. a -> Maybe a
Just ConwayEraGovDict (ConwayEra c)
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 c) where
  isIncorrectClaimedFlag :: forall (proxy :: * -> *).
proxy (AlonzoEra c)
-> PredicateFailure (EraRule "LEDGER" (AlonzoEra c)) -> Bool
isIncorrectClaimedFlag proxy (AlonzoEra c)
_ = \case
    SL.UtxowFailure
      ( Alonzo.ShelleyInAlonzoUtxowPredFailure
          ( SL.UtxoFailure
              ( Alonzo.UtxosFailure
                  ( Alonzo.ValidationTagMismatch
                      (Alonzo.IsValid Bool
_claimedFlag)
                      TagMismatchDescription
_validationErrs
                    )
                )
            )
        ) ->
        Bool
True
    PredicateFailure (EraRule "LEDGER" (AlonzoEra c))
_ -> Bool
False

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

instance SupportsTwoPhaseValidation (ConwayEra c) where
  isIncorrectClaimedFlag :: forall (proxy :: * -> *).
proxy (ConwayEra c)
-> PredicateFailure (EraRule "LEDGER" (ConwayEra c)) -> Bool
isIncorrectClaimedFlag proxy (ConwayEra c)
_ = \case
    SL.ConwayUtxowFailure
      ( Conway.UtxoFailure
              ( Conway.UtxosFailure
                  ( Conway.ValidationTagMismatch
                      (Alonzo.IsValid Bool
_claimedFlag)
                      TagMismatchDescription
_validationErrs
                  )
              )
      ) -> Bool
True
    PredicateFailure (EraRule "LEDGER" (ConwayEra c))
_ -> 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 ShelleyBasedEra (AllegraEra c) => Core.TranslateEra (AllegraEra c) WrapTx where
  type TranslationError (AllegraEra c) WrapTx = Core.TranslationError (AllegraEra c) SL.ShelleyTx
  translateEra :: TranslationContext (AllegraEra c)
-> WrapTx (PreviousEra (AllegraEra c))
-> Except
     (TranslationError (AllegraEra c) WrapTx) (WrapTx (AllegraEra c))
translateEra TranslationContext (AllegraEra c)
ctxt = (ShelleyTx (AllegraEra c) -> WrapTx (AllegraEra c))
-> ExceptT DecoderError Identity (ShelleyTx (AllegraEra c))
-> ExceptT DecoderError Identity (WrapTx (AllegraEra c))
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 c) -> WrapTx (AllegraEra c)
ShelleyTx (AllegraEra c) -> WrapTx (AllegraEra c)
forall era. Tx era -> WrapTx era
WrapTx (ExceptT DecoderError Identity (ShelleyTx (AllegraEra c))
 -> ExceptT DecoderError Identity (WrapTx (AllegraEra c)))
-> (WrapTx (ShelleyEra c)
    -> ExceptT DecoderError Identity (ShelleyTx (AllegraEra c)))
-> WrapTx (ShelleyEra c)
-> ExceptT DecoderError Identity (WrapTx (AllegraEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext (AllegraEra c)
-> ShelleyTx (PreviousEra (AllegraEra c))
-> Except
     (TranslationError (AllegraEra c) ShelleyTx)
     (ShelleyTx (AllegraEra c))
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
Core.translateEra TranslationContext (AllegraEra c)
ctxt (ShelleyTx (ShelleyEra c)
 -> ExceptT DecoderError Identity (ShelleyTx (AllegraEra c)))
-> (WrapTx (ShelleyEra c) -> ShelleyTx (ShelleyEra c))
-> WrapTx (ShelleyEra c)
-> ExceptT DecoderError Identity (ShelleyTx (AllegraEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx (ShelleyEra c) -> Tx (ShelleyEra c)
WrapTx (ShelleyEra c) -> ShelleyTx (ShelleyEra c)
forall era. WrapTx era -> Tx era
unwrapTx

instance ShelleyBasedEra (MaryEra c) => Core.TranslateEra (MaryEra c) WrapTx where
  type TranslationError (MaryEra c) WrapTx = Core.TranslationError (MaryEra c) SL.ShelleyTx
  translateEra :: TranslationContext (MaryEra c)
-> WrapTx (PreviousEra (MaryEra c))
-> Except
     (TranslationError (MaryEra c) WrapTx) (WrapTx (MaryEra c))
translateEra TranslationContext (MaryEra c)
ctxt = (ShelleyTx (MaryEra c) -> WrapTx (MaryEra c))
-> ExceptT DecoderError Identity (ShelleyTx (MaryEra c))
-> ExceptT DecoderError Identity (WrapTx (MaryEra c))
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 c) -> WrapTx (MaryEra c)
ShelleyTx (MaryEra c) -> WrapTx (MaryEra c)
forall era. Tx era -> WrapTx era
WrapTx (ExceptT DecoderError Identity (ShelleyTx (MaryEra c))
 -> ExceptT DecoderError Identity (WrapTx (MaryEra c)))
-> (WrapTx (AllegraEra c)
    -> ExceptT DecoderError Identity (ShelleyTx (MaryEra c)))
-> WrapTx (AllegraEra c)
-> ExceptT DecoderError Identity (WrapTx (MaryEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext (MaryEra c)
-> ShelleyTx (PreviousEra (MaryEra c))
-> Except
     (TranslationError (MaryEra c) ShelleyTx) (ShelleyTx (MaryEra c))
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
Core.translateEra TranslationContext (MaryEra c)
ctxt (ShelleyTx (AllegraEra c)
 -> ExceptT DecoderError Identity (ShelleyTx (MaryEra c)))
-> (WrapTx (AllegraEra c) -> ShelleyTx (AllegraEra c))
-> WrapTx (AllegraEra c)
-> ExceptT DecoderError Identity (ShelleyTx (MaryEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx (AllegraEra c) -> Tx (AllegraEra c)
WrapTx (AllegraEra c) -> ShelleyTx (AllegraEra c)
forall era. WrapTx era -> Tx era
unwrapTx

instance ShelleyBasedEra (AlonzoEra c) => Core.TranslateEra (AlonzoEra c) WrapTx where
  type TranslationError (AlonzoEra c) WrapTx = Core.TranslationError (AlonzoEra c) Alonzo.Tx
  translateEra :: TranslationContext (AlonzoEra c)
-> WrapTx (PreviousEra (AlonzoEra c))
-> Except
     (TranslationError (AlonzoEra c) WrapTx) (WrapTx (AlonzoEra c))
translateEra TranslationContext (AlonzoEra c)
ctxt =
        (Tx (AlonzoEra c) -> WrapTx (AlonzoEra c))
-> ExceptT DecoderError Identity (Tx (AlonzoEra c))
-> ExceptT DecoderError Identity (WrapTx (AlonzoEra c))
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 c) -> WrapTx (AlonzoEra c)
AlonzoTx (AlonzoEra c) -> WrapTx (AlonzoEra c)
forall era. Tx era -> WrapTx era
WrapTx (AlonzoTx (AlonzoEra c) -> WrapTx (AlonzoEra c))
-> (Tx (AlonzoEra c) -> AlonzoTx (AlonzoEra c))
-> Tx (AlonzoEra c)
-> WrapTx (AlonzoEra c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (AlonzoEra c) -> Tx (AlonzoEra c)
Tx (AlonzoEra c) -> AlonzoTx (AlonzoEra c)
forall era. Tx era -> Tx era
Alonzo.unTx)
      (ExceptT DecoderError Identity (Tx (AlonzoEra c))
 -> ExceptT DecoderError Identity (WrapTx (AlonzoEra c)))
-> (WrapTx (MaryEra c)
    -> ExceptT DecoderError Identity (Tx (AlonzoEra c)))
-> WrapTx (MaryEra c)
-> ExceptT DecoderError Identity (WrapTx (AlonzoEra c))
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 c) TranslationContext (AlonzoEra c)
ctxt
      (Tx (MaryEra c)
 -> ExceptT DecoderError Identity (Tx (AlonzoEra c)))
-> (WrapTx (MaryEra c) -> Tx (MaryEra c))
-> WrapTx (MaryEra c)
-> ExceptT DecoderError Identity (Tx (AlonzoEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (MaryEra c) -> Tx (MaryEra c)
ShelleyTx (MaryEra c) -> Tx (MaryEra c)
forall era. Tx era -> Tx era
Alonzo.Tx (ShelleyTx (MaryEra c) -> Tx (MaryEra c))
-> (WrapTx (MaryEra c) -> ShelleyTx (MaryEra c))
-> WrapTx (MaryEra c)
-> Tx (MaryEra c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx (MaryEra c) -> Tx (MaryEra c)
WrapTx (MaryEra c) -> ShelleyTx (MaryEra c)
forall era. WrapTx era -> Tx era
unwrapTx

instance ShelleyBasedEra (BabbageEra c) => Core.TranslateEra (BabbageEra c) WrapTx where
  type TranslationError (BabbageEra c) WrapTx = Core.TranslationError (BabbageEra c) Babbage.Tx
  translateEra :: TranslationContext (BabbageEra c)
-> WrapTx (PreviousEra (BabbageEra c))
-> Except
     (TranslationError (BabbageEra c) WrapTx) (WrapTx (BabbageEra c))
translateEra TranslationContext (BabbageEra c)
ctxt =
        (Tx (BabbageEra c) -> WrapTx (BabbageEra c))
-> ExceptT DecoderError Identity (Tx (BabbageEra c))
-> ExceptT DecoderError Identity (WrapTx (BabbageEra c))
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 c) -> WrapTx (BabbageEra c)
AlonzoTx (BabbageEra c) -> WrapTx (BabbageEra c)
forall era. Tx era -> WrapTx era
WrapTx (AlonzoTx (BabbageEra c) -> WrapTx (BabbageEra c))
-> (Tx (BabbageEra c) -> AlonzoTx (BabbageEra c))
-> Tx (BabbageEra c)
-> WrapTx (BabbageEra c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (BabbageEra c) -> Tx (BabbageEra c)
Tx (BabbageEra c) -> AlonzoTx (BabbageEra c)
forall era. Tx era -> Tx era
Babbage.unTx)
      (ExceptT DecoderError Identity (Tx (BabbageEra c))
 -> ExceptT DecoderError Identity (WrapTx (BabbageEra c)))
-> (WrapTx (AlonzoEra c)
    -> ExceptT DecoderError Identity (Tx (BabbageEra c)))
-> WrapTx (AlonzoEra c)
-> ExceptT DecoderError Identity (WrapTx (BabbageEra c))
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 c) TranslationContext (BabbageEra c)
ctxt
      (Tx (AlonzoEra c)
 -> ExceptT DecoderError Identity (Tx (BabbageEra c)))
-> (WrapTx (AlonzoEra c) -> Tx (AlonzoEra c))
-> WrapTx (AlonzoEra c)
-> ExceptT DecoderError Identity (Tx (BabbageEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (AlonzoEra c) -> Tx (AlonzoEra c)
AlonzoTx (AlonzoEra c) -> Tx (AlonzoEra c)
forall era. Tx era -> Tx era
Babbage.Tx (AlonzoTx (AlonzoEra c) -> Tx (AlonzoEra c))
-> (WrapTx (AlonzoEra c) -> AlonzoTx (AlonzoEra c))
-> WrapTx (AlonzoEra c)
-> Tx (AlonzoEra c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx (AlonzoEra c) -> Tx (AlonzoEra c)
WrapTx (AlonzoEra c) -> AlonzoTx (AlonzoEra c)
forall era. WrapTx era -> Tx era
unwrapTx

instance ShelleyBasedEra (ConwayEra c) => Core.TranslateEra (ConwayEra c) WrapTx where
  type TranslationError (ConwayEra c) WrapTx = Core.TranslationError (ConwayEra c) Conway.Tx
  translateEra :: TranslationContext (ConwayEra c)
-> WrapTx (PreviousEra (ConwayEra c))
-> Except
     (TranslationError (ConwayEra c) WrapTx) (WrapTx (ConwayEra c))
translateEra TranslationContext (ConwayEra c)
ctxt =
        (Tx (ConwayEra c) -> WrapTx (ConwayEra c))
-> ExceptT DecoderError Identity (Tx (ConwayEra c))
-> ExceptT DecoderError Identity (WrapTx (ConwayEra c))
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 c) -> WrapTx (ConwayEra c)
AlonzoTx (ConwayEra c) -> WrapTx (ConwayEra c)
forall era. Tx era -> WrapTx era
WrapTx (AlonzoTx (ConwayEra c) -> WrapTx (ConwayEra c))
-> (Tx (ConwayEra c) -> AlonzoTx (ConwayEra c))
-> Tx (ConwayEra c)
-> WrapTx (ConwayEra c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (ConwayEra c) -> Tx (ConwayEra c)
Tx (ConwayEra c) -> AlonzoTx (ConwayEra c)
forall era. Tx era -> Tx era
Conway.unTx)
      (ExceptT DecoderError Identity (Tx (ConwayEra c))
 -> ExceptT DecoderError Identity (WrapTx (ConwayEra c)))
-> (WrapTx (BabbageEra c)
    -> ExceptT DecoderError Identity (Tx (ConwayEra c)))
-> WrapTx (BabbageEra c)
-> ExceptT DecoderError Identity (WrapTx (ConwayEra c))
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 c) TranslationContext (ConwayEra c)
ctxt
      (Tx (BabbageEra c)
 -> ExceptT DecoderError Identity (Tx (ConwayEra c)))
-> (WrapTx (BabbageEra c) -> Tx (BabbageEra c))
-> WrapTx (BabbageEra c)
-> ExceptT DecoderError Identity (Tx (ConwayEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (BabbageEra c) -> Tx (BabbageEra c)
AlonzoTx (BabbageEra c) -> Tx (BabbageEra c)
forall era. Tx era -> Tx era
Conway.Tx (AlonzoTx (BabbageEra c) -> Tx (BabbageEra c))
-> (WrapTx (BabbageEra c) -> AlonzoTx (BabbageEra c))
-> WrapTx (BabbageEra c)
-> Tx (BabbageEra c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx (BabbageEra c) -> Tx (BabbageEra c)
WrapTx (BabbageEra c) -> AlonzoTx (BabbageEra c)
forall era. WrapTx era -> Tx era
unwrapTx