{-# LANGUAGE AllowAmbiguousTypes     #-}
{-# LANGUAGE DataKinds               #-}
{-# LANGUAGE DeriveAnyClass          #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE OverloadedStrings       #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE TypeApplications        #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE UndecidableInstances    #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Ouroboros.Consensus.Shelley.Eras (
    -- * Eras based on the Shelley ledger
    AllegraEra
  , AlonzoEra
  , BabbageEra
  , MaryEra
  , ShelleyEra
    -- * Eras instantiated with standard crypto
  , StandardAllegra
  , StandardAlonzo
  , StandardBabbage
  , StandardMary
  , StandardShelley
    -- * Shelley-based era
  , ShelleyBasedEra (..)
  , WrapTx (..)
    -- * Type synonyms for convenience
  , EraCrypto
    -- * Re-exports
  , StandardCrypto
    -- * Exceptions
  , UnexpectedAlonzoLedgerErrors
  ) where

import           Control.Exception (Exception, throw)
import           Control.Monad.Except
import           Data.Default.Class (Default)
import qualified Data.Set as Set
import           Data.Text (Text)
import           GHC.Records
import           NoThunks.Class (NoThunks)
import           Numeric.Natural (Natural)

import           Cardano.Binary (Annotator, FromCBOR, ToCBOR)

import           Cardano.Ledger.Allegra (AllegraEra)
import           Cardano.Ledger.Allegra.Translation ()
import           Cardano.Ledger.Alonzo (AlonzoEra)
import           Cardano.Ledger.Alonzo.PParams
import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo
import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo
import qualified Cardano.Ledger.Alonzo.Rules.Utxow as Alonzo
import qualified Cardano.Ledger.Alonzo.Translation as Alonzo
import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
import           Cardano.Ledger.Babbage (BabbageEra)
import           Cardano.Ledger.Babbage.PParams (PParams' (..))
import qualified Cardano.Ledger.Babbage.Rules.Utxo as Babbage
import qualified Cardano.Ledger.Babbage.Rules.Utxow as Babbage
import qualified Cardano.Ledger.Babbage.Translation as Babbage
import           Cardano.Ledger.BaseTypes
import qualified Cardano.Ledger.Core as Core
import           Cardano.Ledger.Crypto (StandardCrypto)
import           Cardano.Ledger.Era (Crypto, SupportsSegWit (..))
import qualified Cardano.Ledger.Era as Core
import           Cardano.Ledger.Hashes (EraIndependentTxBody)
import           Cardano.Ledger.Keys (DSignable, Hash)
import           Cardano.Ledger.Mary (MaryEra)
import           Cardano.Ledger.Mary.Translation ()
import           Cardano.Ledger.Serialization
import           Cardano.Ledger.Shelley (ShelleyEra)
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.Rules.Ledger as SL
import qualified Cardano.Ledger.Shelley.Rules.Utxow as SL
import           Cardano.Ledger.ShelleyMA ()
import qualified Cardano.Protocol.TPraos.API as SL
import           Control.State.Transition (State)
import           Data.Data (Proxy (Proxy))
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

{-------------------------------------------------------------------------------
  Type synonyms for convenience
-------------------------------------------------------------------------------}

-- | The 'Cardano.Ledger.Era.Crypto' type family conflicts with the
-- 'Cardano.Ledger.Crypto.Crypto' class. To avoid having to import one or both
-- of them qualified, define 'EraCrypto' as an alias of the former: /return the
-- crypto used by this era/.
type EraCrypto era = Crypto era

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

-- | The ledger already defines 'SL.ShelleyBasedEra' as /the/ top-level
-- constraint on an era, however, 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.
--
-- By having the same name as the class defined in ledger, we can, if this class
-- becomes redundant, switch to the ledger-defined one without having to update
-- all the code using it. We can just export the right one from this module.
--
-- 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/input-output-hk/ouroboros-network/issues/2890
class ( SL.ShelleyBasedEra 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

      , State (Core.EraRule "PPUP" era) ~ SL.PPUPState era
      , Default (State (Core.EraRule "PPUP" era))

      , HasField "_maxBBSize" (Core.PParams era) Natural
      , HasField "_maxBHSize" (Core.PParams era) Natural
      , HasField "_maxTxSize" (Core.PParams era) Natural
      , HasField "_a0" (Core.PParams era) NonNegativeInterval
      , HasField "_nOpt" (Core.PParams era) Natural
      , HasField "_rho" (Core.PParams era) UnitInterval
      , HasField "_tau" (Core.PParams era) UnitInterval

      , Core.ValidateScript era

      , FromCBOR (Core.PParams era)
      , ToCBOR (Core.PParams era)

      , HasField "_protocolVersion" (Core.PParamsDelta era) (SL.StrictMaybe SL.ProtVer)
      , FromCBOR (Core.PParamsDelta era)

        -- TODO This constraint is a little weird. The translation context
        -- reflects things needed in comparison to the previous era, whereas the
        -- 'AdditionalGenesisConfig' is from Shelley. Ultimately we should drop
        -- this and potentially add a new API for dealing with the relationship
        -- between `GenesisConfig` and `TranslationContext`.
      , SL.AdditionalGenesisConfig era ~ Core.TranslationContext era
      , ToCBORGroup (TxSeq era)

      , NoThunks (Core.TranslationContext era)

      , FromCBOR (Annotator (Core.Witnesses era))
      , ToCBOR (Core.Witnesses era)

      , Eq (TxSeq era)
      , Show (TxSeq era)
      , FromCBOR (Annotator (TxSeq era))

      ) => ShelleyBasedEra era where

  -- | Return the name of the Shelley-based era, e.g., @"Shelley"@, @"Allegra"@,
  -- etc.
  shelleyBasedEraName :: proxy era -> Text

  applyShelleyBasedTx ::
       SL.Globals
    -> SL.LedgerEnv    era
    -> SL.MempoolState era
    -> WhetherToIntervene
    -> Core.Tx           era
    -> Except
         (SL.ApplyTxError era)
         ( SL.MempoolState era
         , SL.Validated (Core.Tx era)
         )

-- | The default implementation of 'applyShelleyBasedTx', a thin wrapper around
-- 'SL.applyTx'
defaultApplyShelleyBasedTx ::
     ShelleyBasedEra era
  => SL.Globals
  -> SL.LedgerEnv    era
  -> SL.MempoolState era
  -> WhetherToIntervene
  -> Core.Tx         era
  -> Except
       (SL.ApplyTxError era)
       ( SL.MempoolState era
       , SL.Validated (Core.Tx era)
       )
defaultApplyShelleyBasedTx :: Globals
-> LedgerEnv era
-> MempoolState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (MempoolState era, Validated (Tx era))
defaultApplyShelleyBasedTx Globals
globals LedgerEnv era
ledgerEnv MempoolState era
mempoolState WhetherToIntervene
_wti Tx era
tx =
    Globals
-> LedgerEnv era
-> MempoolState era
-> Tx era
-> Except (ApplyTxError era) (MempoolState 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
      MempoolState era
mempoolState
      Tx era
tx

instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
  => ShelleyBasedEra (ShelleyEra c) where
  shelleyBasedEraName :: proxy (ShelleyEra c) -> Text
shelleyBasedEraName proxy (ShelleyEra c)
_ = Text
"Shelley"

  applyShelleyBasedTx :: Globals
-> LedgerEnv (ShelleyEra c)
-> MempoolState (ShelleyEra c)
-> WhetherToIntervene
-> Tx (ShelleyEra c)
-> Except
     (ApplyTxError (ShelleyEra c))
     (MempoolState (ShelleyEra c), Validated (Tx (ShelleyEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (ShelleyEra c)
-> MempoolState (ShelleyEra c)
-> WhetherToIntervene
-> Tx (ShelleyEra c)
-> Except
     (ApplyTxError (ShelleyEra c))
     (MempoolState (ShelleyEra c), Validated (Tx (ShelleyEra c)))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> MempoolState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (MempoolState era, Validated (Tx era))
defaultApplyShelleyBasedTx

instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
  => ShelleyBasedEra (AllegraEra c) where
  shelleyBasedEraName :: proxy (AllegraEra c) -> Text
shelleyBasedEraName proxy (AllegraEra c)
_ = Text
"Allegra"

  applyShelleyBasedTx :: Globals
-> LedgerEnv (AllegraEra c)
-> MempoolState (AllegraEra c)
-> WhetherToIntervene
-> Tx (AllegraEra c)
-> Except
     (ApplyTxError (AllegraEra c))
     (MempoolState (AllegraEra c), Validated (Tx (AllegraEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (AllegraEra c)
-> MempoolState (AllegraEra c)
-> WhetherToIntervene
-> Tx (AllegraEra c)
-> Except
     (ApplyTxError (AllegraEra c))
     (MempoolState (AllegraEra c), Validated (Tx (AllegraEra c)))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> MempoolState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (MempoolState era, Validated (Tx era))
defaultApplyShelleyBasedTx

instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
  => ShelleyBasedEra (MaryEra c) where
  shelleyBasedEraName :: proxy (MaryEra c) -> Text
shelleyBasedEraName proxy (MaryEra c)
_ = Text
"Mary"

  applyShelleyBasedTx :: Globals
-> LedgerEnv (MaryEra c)
-> MempoolState (MaryEra c)
-> WhetherToIntervene
-> Tx (MaryEra c)
-> Except
     (ApplyTxError (MaryEra c))
     (MempoolState (MaryEra c), Validated (Tx (MaryEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (MaryEra c)
-> MempoolState (MaryEra c)
-> WhetherToIntervene
-> Tx (MaryEra c)
-> Except
     (ApplyTxError (MaryEra c))
     (MempoolState (MaryEra c), Validated (Tx (MaryEra c)))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> MempoolState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (MempoolState era, Validated (Tx era))
defaultApplyShelleyBasedTx

instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
  => ShelleyBasedEra (AlonzoEra c) where
  shelleyBasedEraName :: proxy (AlonzoEra c) -> Text
shelleyBasedEraName proxy (AlonzoEra c)
_ = Text
"Alonzo"

  applyShelleyBasedTx :: Globals
-> LedgerEnv (AlonzoEra c)
-> MempoolState (AlonzoEra c)
-> WhetherToIntervene
-> Tx (AlonzoEra c)
-> Except
     (ApplyTxError (AlonzoEra c))
     (MempoolState (AlonzoEra c), Validated (Tx (AlonzoEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (AlonzoEra c)
-> MempoolState (AlonzoEra c)
-> WhetherToIntervene
-> Tx (AlonzoEra c)
-> Except
     (ApplyTxError (AlonzoEra c))
     (MempoolState (AlonzoEra c), Validated (Tx (AlonzoEra c)))
forall era.
(ShelleyBasedEra era, SupportsTwoPhaseValidation era,
 Tx era ~ ValidatedTx era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> ValidatedTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
applyAlonzoBasedTx

instance (Praos.PraosCrypto c) => ShelleyBasedEra (BabbageEra c) where
  shelleyBasedEraName :: proxy (BabbageEra c) -> Text
shelleyBasedEraName proxy (BabbageEra c)
_ = Text
"Babbage"
  applyShelleyBasedTx :: Globals
-> LedgerEnv (BabbageEra c)
-> MempoolState (BabbageEra c)
-> WhetherToIntervene
-> Tx (BabbageEra c)
-> Except
     (ApplyTxError (BabbageEra c))
     (MempoolState (BabbageEra c), Validated (Tx (BabbageEra c)))
applyShelleyBasedTx = Globals
-> LedgerEnv (BabbageEra c)
-> MempoolState (BabbageEra c)
-> WhetherToIntervene
-> Tx (BabbageEra c)
-> Except
     (ApplyTxError (BabbageEra c))
     (MempoolState (BabbageEra c), Validated (Tx (BabbageEra c)))
forall era.
(ShelleyBasedEra era, SupportsTwoPhaseValidation era,
 Tx era ~ ValidatedTx era) =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> ValidatedTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
applyAlonzoBasedTx

applyAlonzoBasedTx :: forall era.
  ( ShelleyBasedEra era,
    SupportsTwoPhaseValidation era,
    Core.Tx era ~ Alonzo.ValidatedTx era
  ) =>
  Globals ->
  SL.LedgerEnv era ->
  SL.LedgerState era ->
  WhetherToIntervene ->
  Alonzo.ValidatedTx era ->
  Except
    (SL.ApplyTxError era)
    ( SL.LedgerState era,
      SL.Validated (Alonzo.ValidatedTx era)
    )
applyAlonzoBasedTx :: Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> ValidatedTx era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
applyAlonzoBasedTx Globals
globals LedgerEnv era
ledgerEnv LedgerState era
mempoolState WhetherToIntervene
wti ValidatedTx era
tx = do
      (LedgerState era
mempoolState', Validated (ValidatedTx era)
vtx) <-
          (Except
  (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
-> (ApplyTxError era
    -> Except
         (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era)))
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` ApplyTxError era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
handler)
        (Except
   (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
 -> Except
      (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era)))
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
forall a b. (a -> b) -> a -> b
$ Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (LedgerState era, Validated (Tx era))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> MempoolState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (MempoolState era, Validated (Tx era))
defaultApplyShelleyBasedTx
            Globals
globals
            LedgerEnv era
ledgerEnv
            LedgerState era
mempoolState
            WhetherToIntervene
wti
            Tx era
ValidatedTx era
tx

      (LedgerState era, Validated (ValidatedTx era))
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerState era
mempoolState', Validated (ValidatedTx era)
vtx)
    where
      nubOrd :: [Bool] -> [Bool]
nubOrd = Set Bool -> [Bool]
forall a. Set a -> [a]
Set.toList (Set Bool -> [Bool]) -> ([Bool] -> Set Bool) -> [Bool] -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Set Bool
forall a. Ord a => [a] -> Set a
Set.fromList

      handler :: ApplyTxError era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
handler ApplyTxError era
e = case (WhetherToIntervene
wti, ApplyTxError era
e) of
        (WhetherToIntervene
DoNotIntervene, SL.ApplyTxError [PredicateFailure (EraRule "LEDGER" era)]
errs)
          | Bool
flag:[Bool]
flags <- [Bool] -> [Bool]
nubOrd [Bool
b | Just Bool
b <- Proxy era -> PredicateFailure (EraRule "LEDGER" era) -> Maybe Bool
forall era (proxy :: * -> *).
SupportsTwoPhaseValidation era =>
proxy era -> PredicateFailure (EraRule "LEDGER" era) -> Maybe Bool
incorrectClaimedFlag (Proxy era
forall k (t :: k). Proxy t
Proxy @era) (LedgerPredicateFailure era -> Maybe Bool)
-> [LedgerPredicateFailure era] -> [Maybe Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LedgerPredicateFailure era]
[PredicateFailure (EraRule "LEDGER" era)]
errs] ->
            if Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bool]
flags)
            then UnexpectedAlonzoLedgerErrors
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
forall a e. Exception e => e -> a
throw (UnexpectedAlonzoLedgerErrors
 -> Except
      (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era)))
-> UnexpectedAlonzoLedgerErrors
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
forall a b. (a -> b) -> a -> b
$ [Bool] -> UnexpectedAlonzoLedgerErrors
UnexpectedAlonzoLedgerErrors (Bool
flagBool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
:[Bool]
flags)
            else
            -- 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
-> Except (ApplyTxError era) (LedgerState era, Validated (Tx era))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> MempoolState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (MempoolState era, Validated (Tx era))
defaultApplyShelleyBasedTx
              Globals
globals
              LedgerEnv era
ledgerEnv
              LedgerState era
mempoolState
              WhetherToIntervene
wti
              ValidatedTx era
tx{isValid :: IsValid
Alonzo.isValid = Bool -> IsValid
Alonzo.IsValid (Bool -> Bool
not Bool
flag)}
        (WhetherToIntervene, ApplyTxError era)
_ -> ApplyTxError era
-> Except
     (ApplyTxError era) (LedgerState era, Validated (ValidatedTx era))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ApplyTxError era
e
               -- reject the transaction, protecting the local wallet
-- not exported
--
-- The ledger failure we see when the transaction's claimed 'IsValid'
-- flag was incorrect

class SupportsTwoPhaseValidation era where
  incorrectClaimedFlag :: proxy era -> SL.PredicateFailure (Core.EraRule "LEDGER" era) -> Maybe Bool

instance SupportsTwoPhaseValidation (AlonzoEra c) where
  incorrectClaimedFlag :: proxy (AlonzoEra c)
-> PredicateFailure (EraRule "LEDGER" (AlonzoEra c)) -> Maybe Bool
incorrectClaimedFlag proxy (AlonzoEra c)
_ PredicateFailure (EraRule "LEDGER" (AlonzoEra c))
pf = case PredicateFailure (EraRule "LEDGER" (AlonzoEra c))
pf of
    SL.UtxowFailure
      ( Alonzo.WrappedShelleyEraFailure
          ( SL.UtxoFailure
              ( Alonzo.UtxosFailure
                  ( Alonzo.ValidationTagMismatch
                      (Alonzo.IsValid claimedFlag)
                      _validationErrs
                    )
                )
            )
        ) ->
        Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
claimedFlag
    PredicateFailure (EraRule "LEDGER" (AlonzoEra c))
_ -> Maybe Bool
forall a. Maybe a
Nothing

instance SupportsTwoPhaseValidation (BabbageEra c) where
  incorrectClaimedFlag :: proxy (BabbageEra c)
-> PredicateFailure (EraRule "LEDGER" (BabbageEra c)) -> Maybe Bool
incorrectClaimedFlag proxy (BabbageEra c)
_ PredicateFailure (EraRule "LEDGER" (BabbageEra c))
pf = case PredicateFailure (EraRule "LEDGER" (BabbageEra c))
pf of
    SL.UtxowFailure
      ( Babbage.FromAlonzoUtxowFail
          ( Alonzo.WrappedShelleyEraFailure
              ( SL.UtxoFailure
                  ( Babbage.FromAlonzoUtxoFail
                      ( Alonzo.UtxosFailure
                          ( Alonzo.ValidationTagMismatch
                              (Alonzo.IsValid claimedFlag)
                              _validationErrs
                            )
                        )
                    )
                )
            )
        ) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
claimedFlag
    PredicateFailure (EraRule "LEDGER" (BabbageEra c))
_ -> Maybe Bool
forall a. Maybe a
Nothing


-- | The ledger responded with Alonzo errors we were not expecting
data UnexpectedAlonzoLedgerErrors =
    -- | We received more than one 'Alonzo.ValidationTagMismatch'
    --
    -- The exception lists the 'Alonzo.IsValid' flags we saw.
    UnexpectedAlonzoLedgerErrors [Bool]
  deriving (Int -> UnexpectedAlonzoLedgerErrors -> ShowS
[UnexpectedAlonzoLedgerErrors] -> ShowS
UnexpectedAlonzoLedgerErrors -> String
(Int -> UnexpectedAlonzoLedgerErrors -> ShowS)
-> (UnexpectedAlonzoLedgerErrors -> String)
-> ([UnexpectedAlonzoLedgerErrors] -> ShowS)
-> Show UnexpectedAlonzoLedgerErrors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnexpectedAlonzoLedgerErrors] -> ShowS
$cshowList :: [UnexpectedAlonzoLedgerErrors] -> ShowS
show :: UnexpectedAlonzoLedgerErrors -> String
$cshow :: UnexpectedAlonzoLedgerErrors -> String
showsPrec :: Int -> UnexpectedAlonzoLedgerErrors -> ShowS
$cshowsPrec :: Int -> UnexpectedAlonzoLedgerErrors -> ShowS
Show, Show UnexpectedAlonzoLedgerErrors
Typeable UnexpectedAlonzoLedgerErrors
Typeable UnexpectedAlonzoLedgerErrors
-> Show UnexpectedAlonzoLedgerErrors
-> (UnexpectedAlonzoLedgerErrors -> SomeException)
-> (SomeException -> Maybe UnexpectedAlonzoLedgerErrors)
-> (UnexpectedAlonzoLedgerErrors -> String)
-> Exception UnexpectedAlonzoLedgerErrors
SomeException -> Maybe UnexpectedAlonzoLedgerErrors
UnexpectedAlonzoLedgerErrors -> String
UnexpectedAlonzoLedgerErrors -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: UnexpectedAlonzoLedgerErrors -> String
$cdisplayException :: UnexpectedAlonzoLedgerErrors -> String
fromException :: SomeException -> Maybe UnexpectedAlonzoLedgerErrors
$cfromException :: SomeException -> Maybe UnexpectedAlonzoLedgerErrors
toException :: UnexpectedAlonzoLedgerErrors -> SomeException
$ctoException :: UnexpectedAlonzoLedgerErrors -> SomeException
$cp2Exception :: Show UnexpectedAlonzoLedgerErrors
$cp1Exception :: Typeable UnexpectedAlonzoLedgerErrors
Exception)

{-------------------------------------------------------------------------------
  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 {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.Tx
  translateEra :: TranslationContext (AllegraEra c)
-> WrapTx (PreviousEra (AllegraEra c))
-> Except
     (TranslationError (AllegraEra c) WrapTx) (WrapTx (AllegraEra c))
translateEra TranslationContext (AllegraEra c)
ctxt = (Tx (AllegraEra c) -> WrapTx (AllegraEra c))
-> ExceptT DecoderError Identity (Tx (AllegraEra c))
-> ExceptT DecoderError Identity (WrapTx (AllegraEra c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tx (AllegraEra c) -> WrapTx (AllegraEra c)
forall era. Tx era -> WrapTx era
WrapTx (ExceptT DecoderError Identity (Tx (AllegraEra c))
 -> ExceptT DecoderError Identity (WrapTx (AllegraEra c)))
-> (WrapTx (ShelleyEra c)
    -> ExceptT DecoderError Identity (Tx (AllegraEra c)))
-> WrapTx (ShelleyEra c)
-> ExceptT DecoderError Identity (WrapTx (AllegraEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext (AllegraEra c)
-> Tx (PreviousEra (AllegraEra c))
-> Except (TranslationError (AllegraEra c) Tx) (Tx (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 (Tx (ShelleyEra c)
 -> ExceptT DecoderError Identity (Tx (AllegraEra c)))
-> (WrapTx (ShelleyEra c) -> Tx (ShelleyEra c))
-> WrapTx (ShelleyEra c)
-> ExceptT DecoderError Identity (Tx (AllegraEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx (ShelleyEra c) -> Tx (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.Tx
  translateEra :: TranslationContext (MaryEra c)
-> WrapTx (PreviousEra (MaryEra c))
-> Except
     (TranslationError (MaryEra c) WrapTx) (WrapTx (MaryEra c))
translateEra TranslationContext (MaryEra c)
ctxt = (Tx (MaryEra c) -> WrapTx (MaryEra c))
-> ExceptT DecoderError Identity (Tx (MaryEra c))
-> ExceptT DecoderError Identity (WrapTx (MaryEra c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tx (MaryEra c) -> WrapTx (MaryEra c)
forall era. Tx era -> WrapTx era
WrapTx (ExceptT DecoderError Identity (Tx (MaryEra c))
 -> ExceptT DecoderError Identity (WrapTx (MaryEra c)))
-> (WrapTx (ShelleyMAEra 'Allegra c)
    -> ExceptT DecoderError Identity (Tx (MaryEra c)))
-> WrapTx (ShelleyMAEra 'Allegra c)
-> ExceptT DecoderError Identity (WrapTx (MaryEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext (MaryEra c)
-> Tx (PreviousEra (MaryEra c))
-> Except (TranslationError (MaryEra c) Tx) (Tx (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 (Tx (ShelleyMAEra 'Allegra c)
 -> ExceptT DecoderError Identity (Tx (MaryEra c)))
-> (WrapTx (ShelleyMAEra 'Allegra c)
    -> Tx (ShelleyMAEra 'Allegra c))
-> WrapTx (ShelleyMAEra 'Allegra c)
-> ExceptT DecoderError Identity (Tx (MaryEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx (ShelleyMAEra 'Allegra c) -> Tx (ShelleyMAEra 'Allegra 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValidatedTx (AlonzoEra c) -> WrapTx (AlonzoEra c)
forall era. Tx era -> WrapTx era
WrapTx (ValidatedTx (AlonzoEra c) -> WrapTx (AlonzoEra c))
-> (Tx (AlonzoEra c) -> ValidatedTx (AlonzoEra c))
-> Tx (AlonzoEra c)
-> WrapTx (AlonzoEra c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (AlonzoEra c) -> ValidatedTx (AlonzoEra c)
forall era. Tx era -> Tx era
Alonzo.unTx)
      (ExceptT DecoderError Identity (Tx (AlonzoEra c))
 -> ExceptT DecoderError Identity (WrapTx (AlonzoEra c)))
-> (WrapTx (ShelleyMAEra 'Mary c)
    -> ExceptT DecoderError Identity (Tx (AlonzoEra c)))
-> WrapTx (ShelleyMAEra 'Mary c)
-> ExceptT DecoderError Identity (WrapTx (AlonzoEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext (AlonzoEra c)
-> Tx (PreviousEra (AlonzoEra c))
-> Except (TranslationError (AlonzoEra c) Tx) (Tx (AlonzoEra 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 (ShelleyMAEra 'Mary c)
 -> ExceptT DecoderError Identity (Tx (AlonzoEra c)))
-> (WrapTx (ShelleyMAEra 'Mary c) -> Tx (ShelleyMAEra 'Mary c))
-> WrapTx (ShelleyMAEra 'Mary c)
-> ExceptT DecoderError Identity (Tx (AlonzoEra c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (ShelleyMAEra 'Mary c) -> Tx (ShelleyMAEra 'Mary c)
forall era. Tx era -> Tx era
Alonzo.Tx (Tx (ShelleyMAEra 'Mary c) -> Tx (ShelleyMAEra 'Mary c))
-> (WrapTx (ShelleyMAEra 'Mary c) -> Tx (ShelleyMAEra 'Mary c))
-> WrapTx (ShelleyMAEra 'Mary c)
-> Tx (ShelleyMAEra 'Mary c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx (ShelleyMAEra 'Mary c) -> Tx (ShelleyMAEra 'Mary 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValidatedTx (BabbageEra c) -> WrapTx (BabbageEra c)
forall era. Tx era -> WrapTx era
WrapTx (ValidatedTx (BabbageEra c) -> WrapTx (BabbageEra c))
-> (Tx (BabbageEra c) -> ValidatedTx (BabbageEra c))
-> Tx (BabbageEra c)
-> WrapTx (BabbageEra c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (BabbageEra c) -> ValidatedTx (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
. TranslationContext (BabbageEra c)
-> Tx (PreviousEra (BabbageEra c))
-> Except (TranslationError (BabbageEra c) Tx) (Tx (BabbageEra 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
. ValidatedTx (AlonzoEra c) -> Tx (AlonzoEra c)
forall era. Tx era -> Tx era
Babbage.Tx (ValidatedTx (AlonzoEra c) -> Tx (AlonzoEra c))
-> (WrapTx (AlonzoEra c) -> ValidatedTx (AlonzoEra c))
-> WrapTx (AlonzoEra c)
-> Tx (AlonzoEra c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTx (AlonzoEra c) -> ValidatedTx (AlonzoEra c)
forall era. WrapTx era -> Tx era
unwrapTx