From dbfad9b94abc2615ef13a2d96acfc2fd759bb934 Mon Sep 17 00:00:00 2001 From: John Ky Date: Mon, 26 Jun 2023 14:04:53 +1000 Subject: [PATCH 1/2] New withShelleyBasedEraConstraintsForLedger replacing a number of locally defined functions for introducing ledger constraints for shelley based era. --- cardano-api/internal/Cardano/Api/Eras.hs | 23 +++++++++++ cardano-api/internal/Cardano/Api/Fees.hs | 36 ++++------------ .../internal/Cardano/Api/LedgerState.hs | 15 +------ cardano-api/internal/Cardano/Api/TxBody.hs | 41 ++----------------- 4 files changed, 35 insertions(+), 80 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index 4d181a1bc8..5b1c06577b 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -52,6 +54,8 @@ module Cardano.Api.Eras -- * Assertions on era , requireShelleyBasedEra + + , withShelleyBasedEraConstraintsForLedger ) where import Cardano.Api.HasTypeProxy @@ -535,3 +539,22 @@ requireShelleyBasedEra era = case cardanoEraStyle era of LegacyByronEra -> pure Nothing ShelleyBasedEra sbe -> pure (Just sbe) + +withShelleyBasedEraConstraintsForLedger :: () + => ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> ( () + => L.EraCrypto ledgerera ~ L.StandardCrypto + => L.EraTx ledgerera + => L.EraTxBody ledgerera + => L.Era ledgerera + => a + ) + -> a +withShelleyBasedEraConstraintsForLedger = \case + ShelleyBasedEraShelley -> id + ShelleyBasedEraAllegra -> id + ShelleyBasedEraMary -> id + ShelleyBasedEraAlonzo -> id + ShelleyBasedEraBabbage -> id + ShelleyBasedEraConway -> id diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index af39b175cd..41e145e865 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -111,22 +112,12 @@ transactionFee txFeeFixed txFeePerByte tx = let a = toInteger txFeePerByte b = toInteger txFeeFixed in case tx of - ShelleyTx _ tx' -> let x = obtainEraTx shelleyBasedEra $ tx' ^. L.sizeTxF - in Lovelace (a * x + b) + ShelleyTx _ tx' -> + let x = withShelleyBasedEraConstraintsForLedger (shelleyBasedEra @era) $ tx' ^. L.sizeTxF + in Lovelace (a * x + b) --TODO: This can be made to work for Byron txs too. Do that: fill in this case -- and remove the IsShelleyBasedEra constraint. - ByronTx _ -> case shelleyBasedEra :: ShelleyBasedEra ByronEra of {} - where - obtainEraTx - :: ShelleyBasedEra era - -> (L.EraTx (ShelleyLedgerEra era) => a) - -> a - obtainEraTx ShelleyBasedEraShelley f = f - obtainEraTx ShelleyBasedEraAllegra f = f - obtainEraTx ShelleyBasedEraMary f = f - obtainEraTx ShelleyBasedEraAlonzo f = f - obtainEraTx ShelleyBasedEraBabbage f = f - obtainEraTx ShelleyBasedEraConway f = f + ByronTx _ -> case shelleyBasedEra @era of {} {-# DEPRECATED transactionFee "Use 'evaluateTransactionFee' instead" #-} @@ -201,7 +192,7 @@ estimateTransactionFee nw txFeeFixed txFeePerByte (ShelleyTx era tx) = --TODO: This can be made to work for Byron txs too. Do that: fill in this case -- and remove the IsShelleyBasedEra constraint. estimateTransactionFee _ _ _ (ByronTx _) = - case shelleyBasedEra :: ShelleyBasedEra era of {} + case shelleyBasedEra @era of {} --TODO: also deprecate estimateTransactionFee: --{-# DEPRECATED estimateTransactionFee "Use 'evaluateTransactionFee' instead" #-} @@ -228,7 +219,7 @@ evaluateTransactionFee bpparams txbody keywitcount _byronwitcount = ByronTx{} -> case shelleyBasedEra :: ShelleyBasedEra era of {} --TODO: we could actually support Byron here, it'd be different but simpler - ShelleyTx era tx -> withLedgerConstraints era (evalShelleyBasedEra tx) + ShelleyTx era tx -> withShelleyBasedEraConstraintsForLedger era (evalShelleyBasedEra tx) where evalShelleyBasedEra :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera @@ -242,19 +233,6 @@ evaluateTransactionFee bpparams txbody keywitcount _byronwitcount = tx keywitcount - -- Conjure up all the necessary class instances and evidence - withLedgerConstraints - :: ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> (L.EraTx ledgerera => a) - -> a - withLedgerConstraints ShelleyBasedEraShelley f = f - withLedgerConstraints ShelleyBasedEraAllegra f = f - withLedgerConstraints ShelleyBasedEraMary f = f - withLedgerConstraints ShelleyBasedEraAlonzo f = f - withLedgerConstraints ShelleyBasedEraBabbage f = f - withLedgerConstraints ShelleyBasedEraConway f = f - -- | Give an approximate count of the number of key witnesses (i.e. signatures) -- a transaction will need. -- diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 5a7c67805f..223b250c7c 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -1494,7 +1494,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr decodeCurrentEpochState sbe serCurrEpochState let snapshot :: ShelleyAPI.SnapShot Shelley.StandardCrypto - snapshot = ShelleyAPI.ssStakeMark $ obtainIsStandardCrypto sbe $ ShelleyAPI.esSnapshots cEstate + snapshot = ShelleyAPI.ssStakeMark $ withShelleyBasedEraConstraintsForLedger sbe $ ShelleyAPI.esSnapshots cEstate markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr $ snapshot @@ -1576,19 +1576,6 @@ isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey Right $ Set.filter isLeader slotRangeOfInterest -obtainIsStandardCrypto - :: ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> (Core.EraCrypto ledgerera ~ Shelley.StandardCrypto => a) - -> a -obtainIsStandardCrypto ShelleyBasedEraShelley f = f -obtainIsStandardCrypto ShelleyBasedEraAllegra f = f -obtainIsStandardCrypto ShelleyBasedEraMary f = f -obtainIsStandardCrypto ShelleyBasedEraAlonzo f = f -obtainIsStandardCrypto ShelleyBasedEraBabbage f = f -obtainIsStandardCrypto ShelleyBasedEraConway f = f - - -- | Return the slots at which a particular stake pool operator is -- expected to mint a block. currentEpochEligibleLeadershipSlots :: forall era. () diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 1f16dcc341..5df59c69cb 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -2286,18 +2286,7 @@ getTxId (ByronTxBody tx) = error "getTxId: byron and shelley hash sizes do not match" getTxId (ShelleyTxBody era tx _ _ _ _) = - obtainConstraints era $ getTxIdShelley era tx - where - obtainConstraints - :: ShelleyBasedEra era - -> ((Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto, Ledger.EraTxBody (ShelleyLedgerEra era)) => a) - -> a - obtainConstraints ShelleyBasedEraShelley f = f - obtainConstraints ShelleyBasedEraAllegra f = f - obtainConstraints ShelleyBasedEraMary f = f - obtainConstraints ShelleyBasedEraAlonzo f = f - obtainConstraints ShelleyBasedEraBabbage f = f - obtainConstraints ShelleyBasedEraConway f = f + withShelleyBasedEraConstraintsForLedger era $ getTxIdShelley era tx getTxIdShelley :: Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto @@ -2485,7 +2474,7 @@ createTransactionBody era txBodyContent = case sData of TxBodyNoScriptData -> pure SNothing TxBodyScriptData _sDataSupported datums redeemers -> - getLedgerEraConstraint era + withShelleyBasedEraConstraintsForLedger era $ convPParamsToScriptIntegrityHash era apiProtocolParameters @@ -2519,7 +2508,7 @@ createTransactionBody era txBodyContent = case sData of TxBodyNoScriptData -> pure SNothing TxBodyScriptData _sDataSupported datums redeemers -> - getLedgerEraConstraint era + withShelleyBasedEraConstraintsForLedger era $ convPParamsToScriptIntegrityHash era apiProtocolParameters @@ -3423,7 +3412,7 @@ convReturnCollateral convReturnCollateral era txReturnCollateral = case txReturnCollateral of TxReturnCollateralNone -> SNothing - TxReturnCollateral _ colTxOut -> SJust $ getCBORConstraint era $ toShelleyTxOutAny era colTxOut + TxReturnCollateral _ colTxOut -> SJust $ withShelleyBasedEraConstraintsForLedger era $ toShelleyTxOutAny era colTxOut convTotalCollateral :: TxTotalCollateral era -> StrictMaybe Ledger.Coin convTotalCollateral txTotalCollateral = @@ -3600,28 +3589,6 @@ convReferenceInputs txInsReference = TxInsReferenceNone -> mempty TxInsReference _ refTxins -> Set.fromList $ map toShelleyTxIn refTxins -getCBORConstraint - :: ShelleyBasedEra era - -> (ToCBOR (Ledger.TxOut (ShelleyLedgerEra era)) => a) - -> a -getCBORConstraint ShelleyBasedEraShelley f = f -getCBORConstraint ShelleyBasedEraAllegra f = f -getCBORConstraint ShelleyBasedEraMary f = f -getCBORConstraint ShelleyBasedEraAlonzo f = f -getCBORConstraint ShelleyBasedEraBabbage f = f -getCBORConstraint ShelleyBasedEraConway f = f - -getLedgerEraConstraint - :: ShelleyBasedEra era - -> (Ledger.Era (ShelleyLedgerEra era) => a) - -> a -getLedgerEraConstraint ShelleyBasedEraShelley f = f -getLedgerEraConstraint ShelleyBasedEraAllegra f = f -getLedgerEraConstraint ShelleyBasedEraMary f = f -getLedgerEraConstraint ShelleyBasedEraAlonzo f = f -getLedgerEraConstraint ShelleyBasedEraBabbage f = f -getLedgerEraConstraint ShelleyBasedEraConway f = f - guardShelleyTxInsOverflow :: [TxIn] -> Either TxBodyError () guardShelleyTxInsOverflow txIns = do for_ txIns $ \txin@(TxIn _ (TxIx txix)) -> From 7ff6c7ea676994cb2b25e5db06e7cb0d2aa0e6fa Mon Sep 17 00:00:00 2001 From: John Ky Date: Mon, 26 Jun 2023 14:18:01 +1000 Subject: [PATCH 2/2] New withShelleyBasedEraConstraintForConsensus --- cardano-api/internal/Cardano/Api/Block.hs | 15 +-------------- cardano-api/internal/Cardano/Api/Modes.hs | 21 ++++++++++++++++++++- 2 files changed, 21 insertions(+), 15 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index 620ca2d09a..321095b084 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -171,7 +171,7 @@ getBlockTxs (ByronBlock Consensus.ByronBlock { Consensus.byronBlockRaw }) = } } -> map ByronTx txs getBlockTxs (ShelleyBlock era Consensus.ShelleyBlock{Consensus.shelleyBlockRaw}) = - obtainConsensusShelleyCompatibleEra era $ + withShelleyBasedEraConstraintForConsensus era $ getShelleyBlockTxs era shelleyBlockRaw @@ -186,19 +186,6 @@ getShelleyBlockTxs era (Ledger.Block _header txs) = [ ShelleyTx era txinblock | txinblock <- toList (Ledger.fromTxSeq txs) ] -obtainConsensusShelleyCompatibleEra - :: forall era ledgerera a. - ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> (Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera => a) - -> a -obtainConsensusShelleyCompatibleEra ShelleyBasedEraShelley f = f -obtainConsensusShelleyCompatibleEra ShelleyBasedEraAllegra f = f -obtainConsensusShelleyCompatibleEra ShelleyBasedEraMary f = f -obtainConsensusShelleyCompatibleEra ShelleyBasedEraAlonzo f = f -obtainConsensusShelleyCompatibleEra ShelleyBasedEraBabbage f = f -obtainConsensusShelleyCompatibleEra ShelleyBasedEraConway f = f - -- ---------------------------------------------------------------------------- -- Block in a consensus mode -- diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index e8fca4779b..da7366e606 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -41,6 +44,8 @@ module Cardano.Api.Modes ( ConsensusBlockForEra, toConsensusEraIndex, fromConsensusEraIndex, + + withShelleyBasedEraConstraintForConsensus, ) where import Cardano.Api.Eras @@ -49,12 +54,13 @@ import qualified Cardano.Chain.Slotting as Byron (EpochSlots (..)) import Cardano.Ledger.Crypto (StandardCrypto) import qualified Ouroboros.Consensus.Byron.Ledger as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus -import qualified Ouroboros.Consensus.Cardano.ByronHFC as Consensus (ByronBlockHFC) +import qualified Ouroboros.Consensus.Cardano.ByronHFC as Consensus import Ouroboros.Consensus.HardFork.Combinator as Consensus (EraIndex (..), eraIndexSucc, eraIndexZero) import qualified Ouroboros.Consensus.Protocol.Praos as Consensus import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus +import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Consensus.Shelley.ShelleyHFC as Consensus import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value) @@ -424,3 +430,16 @@ fromConsensusEraIndex CardanoMode = fromShelleyEraIndex fromShelleyEraIndex (Consensus.EraIndex (S (S (S (S (S (S (Z (K ()))))))))) = AnyEraInMode ConwayEraInCardanoMode +withShelleyBasedEraConstraintForConsensus + :: forall era ledgerera a. () + => ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> (Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera => a) + -> a +withShelleyBasedEraConstraintForConsensus = \case + ShelleyBasedEraShelley -> id + ShelleyBasedEraAllegra -> id + ShelleyBasedEraMary -> id + ShelleyBasedEraAlonzo -> id + ShelleyBasedEraBabbage -> id + ShelleyBasedEraConway -> id