diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 8b053a3c05..134dc5963b 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -840,7 +840,10 @@ genPraosNonce = makePraosNonce <$> Gen.bytes (Range.linear 0 32) genMaybePraosNonce :: Gen (Maybe PraosNonce) genMaybePraosNonce = Gen.maybe genPraosNonce -genProtocolParameters :: CardanoEra era -> Gen ProtocolParameters +genFeatureValue :: FeatureInEra feature => CardanoEra era -> Gen a -> Gen (FeatureValue feature era a) +genFeatureValue era g = featureInEra (pure NoFeatureValue) (\w -> fmap (FeatureValue w) g) era + +genProtocolParameters :: CardanoEra era -> Gen (ProtocolParameters era) genProtocolParameters era = do protocolParamProtocolVersion <- (,) <$> genNat <*> genNat protocolParamDecentralization <- Gen.maybe genRational @@ -859,7 +862,7 @@ genProtocolParameters era = do protocolParamPoolPledgeInfluence <- genRationalInt64 protocolParamMonetaryExpansion <- genRational protocolParamTreasuryCut <- genRational - protocolParamUTxOCostPerWord <- featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era + protocolParamUTxOCostPerWord <- genFeatureValue era genLovelace protocolParamCostModels <- pure mempty --TODO: Babbage figure out how to deal with -- asymmetric cost model JSON instances @@ -869,12 +872,12 @@ genProtocolParameters era = do protocolParamMaxValueSize <- Gen.maybe genNat protocolParamCollateralPercent <- Gen.maybe genNat protocolParamMaxCollateralInputs <- Gen.maybe genNat - protocolParamUTxOCostPerByte <- featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era + protocolParamUTxOCostPerByte <- genFeatureValue era genLovelace pure ProtocolParameters {..} -- | Generate valid protocol parameters which pass validations in Cardano.Api.ProtocolParameters -genValidProtocolParameters :: CardanoEra era -> Gen ProtocolParameters +genValidProtocolParameters :: CardanoEra era -> Gen (ProtocolParameters era) genValidProtocolParameters era = ProtocolParameters <$> ((,) <$> genNat <*> genNat) @@ -895,7 +898,7 @@ genValidProtocolParameters era = <*> genRational <*> genRational -- 'Just' is required by checks in Cardano.Api.ProtocolParameters - <*> featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era + <*> genFeatureValue era genLovelace <*> return mempty --TODO: Babbage figure out how to deal with -- asymmetric cost model JSON instances @@ -906,7 +909,7 @@ genValidProtocolParameters era = <*> fmap Just genNat <*> fmap Just genNat <*> fmap Just genNat - <*> featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era + <*> genFeatureValue era genLovelace genProtocolParametersUpdate :: CardanoEra era -> Gen ProtocolParametersUpdate genProtocolParametersUpdate era = do diff --git a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs index 56d2162b08..8cc4372ea8 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs @@ -41,7 +41,7 @@ constructBalancedTx -> AddressInEra era -- ^ Change address -> Maybe Word -- ^ Override key witnesses -> UTxO era -- ^ Just the transaction inputs, not the entire 'UTxO'. - -> ProtocolParameters + -> ProtocolParameters era -> LedgerEpochInfo -> SystemStart -> Set PoolId -- ^ The set of registered stake pools diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index b2fc5349fd..95454bb3ec 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -69,7 +69,7 @@ queryStateForBalancedTx -> [TxIn] -> [Certificate] -> IO (Either QueryConvenienceError ( UTxO era - , ProtocolParameters + , ProtocolParameters era , EraHistory CardanoMode , SystemStart , Set PoolId diff --git a/cardano-api/internal/Cardano/Api/EraCast.hs b/cardano-api/internal/Cardano/Api/EraCast.hs index 8e2a911a4d..7f01bd4e56 100644 --- a/cardano-api/internal/Cardano/Api/EraCast.hs +++ b/cardano-api/internal/Cardano/Api/EraCast.hs @@ -3,6 +3,7 @@ module Cardano.Api.EraCast ( EraCast(..) + , EraCastLossy(..) , EraCastError(..) ) where @@ -26,3 +27,9 @@ class EraCast (f :: Type -> Type) where => CardanoEra toEra -> f fromEra -> Either EraCastError (f toEra) + +class EraCastLossy (f :: Type -> Type) where + eraCastLossy :: () + => CardanoEra toEra + -> f fromEra + -> f toEra diff --git a/cardano-api/internal/Cardano/Api/Feature.hs b/cardano-api/internal/Cardano/Api/Feature.hs index 1d983890c8..7c15629b17 100644 --- a/cardano-api/internal/Cardano/Api/Feature.hs +++ b/cardano-api/internal/Cardano/Api/Feature.hs @@ -1,21 +1,28 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Api.Feature ( FeatureValue (..) , FeatureInEra(..) + , Flip(..) , featureInShelleyBasedEra , valueOrDefault , asFeatureValue , asFeatureValueInShelleyBasedEra - , isFeatureValue + , existsFeatureValue , eraCastLossyFeatureValue + , (.:?^) ) where +import Cardano.Api.EraCast import Cardano.Api.Eras +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types import Data.Kind -- | A class for features that are supported in some eras but not others. @@ -55,12 +62,62 @@ data FeatureValue feature era a where deriving instance (Eq a, Eq (feature era)) => Eq (FeatureValue feature era a) deriving instance (Show a, Show (feature era)) => Show (FeatureValue feature era a) +instance ToJSON a => ToJSON (FeatureValue feature era a) where + toJSON v = + toJSON $ + case v of + NoFeatureValue -> Nothing + FeatureValue _ a -> Just a + +instance (IsCardanoEra era, FromJSON a, FeatureInEra feature) => FromJSON (FeatureValue feature era a) where + parseJSON v = + featureInEra + (pure NoFeatureValue) + (\fe -> FeatureValue fe <$> parseJSON v) + cardanoEra + +newtype Flip t a b = Flip { unFlip :: t b a } + +instance FeatureInEra feature => EraCastLossy (Flip (FeatureValue feature) a) where + eraCastLossy era (Flip fv) = Flip $ eraCastLossyFeatureValue era fv + +eraCastLossyFeatureValue :: () + => FeatureInEra feature + => CardanoEra toEra + -> FeatureValue feature fromEra a + -> FeatureValue feature toEra a +eraCastLossyFeatureValue era fv = + case fv of + FeatureValue _ a -> featureInEra NoFeatureValue (\fe -> FeatureValue fe a) era + NoFeatureValue -> NoFeatureValue + + +(.:?^) :: (IsCardanoEra era, FromJSON a, FeatureInEra feature) => Object -> Key -> Parser (FeatureValue feature era a) +(.:?^) = explicitParseFieldFeatureValue' parseJSON + +-- | Variant of '.:!' with explicit parser function. +explicitParseFieldFeatureValue' :: () + => IsCardanoEra era + => FeatureInEra feature + => (Value -> Parser a) + -> Object + -> Key + -> Parser (FeatureValue feature era a) +explicitParseFieldFeatureValue' p obj key = + case KM.lookup key obj of + Nothing -> pure NoFeatureValue + Just v -> + featureInEra + (fail "") + (\fe -> FeatureValue fe <$> p v) + cardanoEra + -- | Determine if a value is defined. -- -- If the value is not defined, it could be because the feature is not supported or -- because the feature is supported but the value is not available. -isFeatureValue :: FeatureValue feature era a -> Bool -isFeatureValue = \case +existsFeatureValue :: FeatureValue feature era a -> Bool +existsFeatureValue = \case NoFeatureValue -> False FeatureValue _ _ -> True diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 6c204e340f..e7cc4a6b76 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -902,7 +902,7 @@ makeTransactionBodyAutoBalance IsShelleyBasedEra era => SystemStart -> LedgerEpochInfo - -> ProtocolParameters + -> ProtocolParameters era -> Set PoolId -- ^ The set of registered stake pools, that are being -- unregistered in this transaction. -> Map StakeCredential Lovelace @@ -1063,7 +1063,7 @@ makeTransactionBodyAutoBalance systemstart history pparams poolids stakeDelegDep -- TODO: Bug Jared to expose a function from the ledger that returns total and return collateral. calcReturnAndTotalCollateral :: Lovelace -- ^ Fee - -> ProtocolParameters + -> ProtocolParameters era -- ^ Protocol parameters -> TxInsCollateral era -- ^ From the initial TxBodyContent -> TxReturnCollateral CtxTx era -- ^ From the initial TxBodyContent -> TxTotalCollateral era -- ^ From the initial TxBodyContent diff --git a/cardano-api/internal/Cardano/Api/GenesisParameters.hs b/cardano-api/internal/Cardano/Api/GenesisParameters.hs index 73600e333b..a389d0b3b4 100644 --- a/cardano-api/internal/Cardano/Api/GenesisParameters.hs +++ b/cardano-api/internal/Cardano/Api/GenesisParameters.hs @@ -16,7 +16,9 @@ module Cardano.Api.GenesisParameters ( ) where -import Cardano.Api.Eras (ShelleyBasedEra (ShelleyBasedEraShelley)) +import Cardano.Api.EraCast +import Cardano.Api.Eras (ShelleyBasedEra (ShelleyBasedEraShelley), + shelleyBasedToCardanoEra) import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import Cardano.Api.Value @@ -33,7 +35,7 @@ import Data.Time (NominalDiffTime, UTCTime) -- Genesis parameters -- -data GenesisParameters = +data GenesisParameters era = GenesisParameters { -- | The reference time the system started. The time of slot zero. @@ -92,7 +94,7 @@ data GenesisParameters = -- | The initial values of the updateable 'ProtocolParameters'. -- - protocolInitialUpdateableProtocolParameters :: ProtocolParameters + protocolInitialUpdateableProtocolParameters :: ProtocolParameters era } @@ -100,8 +102,8 @@ data GenesisParameters = -- Conversion functions -- -fromShelleyGenesis :: Shelley.ShelleyGenesis Ledger.StandardCrypto -> GenesisParameters -fromShelleyGenesis +fromShelleyGenesis :: ShelleyBasedEra era -> Shelley.ShelleyGenesis Ledger.StandardCrypto -> GenesisParameters era +fromShelleyGenesis sbe Shelley.ShelleyGenesis { Shelley.sgSystemStart , Shelley.sgNetworkMagic @@ -133,7 +135,5 @@ fromShelleyGenesis , protocolParamUpdateQuorum = fromIntegral sgUpdateQuorum , protocolParamMaxLovelaceSupply = Lovelace (fromIntegral sgMaxLovelaceSupply) - , protocolInitialUpdateableProtocolParameters = fromLedgerPParams - ShelleyBasedEraShelley - sgProtocolParams + , protocolInitialUpdateableProtocolParameters = eraCastLossy (shelleyBasedToCardanoEra sbe) (fromLedgerPParams ShelleyBasedEraShelley sgProtocolParams) } diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 5a7c67805f..4f30fb8fa6 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -1656,7 +1656,7 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo bpp ptclState poolid (VrfSign constructGlobals :: ShelleyGenesis Shelley.StandardCrypto -> EpochInfo (Either Text) - -> ProtocolParameters + -> ProtocolParameters era -> Globals constructGlobals sGen eInfo pParams = let majorPParamsVer = fst $ protocolParamProtocolVersion pParams diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index 045121ef3d..d54f1d6ca1 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -79,6 +79,7 @@ module Cardano.Api.ProtocolParameters ( ) where import Cardano.Api.Address +import Cardano.Api.EraCast import Cardano.Api.Eras import Cardano.Api.Error import Cardano.Api.Feature @@ -140,7 +141,7 @@ import Text.PrettyBy.Default (display) -- -- There are also parameters fixed in the Genesis file. See 'GenesisParameters'. -- -data ProtocolParameters = +data ProtocolParameters era = ProtocolParameters { -- | Protocol version, major and minor. Updating the major version is @@ -257,7 +258,7 @@ data ProtocolParameters = -- | Cost in ada per word of UTxO storage. -- -- /Introduced in Alonzo/ - protocolParamUTxOCostPerWord :: Maybe Lovelace, + protocolParamUTxOCostPerWord :: FeatureValue ProtocolUTxOCostPerWordFeature era Lovelace, -- | Cost models for script languages that use them. -- @@ -298,12 +299,43 @@ data ProtocolParameters = -- | Cost in ada per byte of UTxO storage. -- -- /Introduced in Babbage/ - protocolParamUTxOCostPerByte :: Maybe Lovelace + protocolParamUTxOCostPerByte :: FeatureValue ProtocolUTxOCostPerByteFeature era Lovelace } deriving (Eq, Generic, Show) -instance FromJSON ProtocolParameters where +instance EraCastLossy ProtocolParameters where + eraCastLossy era pp = + ProtocolParameters + { protocolParamProtocolVersion = protocolParamProtocolVersion pp + , protocolParamDecentralization = protocolParamDecentralization pp + , protocolParamExtraPraosEntropy = protocolParamExtraPraosEntropy pp + , protocolParamMaxBlockHeaderSize = protocolParamMaxBlockHeaderSize pp + , protocolParamMaxBlockBodySize = protocolParamMaxBlockBodySize pp + , protocolParamMaxTxSize = protocolParamMaxTxSize pp + , protocolParamTxFeeFixed = protocolParamTxFeeFixed pp + , protocolParamTxFeePerByte = protocolParamTxFeePerByte pp + , protocolParamMinUTxOValue = protocolParamMinUTxOValue pp + , protocolParamStakeAddressDeposit = protocolParamStakeAddressDeposit pp + , protocolParamStakePoolDeposit = protocolParamStakePoolDeposit pp + , protocolParamMinPoolCost = protocolParamMinPoolCost pp + , protocolParamPoolRetireMaxEpoch = protocolParamPoolRetireMaxEpoch pp + , protocolParamStakePoolTargetNum = protocolParamStakePoolTargetNum pp + , protocolParamPoolPledgeInfluence = protocolParamPoolPledgeInfluence pp + , protocolParamMonetaryExpansion = protocolParamMonetaryExpansion pp + , protocolParamTreasuryCut = protocolParamTreasuryCut pp + , protocolParamUTxOCostPerWord = eraCastLossyFeatureValue era (protocolParamUTxOCostPerWord pp) + , protocolParamCostModels = protocolParamCostModels pp + , protocolParamPrices = protocolParamPrices pp + , protocolParamMaxTxExUnits = protocolParamMaxTxExUnits pp + , protocolParamMaxBlockExUnits = protocolParamMaxBlockExUnits pp + , protocolParamMaxValueSize = protocolParamMaxValueSize pp + , protocolParamCollateralPercent = protocolParamCollateralPercent pp + , protocolParamMaxCollateralInputs = protocolParamMaxCollateralInputs pp + , protocolParamUTxOCostPerByte = eraCastLossyFeatureValue era (protocolParamUTxOCostPerByte pp) + } + +instance IsCardanoEra era => FromJSON (ProtocolParameters era) where parseJSON = withObject "ProtocolParameters" $ \o -> do v <- o .: "protocolVersion" @@ -325,7 +357,7 @@ instance FromJSON ProtocolParameters where <*> o .: "poolPledgeInfluence" <*> o .: "monetaryExpansion" <*> o .: "treasuryCut" - <*> o .:? "utxoCostPerWord" + <*> o .:?^ "utxoCostPerWord" <*> (fmap unCostModels <$> o .:? "costModels") .!= Map.empty <*> o .:? "executionUnitPrices" <*> o .:? "maxTxExecutionUnits" @@ -333,9 +365,9 @@ instance FromJSON ProtocolParameters where <*> o .:? "maxValueSize" <*> o .:? "collateralPercentage" <*> o .:? "maxCollateralInputs" - <*> o .:? "utxoCostPerByte" + <*> o .:?^ "utxoCostPerByte" -instance ToJSON ProtocolParameters where +instance ToJSON (ProtocolParameters era) where toJSON ProtocolParameters{..} = object [ "extraPraosEntropy" .= protocolParamExtraPraosEntropy @@ -1094,6 +1126,11 @@ toBabbagePParamsUpdate requireParam :: String -> (a -> Either ProtocolParametersConversionError b) -> Maybe a -> Either ProtocolParametersConversionError b requireParam paramName = maybe (Left $ PpceMissingParameter paramName) +requireFeatureParam :: String -> (a -> Either ProtocolParametersConversionError b) -> FeatureValue feature era a -> Either ProtocolParametersConversionError b +requireFeatureParam paramName f fv = case fv of + NoFeatureValue -> Left $ PpceMissingParameter paramName + FeatureValue _ v -> f v + mkProtVer :: (Natural, Natural) -> Either ProtocolParametersConversionError Ledger.ProtVer mkProtVer (majorProtVer, minorProtVer) = maybeToRight (PpceVersionInvalid majorProtVer) $ (`Ledger.ProtVer` minorProtVer) <$> Ledger.mkVersion majorProtVer @@ -1256,16 +1293,16 @@ fromConwayPParamsUpdate = fromBabbagePParamsUpdate -- (which may be the case for some code paths). data BundledProtocolParameters era where BundleAsByronProtocolParameters - :: ProtocolParameters + :: ProtocolParameters ByronEra -> BundledProtocolParameters ByronEra BundleAsShelleyBasedProtocolParameters :: ShelleyBasedEra era - -> ProtocolParameters + -> ProtocolParameters era -> Ledger.PParams (ShelleyLedgerEra era) -> BundledProtocolParameters era bundleProtocolParams :: CardanoEra era - -> ProtocolParameters + -> ProtocolParameters era -> Either ProtocolParametersConversionError (BundledProtocolParameters era) bundleProtocolParams cEra pp = case cardanoEraStyle cEra of LegacyByronEra -> pure $ BundleAsByronProtocolParameters pp @@ -1283,7 +1320,7 @@ unbundleLedgerShelleyBasedProtocolParams = \case ShelleyBasedEraBabbage -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp ShelleyBasedEraConway -> \(BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp -unbundleProtocolParams :: BundledProtocolParameters era -> ProtocolParameters +unbundleProtocolParams :: BundledProtocolParameters era -> ProtocolParameters era unbundleProtocolParams (BundleAsByronProtocolParameters pp) = pp unbundleProtocolParams (BundleAsShelleyBasedProtocolParameters _ pp _) = pp @@ -1293,7 +1330,7 @@ unbundleProtocolParams (BundleAsShelleyBasedProtocolParameters _ pp _) = pp toLedgerPParams :: ShelleyBasedEra era - -> ProtocolParameters + -> ProtocolParameters era -> Either ProtocolParametersConversionError (Ledger.PParams (ShelleyLedgerEra era)) toLedgerPParams ShelleyBasedEraShelley = toShelleyPParams toLedgerPParams ShelleyBasedEraAllegra = toShelleyPParams @@ -1304,7 +1341,7 @@ toLedgerPParams ShelleyBasedEraConway = toConwayPParams toShelleyCommonPParams :: EraPParams ledgerera - => ProtocolParameters + => ProtocolParameters era -> Either ProtocolParametersConversionError (PParams ledgerera) toShelleyCommonPParams ProtocolParameters { @@ -1349,7 +1386,7 @@ toShelleyPParams :: ( EraPParams ledgerera , Ledger.AtMostEra Ledger.MaryEra ledgerera , Ledger.AtMostEra Ledger.AlonzoEra ledgerera ) - => ProtocolParameters + => ProtocolParameters era -> Either ProtocolParametersConversionError (PParams ledgerera) toShelleyPParams protocolParameters@ProtocolParameters { @@ -1369,7 +1406,7 @@ toShelleyPParams toAlonzoCommonPParams :: AlonzoEraPParams ledgerera - => ProtocolParameters + => ProtocolParameters era -> Either ProtocolParametersConversionError (PParams ledgerera) toAlonzoCommonPParams protocolParameters@ProtocolParameters { @@ -1407,7 +1444,7 @@ toAlonzoCommonPParams pure ppAlonzoCommon toAlonzoPParams :: Ledger.Crypto crypto - => ProtocolParameters + => ProtocolParameters era -> Either ProtocolParametersConversionError (PParams (Ledger.AlonzoEra crypto)) toAlonzoPParams protocolParameters@ProtocolParameters { @@ -1432,7 +1469,7 @@ toAlonzoPParams -- (boundRationalEither "D") -- protocolParamDecentralization utxoCostPerWord <- - requireParam "protocolParamUTxOCostPerWord" Right protocolParamUTxOCostPerWord + requireFeatureParam "protocolParamUTxOCostPerWord" Right protocolParamUTxOCostPerWord let ppAlonzo = ppAlonzoCommon & ppDL .~ d @@ -1441,7 +1478,7 @@ toAlonzoPParams toBabbagePParams :: BabbageEraPParams ledgerera - => ProtocolParameters + => ProtocolParameters era -> Either ProtocolParametersConversionError (PParams ledgerera) toBabbagePParams protocolParameters@ProtocolParameters { @@ -1449,14 +1486,14 @@ toBabbagePParams } = do ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters utxoCostPerByte <- - requireParam "protocolParamUTxOCostPerByte" Right protocolParamUTxOCostPerByte + requireFeatureParam "protocolParamUTxOCostPerByte" Right protocolParamUTxOCostPerByte let ppBabbage = ppAlonzoCommon & ppCoinsPerUTxOByteL .~ CoinPerByte (toShelleyLovelace utxoCostPerByte) pure ppBabbage toConwayPParams :: BabbageEraPParams ledgerera - => ProtocolParameters + => ProtocolParameters era -> Either ProtocolParametersConversionError (PParams ledgerera) toConwayPParams = toBabbagePParams @@ -1467,7 +1504,7 @@ toConwayPParams = toBabbagePParams fromLedgerPParams :: ShelleyBasedEra era -> Ledger.PParams (ShelleyLedgerEra era) - -> ProtocolParameters + -> ProtocolParameters era fromLedgerPParams ShelleyBasedEraShelley = fromShelleyPParams fromLedgerPParams ShelleyBasedEraAllegra = fromShelleyPParams fromLedgerPParams ShelleyBasedEraMary = fromShelleyPParams @@ -1478,7 +1515,7 @@ fromLedgerPParams ShelleyBasedEraConway = fromConwayPParams fromShelleyCommonPParams :: EraPParams ledgerera => PParams ledgerera - -> ProtocolParameters + -> ProtocolParameters era fromShelleyCommonPParams pp = ProtocolParameters { protocolParamProtocolVersion = case pp ^. ppProtocolVersionL of @@ -1496,7 +1533,7 @@ fromShelleyCommonPParams pp = , protocolParamPoolPledgeInfluence = Ledger.unboundRational (pp ^. ppA0L) , protocolParamMonetaryExpansion = Ledger.unboundRational (pp ^. ppRhoL) , protocolParamTreasuryCut = Ledger.unboundRational (pp ^. ppTauL) - , protocolParamUTxOCostPerWord = Nothing -- Obsolete from Babbage onwards + , protocolParamUTxOCostPerWord = NoFeatureValue -- Obsolete from Babbage onwards , protocolParamCostModels = mempty -- Only from Alonzo onwards , protocolParamPrices = Nothing -- Only from Alonzo onwards , protocolParamMaxTxExUnits = Nothing -- Only from Alonzo onwards @@ -1504,7 +1541,7 @@ fromShelleyCommonPParams pp = , protocolParamMaxValueSize = Nothing -- Only from Alonzo onwards , protocolParamCollateralPercent = Nothing -- Only from Alonzo onwards , protocolParamMaxCollateralInputs = Nothing -- Only from Alonzo onwards - , protocolParamUTxOCostPerByte = Nothing -- Only from Babbage onwards + , protocolParamUTxOCostPerByte = NoFeatureValue -- Only from Babbage onwards , protocolParamDecentralization = Nothing -- Obsolete from Babbage onwards , protocolParamExtraPraosEntropy = Nothing -- Obsolete from Alonzo onwards , protocolParamMinUTxOValue = Nothing -- Obsolete from Alonzo onwards @@ -1515,7 +1552,7 @@ fromShelleyPParams :: ( EraPParams ledgerera , Ledger.AtMostEra Ledger.AlonzoEra ledgerera ) => PParams ledgerera - -> ProtocolParameters + -> ProtocolParameters era fromShelleyPParams pp = (fromShelleyCommonPParams pp) { protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDL @@ -1526,7 +1563,7 @@ fromShelleyPParams pp = fromAlonzoCommonPParams :: AlonzoEraPParams ledgerera => PParams ledgerera - -> ProtocolParameters + -> ProtocolParameters era fromAlonzoCommonPParams pp = (fromShelleyCommonPParams pp) { protocolParamCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL @@ -1541,31 +1578,36 @@ fromAlonzoCommonPParams pp = fromAlonzoPParams :: Ledger.Crypto crypto => PParams (Ledger.AlonzoEra crypto) - -> ProtocolParameters + -> ProtocolParameters AlonzoEra fromAlonzoPParams pp = (fromAlonzoCommonPParams pp) { - protocolParamUTxOCostPerWord = Just . fromShelleyLovelace . unCoinPerWord $ + protocolParamUTxOCostPerWord = FeatureValue ProtocolUpdateUTxOCostPerWordInAlonzoEra . fromShelleyLovelace . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL } fromBabbagePParams :: BabbageEraPParams ledgerera + => IsCardanoEra era => PParams ledgerera - -> ProtocolParameters + -> ProtocolParameters era fromBabbagePParams pp = (fromAlonzoCommonPParams pp) { - protocolParamUTxOCostPerByte = Just . fromShelleyLovelace . unCoinPerByte $ - pp ^. ppCoinsPerUTxOByteL + protocolParamUTxOCostPerByte = + featureInEra + NoFeatureValue + (\w -> FeatureValue w . fromShelleyLovelace . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL) + cardanoEra } fromConwayPParams :: BabbageEraPParams ledgerera + => IsCardanoEra era => PParams ledgerera - -> ProtocolParameters + -> ProtocolParameters era fromConwayPParams = fromBabbagePParams checkProtocolParameters :: forall era. IsCardanoEra era => ShelleyBasedEra era - -> ProtocolParameters + -> ProtocolParameters era -> Either ProtocolParametersError () checkProtocolParameters sbe ProtocolParameters{..} = case sbe of @@ -1579,7 +1621,7 @@ checkProtocolParameters sbe ProtocolParameters{..} = era :: CardanoEra era era = shelleyBasedToCardanoEra sbe - costPerWord = isJust protocolParamUTxOCostPerWord + costPerWord = existsFeatureValue protocolParamUTxOCostPerWord cModel = not $ Map.null protocolParamCostModels prices = isJust protocolParamPrices maxTxUnits = isJust protocolParamMaxTxExUnits @@ -1587,7 +1629,7 @@ checkProtocolParameters sbe ProtocolParameters{..} = maxValueSize = isJust protocolParamMaxValueSize collateralPercent = isJust protocolParamCollateralPercent maxCollateralInputs = isJust protocolParamMaxCollateralInputs - costPerByte = isJust protocolParamUTxOCostPerByte + costPerByte = existsFeatureValue protocolParamUTxOCostPerByte decentralization = isJust protocolParamDecentralization extraPraosEntropy = isJust protocolParamExtraPraosEntropy diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 0b2e1fb190..5b74b92815 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -237,10 +237,10 @@ data QueryInShelleyBasedEra era result where :: QueryInShelleyBasedEra era EpochNo QueryGenesisParameters - :: QueryInShelleyBasedEra era GenesisParameters + :: QueryInShelleyBasedEra era (GenesisParameters era) QueryProtocolParameters - :: QueryInShelleyBasedEra era ProtocolParameters + :: QueryInShelleyBasedEra era (ProtocolParameters era) QueryProtocolParametersUpdate :: QueryInShelleyBasedEra era @@ -861,9 +861,9 @@ fromConsensusQueryResultShelleyBased _ QueryEpoch q' epoch = Consensus.GetEpochNo -> epoch _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResultShelleyBased _ QueryGenesisParameters q' r' = +fromConsensusQueryResultShelleyBased sbe QueryGenesisParameters q' r' = case q' of - Consensus.GetGenesisConfig -> fromShelleyGenesis + Consensus.GetGenesisConfig -> fromShelleyGenesis sbe (Consensus.getCompactGenesis r') _ -> fromConsensusQueryResultMismatch diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 8df89d4a7f..0eafd7b714 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1713,7 +1713,7 @@ data TxBodyContent build era = txMetadata :: TxMetadataInEra era, txAuxScripts :: TxAuxScripts era, txExtraKeyWits :: TxExtraKeyWitnesses era, - txProtocolParams :: BuildTxWith build (Maybe ProtocolParameters), + txProtocolParams :: BuildTxWith build (Maybe (ProtocolParameters era)), txWithdrawals :: TxWithdrawals build era, txCertificates :: TxCertificates build era, txUpdateProposal :: TxUpdateProposal era, @@ -1788,7 +1788,7 @@ setTxAuxScripts v txBodyContent = txBodyContent { txAuxScripts = v } setTxExtraKeyWits :: TxExtraKeyWitnesses era -> TxBodyContent build era -> TxBodyContent build era setTxExtraKeyWits v txBodyContent = txBodyContent { txExtraKeyWits = v } -setTxProtocolParams :: BuildTxWith build (Maybe ProtocolParameters) -> TxBodyContent build era -> TxBodyContent build era +setTxProtocolParams :: BuildTxWith build (Maybe (ProtocolParameters era)) -> TxBodyContent build era -> TxBodyContent build era setTxProtocolParams v txBodyContent = txBodyContent { txProtocolParams = v } setTxWithdrawals :: TxWithdrawals build era -> TxBodyContent build era -> TxBodyContent build era @@ -2517,7 +2517,7 @@ validateTxBodyContent :: ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError () -validateTxBodyContent era txBodContent@TxBodyContent { +validateTxBodyContent sbe txBodContent@TxBodyContent { txIns, txInsCollateral, txOuts, @@ -2529,46 +2529,46 @@ validateTxBodyContent era txBodContent@TxBodyContent { [ toAlonzoLanguage (AnyPlutusScriptVersion v) | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses ] - in case era of + in case sbe of ShelleyBasedEraShelley -> do validateTxIns txIns guardShelleyTxInsOverflow (map fst txIns) - validateTxOuts era txOuts + validateTxOuts sbe txOuts validateMetadata txMetadata ShelleyBasedEraAllegra -> do validateTxIns txIns guardShelleyTxInsOverflow (map fst txIns) - validateTxOuts era txOuts + validateTxOuts sbe txOuts validateMetadata txMetadata ShelleyBasedEraMary -> do validateTxIns txIns guardShelleyTxInsOverflow (map fst txIns) - validateTxOuts era txOuts + validateTxOuts sbe txOuts validateMetadata txMetadata validateMintValue txMintValue ShelleyBasedEraAlonzo -> do validateTxIns txIns guardShelleyTxInsOverflow (map fst txIns) - validateTxOuts era txOuts + validateTxOuts sbe txOuts validateMetadata txMetadata validateMintValue txMintValue validateTxInsCollateral txInsCollateral languages - validateProtocolParameters txProtocolParams languages + validateProtocolParameters sbe txProtocolParams languages ShelleyBasedEraBabbage -> do validateTxIns txIns guardShelleyTxInsOverflow (map fst txIns) - validateTxOuts era txOuts + validateTxOuts sbe txOuts validateMetadata txMetadata validateMintValue txMintValue validateTxInsCollateral txInsCollateral languages - validateProtocolParameters txProtocolParams languages + validateProtocolParameters sbe txProtocolParams languages ShelleyBasedEraConway -> do validateTxIns txIns - validateTxOuts era txOuts + validateTxOuts sbe txOuts validateMetadata txMetadata validateMintValue txMintValue validateTxInsCollateral txInsCollateral languages - validateProtocolParameters txProtocolParams languages + validateProtocolParameters sbe txProtocolParams languages validateMetadata :: TxMetadataInEra era -> Either TxBodyError () validateMetadata txMetadata = @@ -2577,10 +2577,11 @@ validateMetadata txMetadata = TxMetadataInEra _ m -> first TxBodyMetadataError (validateTxMetadata m) validateProtocolParameters - :: BuildTxWith BuildTx (Maybe ProtocolParameters) + :: ShelleyBasedEra era + -> BuildTxWith BuildTx (Maybe (ProtocolParameters era)) -> Set Alonzo.Language -> Either TxBodyError () -validateProtocolParameters txProtocolParams languages = +validateProtocolParameters _sbe txProtocolParams languages = case txProtocolParams of BuildTxWith Nothing | not (Set.null languages) -> Left TxBodyMissingProtocolParams @@ -3536,7 +3537,7 @@ convScriptData era txOuts scriptWitnesses = convPParamsToScriptIntegrityHash :: L.AlonzoEraPParams (ShelleyLedgerEra era) => ShelleyBasedEra era - -> BuildTxWith BuildTx (Maybe ProtocolParameters) + -> BuildTxWith BuildTx (Maybe (ProtocolParameters era)) -> Alonzo.Redeemers (ShelleyLedgerEra era) -> Alonzo.TxDats (ShelleyLedgerEra era) -> Set Alonzo.Language