diff --git a/cardano-api/ChangeLog.md b/cardano-api/ChangeLog.md index 3f4304277cb..1f2953f0c8e 100644 --- a/cardano-api/ChangeLog.md +++ b/cardano-api/ChangeLog.md @@ -31,6 +31,11 @@ - **Breaking change** Change return type of `queryNodeLocalState` to new `AcquiringFailure` type. +- **Breaking change** - For performance reasons, `evaluateTransactionFee` to take a + `Ledger.PParams (ShelleyLedgerEra era)` argument instead of `ProtocolParameters` + New type `BundledProtocolParameters` and new functions `bundleProtocolParams` and `unbundleProtocolParams`. + ([PR4903](https://github.com/input-output-hk/cardano-node/pull/4903)) + ### Bugs - Allow reading text envelopes from pipes ([PR 4384](https://github.com/input-output-hk/cardano-node/pull/4384)) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 8bf30748da8..1cc636fc890 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -685,6 +685,11 @@ module Cardano.Api ( NetworkMagic(..), + -- * Protocol parameters + BundledProtocolParameters(..), + bundleProtocolParams, + unbundleProtocolParams, + -- ** Conversions toLedgerPParams, fromLedgerPParams, diff --git a/cardano-api/src/Cardano/Api/Convenience/Construction.hs b/cardano-api/src/Cardano/Api/Convenience/Construction.hs index f68ffeaff94..3c5c6d771df 100644 --- a/cardano-api/src/Cardano/Api/Convenience/Construction.hs +++ b/cardano-api/src/Cardano/Api/Convenience/Construction.hs @@ -24,8 +24,6 @@ import Cardano.Api.Address import Cardano.Api.Certificate import Cardano.Api.Eras import Cardano.Api.Fees -import Cardano.Api.IPC -import Cardano.Api.Modes import Cardano.Api.ProtocolParameters import Cardano.Api.Query import Cardano.Api.Tx @@ -38,8 +36,7 @@ import Cardano.Api.Utils -- for constructBalancedTx. constructBalancedTx :: IsShelleyBasedEra era - => EraInMode era CardanoMode - -> TxBodyContent BuildTx era + => TxBodyContent BuildTx era -> AddressInEra era -- ^ Change address -> Maybe Word -- ^ Override key witnesses -> UTxO era -- ^ Just the transaction inputs, not the entire 'UTxO'. @@ -49,11 +46,11 @@ constructBalancedTx -> Set PoolId -- ^ The set of registered stake pools -> [ShelleyWitnessSigningKey] -> Either TxBodyErrorAutoBalance (Tx era) -constructBalancedTx eInMode txbodcontent changeAddr mOverrideWits utxo pparams +constructBalancedTx txbodcontent changeAddr mOverrideWits utxo pparams ledgerEpochInfo systemStart stakePools shelleyWitSigningKeys = do BalancedTxBody _ txbody _txBalanceOutput _fee <- makeTransactionBodyAutoBalance - eInMode systemStart ledgerEpochInfo + systemStart ledgerEpochInfo pparams stakePools utxo txbodcontent changeAddr mOverrideWits diff --git a/cardano-api/src/Cardano/Api/Fees.hs b/cardano-api/src/Cardano/Api/Fees.hs index 907d0a63287..8d42014ce8a 100644 --- a/cardano-api/src/Cardano/Api/Fees.hs +++ b/cardano-api/src/Cardano/Api/Fees.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} @@ -10,7 +10,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -- | Fee calculation -- @@ -42,6 +41,7 @@ module Cardano.Api.Fees ( mapTxScriptWitnesses, ) where +import Control.Monad (forM_) import qualified Data.Array as Array import Data.Bifunctor (bimap, first) import qualified Data.ByteString as BS @@ -102,7 +102,6 @@ import Cardano.Api.Address import Cardano.Api.Certificate import Cardano.Api.Eras import Cardano.Api.Error -import Cardano.Api.Modes import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import Cardano.Api.Query @@ -238,7 +237,7 @@ estimateTransactionFee _ _ _ (ByronTx _) = -- evaluateTransactionFee :: forall era. IsShelleyBasedEra era - => ProtocolParameters + => BundledProtocolParameters era -> TxBody era -> Word -- ^ The number of Shelley key witnesses -> Word -- ^ The number of Byron key witnesses @@ -246,23 +245,22 @@ evaluateTransactionFee :: forall era. evaluateTransactionFee _ _ _ byronwitcount | byronwitcount > 0 = error "evaluateTransactionFee: TODO support Byron key witnesses" -evaluateTransactionFee pparams txbody keywitcount _byronwitcount = +evaluateTransactionFee bpparams txbody keywitcount _byronwitcount = case makeSignedTransaction [] txbody of 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 era tx) + ShelleyTx era tx -> withLedgerConstraints era (evalShelleyBasedEra tx) where evalShelleyBasedEra :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera => Ledger.CLI ledgerera - => ShelleyBasedEra era - -> Ledger.Tx ledgerera + => Ledger.Tx ledgerera -> Lovelace - evalShelleyBasedEra era tx = + evalShelleyBasedEra tx = fromShelleyLovelace $ Ledger.evaluateTransactionFee - (toLedgerPParams era pparams) + (unbundleLedgerShelleyBasedProtocolParams shelleyBasedEra bpparams) tx keywitcount @@ -505,40 +503,41 @@ instance Error TransactionValidityError where -- are actually used. -- evaluateTransactionExecutionUnits - :: forall era mode. - EraInMode era mode - -> SystemStart + :: forall era. + SystemStart -> LedgerEpochInfo - -> ProtocolParameters + -> BundledProtocolParameters era -> UTxO era -> TxBody era -> Either TransactionValidityError (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) -evaluateTransactionExecutionUnits _eraInMode systemstart (LedgerEpochInfo ledgerEpochInfo) - pparams utxo txbody = +evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = case makeSignedTransaction [] txbody of - ByronTx {} -> evalPreAlonzo - ShelleyTx era tx' -> - case era of + ByronTx {} -> evalPreAlonzo + ShelleyTx sbe tx' -> + case sbe of ShelleyBasedEraShelley -> evalPreAlonzo ShelleyBasedEraAllegra -> evalPreAlonzo ShelleyBasedEraMary -> evalPreAlonzo - ShelleyBasedEraAlonzo -> evalAlonzo era tx' + ShelleyBasedEraAlonzo -> evalAlonzo sbe tx' ShelleyBasedEraBabbage -> - case collateralSupportedInEra $ shelleyBasedToCardanoEra era of - Just supp -> obtainHasFieldConstraint supp $ evalBabbage era tx' + case collateralSupportedInEra $ shelleyBasedToCardanoEra sbe of + Just supp -> obtainHasFieldConstraint supp $ evalBabbage sbe tx' Nothing -> return mempty ShelleyBasedEraConway -> - case collateralSupportedInEra $ shelleyBasedToCardanoEra era of - Just supp -> obtainHasFieldConstraint supp $ evalConway era tx' + case collateralSupportedInEra $ shelleyBasedToCardanoEra sbe of + Just supp -> obtainHasFieldConstraint supp $ evalConway sbe tx' Nothing -> return mempty where - -- Pre-Alonzo eras do not support languages with execution unit accounting. + LedgerEpochInfo ledgerEpochInfo = epochInfo + + -- | Pre-Alonzo eras do not support languages with execution unit accounting. evalPreAlonzo :: Either TransactionValidityError (Map ScriptWitnessIndex - (Either ScriptExecutionError ExecutionUnits)) + (Either ScriptExecutionError ExecutionUnits)) evalPreAlonzo = Right Map.empty + evalAlonzo :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera => ledgerera ~ Alonzo.AlonzoEra Ledger.StandardCrypto @@ -551,9 +550,9 @@ evaluateTransactionExecutionUnits _eraInMode systemstart (LedgerEpochInfo ledger (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evalAlonzo era tx = do - cModelArray <- toAlonzoCostModelsArray (protocolParamCostModels pparams) + cModelArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) case Alonzo.evaluateTransactionExecutionUnits - (toLedgerPParams era pparams) + (unbundleLedgerShelleyBasedProtocolParams era bpp) tx (toLedgerUTxO era utxo) ledgerEpochInfo @@ -573,9 +572,9 @@ evaluateTransactionExecutionUnits _eraInMode systemstart (LedgerEpochInfo ledger (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evalBabbage era tx = do - costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels pparams) + costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) case Alonzo.evaluateTransactionExecutionUnits - (toLedgerPParams era pparams) + (unbundleLedgerShelleyBasedProtocolParams era bpp) tx (toLedgerUTxO era utxo) ledgerEpochInfo @@ -595,9 +594,9 @@ evaluateTransactionExecutionUnits _eraInMode systemstart (LedgerEpochInfo ledger (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evalConway era tx = do - costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels pparams) + costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) case Alonzo.evaluateTransactionExecutionUnits - (toLedgerPParams era pparams) + (toLedgerPParams era (unbundleProtocolParams bpp)) tx (toLedgerUTxO era utxo) ledgerEpochInfo @@ -662,7 +661,6 @@ evaluateTransactionExecutionUnits _eraInMode systemstart (LedgerEpochInfo ledger obtainHasFieldConstraint CollateralInBabbageEra f = f obtainHasFieldConstraint CollateralInConwayEra f = f - -- ---------------------------------------------------------------------------- -- Transaction balance -- @@ -675,7 +673,7 @@ evaluateTransactionExecutionUnits _eraInMode systemstart (LedgerEpochInfo ledger -- evaluateTransactionBalance :: forall era. IsShelleyBasedEra era - => ProtocolParameters + => BundledProtocolParameters era -> Set PoolId -> UTxO era -> TxBody era @@ -684,7 +682,7 @@ evaluateTransactionBalance _ _ _ (ByronTxBody _) = case shelleyBasedEra :: ShelleyBasedEra era of {} --TODO: we could actually support Byron here, it'd be different but simpler -evaluateTransactionBalance pparams poolids utxo +evaluateTransactionBalance bpp poolids utxo (ShelleyTxBody era txbody _ _ _ _) = withLedgerConstraints era @@ -716,7 +714,7 @@ evaluateTransactionBalance pparams poolids utxo evalMultiAsset evidence = TxOutValue evidence . fromMaryValue $ Ledger.evaluateTransactionBalance - (toLedgerPParams era pparams) + (unbundleLedgerShelleyBasedProtocolParams era bpp) (toLedgerUTxO era utxo) isNewPool txbody @@ -731,7 +729,7 @@ evaluateTransactionBalance pparams poolids utxo evalAdaOnly evidence = TxOutAdaOnly evidence . fromShelleyLovelace $ Ledger.evaluateTransactionBalance - (toLedgerPParams era pparams) + (unbundleLedgerShelleyBasedProtocolParams era bpp) (toLedgerUTxO era utxo) isNewPool txbody @@ -952,10 +950,9 @@ data BalancedTxBody era -- which can be queried from a local node. -- makeTransactionBodyAutoBalance - :: forall era mode. + :: forall era. IsShelleyBasedEra era - => EraInMode era mode - -> SystemStart + => SystemStart -> LedgerEpochInfo -> ProtocolParameters -> Set PoolId -- ^ The set of registered stake pools @@ -964,7 +961,7 @@ makeTransactionBodyAutoBalance -> AddressInEra era -- ^ Change address -> Maybe Word -- ^ Override key witnesses -> Either TxBodyErrorAutoBalance (BalancedTxBody era) -makeTransactionBodyAutoBalance eraInMode systemstart history pparams +makeTransactionBodyAutoBalance systemstart history pparams poolids utxo txbodycontent changeaddr mnkeys = do -- Our strategy is to: @@ -982,9 +979,8 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams exUnitsMap <- first TxBodyErrorValidityInterval $ evaluateTransactionExecutionUnits - eraInMode systemstart history - pparams + bpparams utxo txbody0 @@ -1025,7 +1021,7 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams let nkeys = fromMaybe (estimateTransactionKeyWitnessCount txbodycontent1) mnkeys - fee = evaluateTransactionFee pparams txbody1 nkeys 0 --TODO: byron keys + fee = evaluateTransactionFee bpparams txbody1 nkeys 0 --TODO: byron keys (retColl, reqCol) = calcReturnAndTotalCollateral fee pparams (txInsCollateral txbodycontent) (txReturnCollateral txbodycontent) @@ -1041,9 +1037,9 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams txReturnCollateral = retColl, txTotalCollateral = reqCol } - let balance = evaluateTransactionBalance pparams poolids utxo txbody2 + let balance = evaluateTransactionBalance bpparams poolids utxo txbody2 - mapM_ (`checkMinUTxOValue` pparams) $ txOuts txbodycontent1 + forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue txout bpparams -- check if the balance is positive or negative -- in one case we can produce change, in the other the inputs are insufficient @@ -1078,6 +1074,8 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams createAndValidateTransactionBody finalTxBodyContent return (BalancedTxBody finalTxBodyContent txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee) where + bpparams = bundleProtocolParams era' pparams + -- Essentially we check for the existence of collateral inputs. If they exist we -- create a fictitious collateral return output. Why? Because we need to put dummy values -- to get a fee estimate (i.e we overestimate the fee.) @@ -1183,7 +1181,7 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams | txOutValueToLovelace balance < 0 = Left . TxBodyErrorAdaBalanceNegative $ txOutValueToLovelace balance | otherwise = - case checkMinUTxOValue (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) pparams of + case checkMinUTxOValue (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) bpparams of Left (TxBodyErrorMinUTxONotMet txOutAny minUTxO) -> Left $ TxBodyErrorAdaBalanceTooSmall txOutAny minUTxO (txOutValueToLovelace balance) Left err -> Left err @@ -1191,11 +1189,10 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams checkMinUTxOValue :: TxOut CtxTx era - -> ProtocolParameters + -> BundledProtocolParameters era -> Either TxBodyErrorAutoBalance () - checkMinUTxOValue txout@(TxOut _ v _ _) pparams' = do - minUTxO <- first TxBodyErrorMinUTxOMissingPParams - $ calculateMinimumUTxO era txout pparams' + checkMinUTxOValue txout@(TxOut _ v _ _) bpp = do + minUTxO <- first TxBodyErrorMinUTxOMissingPParams $ calculateMinimumUTxO era txout bpp if txOutValueToLovelace v >= minUTxO then Right () else Left $ TxBodyErrorMinUTxONotMet @@ -1356,36 +1353,33 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { calculateMinimumUTxO :: ShelleyBasedEra era -> TxOut CtxTx era - -> ProtocolParameters + -> BundledProtocolParameters era -> Either MinimumUTxOError Lovelace -calculateMinimumUTxO era txout@(TxOut _ v _ _) pparams' = +calculateMinimumUTxO era txout@(TxOut _ v _ _) bpp = case era of - ShelleyBasedEraShelley -> getMinUTxOPreAlonzo pparams' + ShelleyBasedEraShelley -> getMinUTxOPreAlonzo (unbundleProtocolParams bpp) ShelleyBasedEraAllegra -> calcMinUTxOAllegraMary ShelleyBasedEraMary -> calcMinUTxOAllegraMary ShelleyBasedEraAlonzo -> let lTxOut = toShelleyTxOutAny era txout - babPParams = toAlonzoPParams pparams' - minUTxO = Shelley.evaluateMinLovelaceOutput babPParams lTxOut + minUTxO = Shelley.evaluateMinLovelaceOutput (unbundleLedgerShelleyBasedProtocolParams era bpp) lTxOut val = fromShelleyLovelace minUTxO in Right val ShelleyBasedEraBabbage -> let lTxOut = toShelleyTxOutAny era txout - babPParams = toBabbagePParams pparams' - minUTxO = Shelley.evaluateMinLovelaceOutput babPParams lTxOut + minUTxO = Shelley.evaluateMinLovelaceOutput (unbundleLedgerShelleyBasedProtocolParams era bpp) lTxOut val = fromShelleyLovelace minUTxO in Right val ShelleyBasedEraConway -> let lTxOut = toShelleyTxOutAny era txout - babPParams = toConwayPParams pparams' - minUTxO = Shelley.evaluateMinLovelaceOutput babPParams lTxOut + minUTxO = Shelley.evaluateMinLovelaceOutput (unbundleLedgerShelleyBasedProtocolParams era bpp) lTxOut val = fromShelleyLovelace minUTxO in Right val where calcMinUTxOAllegraMary :: Either MinimumUTxOError Lovelace calcMinUTxOAllegraMary = do let val = txOutValueToValue v - minUTxO <- getMinUTxOPreAlonzo pparams' + minUTxO <- getMinUTxOPreAlonzo (unbundleProtocolParams bpp) Right $ calcMinimumDeposit val minUTxO getMinUTxOPreAlonzo diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 2c86391edb2..d0348a03bcf 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -129,9 +129,9 @@ import qualified Cardano.Ledger.BaseTypes as Shelley.Spec import qualified Cardano.Ledger.BHeaderView as Ledger import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) import qualified Cardano.Ledger.Core as Core +import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Credential as Shelley.Spec import qualified Cardano.Ledger.Era -import qualified Cardano.Ledger.Era as Ledger import qualified Cardano.Ledger.Keys as Shelley.Spec import qualified Cardano.Ledger.Keys as SL import qualified Cardano.Ledger.PoolDistr as SL @@ -1447,11 +1447,11 @@ nextEpochEligibleLeadershipSlots -- ^ Potential slot leading stake pool -> SigningKey VrfKey -- ^ VRF signing key of the stake pool - -> ProtocolParameters + -> BundledProtocolParameters era -> EpochInfo (Either Text) -> (ChainTip, EpochNo) -> Either LeadershipError (Set SlotNo) -nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (VrfSigningKey vrfSkey) pParams eInfo (cTip, currentEpoch) = do +nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (VrfSigningKey vrfSkey) bpp eInfo (cTip, currentEpoch) = do (_, currentEpochLastSlot) <- first LeaderErrSlotRangeCalculationFailure $ Slot.epochInfoRange eInfo currentEpoch @@ -1492,7 +1492,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr -- Get the previous epoch's last block header hash nonce let previousLabNonce = Consensus.previousLabNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) - extraEntropy = toLedgerNonce $ protocolParamExtraPraosEntropy pParams + extraEntropy = toLedgerNonce $ protocolParamExtraPraosEntropy (unbundleProtocolParams bpp) nextEpochsNonce = candidateNonce ⭒ previousLabNonce ⭒ extraEntropy -- Then we get the "mark" snapshot. This snapshot will be used for the next @@ -1507,7 +1507,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr $ snapshot let slotRangeOfInterest = Set.filter - (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (toLedgerPParams sbe pParams))) + (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (unbundleLedgerShelleyBasedProtocolParams sbe bpp))) $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] case sbe of @@ -1518,7 +1518,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr ShelleyBasedEraBabbage -> isLeadingSlotsPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f ShelleyBasedEraConway -> isLeadingSlotsPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f where - globals = constructGlobals sGen eInfo pParams + globals = constructGlobals sGen eInfo (unbundleProtocolParams bpp) f :: Shelley.Spec.ActiveSlotCoeff f = activeSlotCoeff globals @@ -1630,14 +1630,14 @@ currentEpochEligibleLeadershipSlots :: forall era ledgerera. () => ShelleyBasedEra era -> ShelleyGenesis Shelley.StandardShelley -> EpochInfo (Either Text) - -> ProtocolParameters + -> BundledProtocolParameters era -> ProtocolState era -> PoolId -> SigningKey VrfKey -> SerialisedPoolDistribution era -> EpochNo -- ^ Current EpochInfo -> Either LeadershipError (Set SlotNo) -currentEpochEligibleLeadershipSlots sbe sGen eInfo pParams ptclState poolid (VrfSigningKey vrkSkey) serPoolDistr currentEpoch = do +currentEpochEligibleLeadershipSlots sbe sGen eInfo bpp ptclState poolid (VrfSigningKey vrkSkey) serPoolDistr currentEpoch = do chainDepState :: ChainDepState (Api.ConsensusProtocol era) <- first LeaderErrDecodeProtocolStateFailure $ decodeProtocolState ptclState @@ -1656,7 +1656,7 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo pParams ptclState poolid (Vrf $ decodePoolDistribution serPoolDistr let slotRangeOfInterest = Set.filter - (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (toLedgerPParams sbe pParams))) + (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (unbundleLedgerShelleyBasedProtocolParams sbe bpp))) $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] case sbe of @@ -1668,7 +1668,7 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo pParams ptclState poolid (Vrf ShelleyBasedEraConway -> isLeadingSlotsPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f where - globals = constructGlobals sGen eInfo pParams + globals = constructGlobals sGen eInfo (unbundleProtocolParams bpp) f :: Shelley.Spec.ActiveSlotCoeff f = activeSlotCoeff globals diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index d68e9cfeff1..02acaec2479 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -2,7 +2,9 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,6 +25,10 @@ module Cardano.Api.ProtocolParameters ( checkProtocolParameters, ProtocolParametersError(..), EpochNo, + BundledProtocolParameters(..), + bundleProtocolParams, + unbundleProtocolParams, + unbundleLedgerShelleyBasedProtocolParams, -- * Updates to the protocol parameters ProtocolParametersUpdate(..), @@ -63,7 +69,7 @@ module Cardano.Api.ProtocolParameters ( toConwayPParams, -- * Data family instances - AsType(..) + AsType(..), ) where import Control.Applicative ((<|>)) @@ -1355,6 +1361,42 @@ fromConwayPParamsUpdate :: BabbagePParamsUpdate ledgerera -> ProtocolParametersUpdate fromConwayPParamsUpdate = fromBabbagePParamsUpdate +-- | Bundle cardano-api representation and ledger representation of protocol parameters together so +-- they can be computed once and passed around rather than re-computed unecessarily. +-- +-- The consructor arguments are intentionally lazy so that the values are not computed if not used +-- (which may be the case for some code paths). +data BundledProtocolParameters era where + BundleAsByronProtocolParameters + :: ProtocolParameters + -> BundledProtocolParameters ByronEra + BundleAsShelleyBasedProtocolParameters + :: ShelleyBasedEra era + -> ProtocolParameters + -> Ledger.PParams (ShelleyLedgerEra era) + -> BundledProtocolParameters era + +bundleProtocolParams :: CardanoEra era -> ProtocolParameters -> BundledProtocolParameters era +bundleProtocolParams cEra pp = case cardanoEraStyle cEra of + LegacyByronEra -> BundleAsByronProtocolParameters pp + ShelleyBasedEra sbe -> BundleAsShelleyBasedProtocolParameters sbe pp (toLedgerPParams sbe pp) + +unbundleLedgerShelleyBasedProtocolParams + :: ShelleyBasedEra era + -> BundledProtocolParameters era + -> Ledger.PParams (ShelleyLedgerEra era) +unbundleLedgerShelleyBasedProtocolParams = \case + ShelleyBasedEraShelley -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp + ShelleyBasedEraAllegra -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp + ShelleyBasedEraMary -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp + ShelleyBasedEraAlonzo -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp + ShelleyBasedEraBabbage -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp + ShelleyBasedEraConway -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp + +unbundleProtocolParams :: BundledProtocolParameters era -> ProtocolParameters +unbundleProtocolParams (BundleAsByronProtocolParameters pp) = pp +unbundleProtocolParams (BundleAsShelleyBasedProtocolParameters _ pp _) = pp + -- ---------------------------------------------------------------------------- -- Conversion functions: protocol parameters to ledger types -- diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index 0ccb7823f92..1461f1feedf 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -1192,7 +1192,8 @@ runQueryLeadershipSchedule (AnyConsensusModeParams cModeParams) network anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) & onLeft (left . ShelleyQueryCmdAcquireFailure) - sbe <- getSbe $ cardanoEraStyle era + sbe <- getSbe (cardanoEraStyle era) + let cMode = consensusModeOnly cModeParams poolid <- lift (readVerificationKeyOrHashOrFile AsStakePoolKey coldVerKeyFile) @@ -1222,6 +1223,8 @@ runQueryLeadershipSchedule (AnyConsensusModeParams cModeParams) network let currentEpochQuery = QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryEpoch curentEpoch <- executeQuery era cModeParams localNodeConnInfo currentEpochQuery + let bpp = bundleProtocolParams era pparams + schedule <- case whichSchedule of CurrentEpoch -> do serCurrentEpochState <- executeQuery era cModeParams localNodeConnInfo $ @@ -1232,7 +1235,7 @@ runQueryLeadershipSchedule (AnyConsensusModeParams cModeParams) network sbe shelleyGenesis eInfo - pparams + bpp ptclState poolid vrkSkey @@ -1248,7 +1251,7 @@ runQueryLeadershipSchedule (AnyConsensusModeParams cModeParams) network firstExceptT ShelleyQueryCmdLeaderShipError $ hoistEither $ eligibleLeaderSlotsConstaints sbe $ nextEpochEligibleLeadershipSlots sbe shelleyGenesis - serCurrentEpochState ptclState poolid vrkSkey pparams + serCurrentEpochState ptclState poolid vrkSkey bpp eInfo (tip, curentEpoch) case mJsonOutputFile of diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index ecaf1cc43e8..5050f9427e8 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -18,17 +18,18 @@ module Cardano.CLI.Shelley.Run.Transaction , toTxOutInAnyEra ) where -import Control.Monad (forM_) +import Control.Monad (forM_, void) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither, hoistMaybe, left, - newExceptT) + newExceptT, onNothing) import Data.Aeson.Encode.Pretty (encodePretty) import Data.Bifunctor (Bifunctor (..)) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Data ((:~:) (..)) import Data.Foldable (Foldable (..)) +import Data.Function ((&)) import qualified Data.List as List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -420,37 +421,39 @@ runTxBuildCmd let BuildTxWith mTxProtocolParams = txProtocolParams txBodycontent case mTxProtocolParams of Just pparams -> - case protocolParamPrices pparams of - Just executionUnitPrices -> do - let consensusMode = consensusModeOnly cModeParams - case consensusMode of - CardanoMode -> do - (nodeEraUTxO, _, eraHistory, systemStart, _) - <- firstExceptT ShelleyTxCmdQueryConvenienceError + case protocolParamPrices pparams of + Just executionUnitPrices -> do + let consensusMode = consensusModeOnly cModeParams + bpp = bundleProtocolParams cEra pparams + case consensusMode of + CardanoMode -> do + (nodeEraUTxO, _, eraHistory, systemStart, _) + <- firstExceptT ShelleyTxCmdQueryConvenienceError . newExceptT $ queryStateForBalancedTx nodeEra nid allTxInputs - case toEraInMode cEra CardanoMode of - Just eInMode -> do - -- Why do we cast the era? The user can specify an era prior to the era that the node is currently in. - -- We cannot use the user specified era to construct a query against a node because it may differ - -- from the node's era and this will result in the 'QueryEraMismatch' failure. - txEraUtxo <- case first ShelleyTxCmdTxEraCastErr (eraCast cEra nodeEraUTxO) of - Right txEraUtxo -> return txEraUtxo - Left e -> left e - - scriptExecUnitsMap <- firstExceptT ShelleyTxCmdTxExecUnitsErr $ hoistEither - $ evaluateTransactionExecutionUnits - eInMode systemStart (toLedgerEpochInfo eraHistory) - pparams txEraUtxo balancedTxBody - scriptCostOutput <- firstExceptT ShelleyTxCmdPlutusScriptCostErr $ hoistEither - $ renderScriptCosts - txEraUtxo - executionUnitPrices - (collectTxBodyScriptWitnesses txBodycontent) - scriptExecUnitsMap - liftIO $ LBS.writeFile fp $ encodePretty scriptCostOutput - Nothing -> left $ ShelleyTxCmdUnsupportedMode (AnyConsensusMode consensusMode) - _ -> left ShelleyTxCmdPlutusScriptsRequireCardanoMode - Nothing -> left ShelleyTxCmdPParamExecutionUnitsNotAvailable + -- Why do we cast the era? The user can specify an era prior to the era that the node is currently in. + -- We cannot use the user specified era to construct a query against a node because it may differ + -- from the node's era and this will result in the 'QueryEraMismatch' failure. + txEraUtxo <- + case first ShelleyTxCmdTxEraCastErr (eraCast cEra nodeEraUTxO) of + Right txEraUtxo -> return txEraUtxo + Left e -> left e + + scriptExecUnitsMap <- + firstExceptT ShelleyTxCmdTxExecUnitsErr $ hoistEither + $ evaluateTransactionExecutionUnits + systemStart (toLedgerEpochInfo eraHistory) + bpp txEraUtxo balancedTxBody + + scriptCostOutput <- + firstExceptT ShelleyTxCmdPlutusScriptCostErr $ hoistEither + $ renderScriptCosts + txEraUtxo + executionUnitPrices + (collectTxBodyScriptWitnesses txBodycontent) + scriptExecUnitsMap + liftIO $ LBS.writeFile fp $ encodePretty scriptCostOutput + _ -> left ShelleyTxCmdPlutusScriptsRequireCardanoMode + Nothing -> left ShelleyTxCmdPParamExecutionUnitsNotAvailable Nothing -> left ShelleyTxCmdProtocolParametersNotPresentInTxBody OutputTxBodyOnly (TxBodyFile fpath) -> let noWitTx = makeSignedTransaction [] balancedTxBody @@ -699,11 +702,9 @@ runTxBuild era (AnyConsensusModeParams cModeParams) networkId mScriptValidity case (consensusMode, cardanoEraStyle era) of (CardanoMode, ShelleyBasedEra _sbe) -> do - eInMode <- case toEraInMode era CardanoMode of - Just result -> return result - Nothing -> - left (ShelleyTxCmdEraConsensusModeMismatchTxBalance outputOptions - (AnyConsensusMode CardanoMode) (AnyCardanoEra era)) + void $ pure (toEraInMode era CardanoMode) + & onNothing (left (ShelleyTxCmdEraConsensusModeMismatchTxBalance outputOptions + (AnyConsensusMode CardanoMode) (AnyCardanoEra era))) SocketPath sockPath <- firstExceptT ShelleyTxCmdSocketEnvError $ newExceptT readEnvSocketPath @@ -764,7 +765,7 @@ runTxBuild era (AnyConsensusModeParams cModeParams) networkId mScriptValidity balancedTxBody@(BalancedTxBody _ _ _ fee) <- firstExceptT ShelleyTxCmdBalanceTxBody . hoistEither - $ makeTransactionBodyAutoBalance eInMode systemStart (toLedgerEpochInfo eraHistory) + $ makeTransactionBodyAutoBalance systemStart (toLedgerEpochInfo eraHistory) pparams stakePools txEraUtxo txBodyContent cAddr mOverrideWits @@ -1240,7 +1241,7 @@ runTxCalculateMinRequiredUTxO (AnyCardanoEra era) protocolParamsSourceSpec txOut firstExceptT ShelleyTxCmdPParamsErr . hoistEither $ checkProtocolParameters sbe pp minValue <- firstExceptT ShelleyTxCmdMinimumUTxOErr - . hoistEither $ calculateMinimumUTxO sbe out pp + . hoistEither $ calculateMinimumUTxO sbe out (bundleProtocolParams era pp) liftIO . IO.print $ minValue runTxCreatePolicyId :: ScriptFile -> ExceptT ShelleyTxCmdError IO () diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs index e1473e6ac20..6c21ac3d1be 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs @@ -375,6 +375,7 @@ nodeToClientVersionToInt = \case NodeToClientV_12 -> 12 NodeToClientV_13 -> 13 NodeToClientV_14 -> 14 + NodeToClientV_15 -> 15 nodeToNodeVersionToInt :: NodeToNodeVersion -> Int nodeToNodeVersionToInt = \case @@ -382,6 +383,7 @@ nodeToNodeVersionToInt = \case NodeToNodeV_8 -> 8 NodeToNodeV_9 -> 9 NodeToNodeV_10 -> 10 + NodeToNodeV_11 -> 11 -- | Pretty print 'StartupInfoTrace' -- diff --git a/cardano-node/src/Cardano/Tracing/Startup.hs b/cardano-node/src/Cardano/Tracing/Startup.hs index 15b65528345..40bced7189a 100644 --- a/cardano-node/src/Cardano/Tracing/Startup.hs +++ b/cardano-node/src/Cardano/Tracing/Startup.hs @@ -1,13 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Tracing.Startup where -import Prelude import Data.Text (Text) +import Prelude import Cardano.Logging (LogFormatting (..)) import Cardano.Node.Startup @@ -15,14 +15,12 @@ import Cardano.Node.Tracing.Compat import Cardano.Node.Tracing.Tracers.Startup import Cardano.Tracing.OrphanInstances.Network () -import Cardano.BM.Tracing (HasPrivacyAnnotation (..), - HasSeverityAnnotation (..), Severity (..), ToObject (..), - Transformable (..)) -import Cardano.BM.Data.Tracer (HasTextFormatter (..), - trStructuredText) +import Cardano.BM.Data.Tracer (HasTextFormatter (..), trStructuredText) +import Cardano.BM.Tracing (HasPrivacyAnnotation (..), HasSeverityAnnotation (..), + Severity (..), ToObject (..), Transformable (..)) -import Ouroboros.Consensus.Node.NetworkProtocolVersion - (BlockNodeToClientVersion, BlockNodeToNodeVersion) +import Ouroboros.Consensus.Node.NetworkProtocolVersion (BlockNodeToClientVersion, + BlockNodeToNodeVersion) instance HasSeverityAnnotation (StartupTrace blk) where @@ -43,10 +41,7 @@ instance ( Show (BlockNodeToNodeVersion blk) => Transformable Text IO (StartupTrace blk) where trTransformer = trStructuredText -instance ( Show (BlockNodeToNodeVersion blk) - , Show (BlockNodeToClientVersion blk) - ) - => HasTextFormatter (StartupTrace blk) where +instance HasTextFormatter (StartupTrace blk) where formatText a _ = ppStartupInfoTrace a instance ( Show (BlockNodeToNodeVersion blk)