diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index b50fcff0e1..7f9a24ae16 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -97,9 +97,7 @@ module Test.Gen.Cardano.Api.Typed , genTxOutDatumHashUTxOContext , genTxOutValue , genTxReturnCollateral - , genTxScriptValidity , genTxTotalCollateral - , genTxUpdateProposal , genTxValidityLowerBound , genTxValidityRange , genTxValidityUpperBound @@ -605,16 +603,6 @@ genCertificate = , StakeAddressDeregistrationCertificate <$> genStakeCredential ] -genTxUpdateProposal :: CardanoEra era -> Gen (TxUpdateProposal era) -genTxUpdateProposal era = - case updateProposalSupportedInEra era of - Nothing -> pure TxUpdateProposalNone - Just supported -> - Gen.choice - [ pure TxUpdateProposalNone - , TxUpdateProposal supported <$> genUpdateProposal era - ] - genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era) genTxMintValue era = case multiAssetSupportedInEra era of @@ -641,9 +629,9 @@ genTxBodyContent era = do txProtocolParams <- BuildTxWith <$> Gen.maybe (genValidProtocolParameters era) txWithdrawals <- genTxWithdrawals era txCertificates <- genTxCertificates era - txUpdateProposal <- genTxUpdateProposal era + txUpdateProposal <- genFeatureValueInEra (genUpdateProposal era) era txMintValue <- genTxMintValue era - txScriptValidity <- genTxScriptValidity era + txScriptValidity <- genFeatureValueInEra genScriptValidity era pure $ TxBodyContent { Api.txIns @@ -718,11 +706,6 @@ genFeatureValueInEra gen = featureInEra (pure NoFeatureValue) $ \witness -> pure NoFeatureValue <|> fmap (FeatureValue witness) gen -genTxScriptValidity :: CardanoEra era -> Gen (TxScriptValidity era) -genTxScriptValidity era = case txScriptValiditySupportedInCardanoEra era of - Nothing -> pure TxScriptValidityNone - Just witness -> TxScriptValidity witness <$> genScriptValidity - genScriptValidity :: Gen ScriptValidity genScriptValidity = Gen.element [ScriptInvalid, ScriptValid] diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index af39b175cd..a645f5f66d 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -44,6 +44,7 @@ import Cardano.Api.Address import Cardano.Api.Certificate import Cardano.Api.Eras import Cardano.Api.Error +import Cardano.Api.Feature import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import Cardano.Api.Query @@ -303,9 +304,9 @@ estimateTransactionKeyWitnessCount TxBodyContent { _ -> 0 + case txUpdateProposal of - TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) + FeatureValue _ (UpdateProposal updatePerGenesisKey _) -> Map.size updatePerGenesisKey - _ -> 0 + NoFeatureValue -> 0 -- ---------------------------------------------------------------------------- @@ -674,7 +675,7 @@ evaluateTransactionBalance bpp poolids stakeDelegDeposits utxo => ShelleyEraTxBody ledgerera => LedgerEraConstraints ledgerera => LedgerMultiAssetConstraints ledgerera - => MultiAssetSupportedInEra era + => MultiAssetFeature era -> TxOutValue era evalMultiAsset evidence = TxOutValue evidence . fromMaryValue $ @@ -690,7 +691,7 @@ evaluateTransactionBalance bpp poolids stakeDelegDeposits utxo => ShelleyEraTxBody ledgerera => LedgerEraConstraints ledgerera => LedgerAdaOnlyConstraints ledgerera - => OnlyAdaSupportedInEra era + => OnlyAdaFeature era -> TxOutValue era evalAdaOnly evidence = TxOutAdaOnly evidence . fromShelleyLovelace @@ -709,13 +710,13 @@ evaluateTransactionBalance bpp poolids stakeDelegDeposits utxo => LedgerAdaOnlyConstraints ledgerera => LedgerPParamsConstraints ledgerera => LedgerTxBodyConstraints ledgerera - => OnlyAdaSupportedInEra era + => OnlyAdaFeature era -> a) -> ( LedgerEraConstraints ledgerera => LedgerMultiAssetConstraints ledgerera => LedgerPParamsConstraints ledgerera => LedgerTxBodyConstraints ledgerera - => MultiAssetSupportedInEra era + => MultiAssetFeature era -> a) -> a withLedgerConstraints ShelleyBasedEraShelley f _ = f AdaOnlyInShelleyEra @@ -939,7 +940,7 @@ makeTransactionBodyAutoBalance systemstart history pparams poolids stakeDelegDep case Map.mapEither id exUnitsMap of (failures, exUnitsMap') -> handleExUnitsErrors - (txScriptValidityToScriptValidity (txScriptValidity txbodycontent)) + (valueOrDefault defaultScriptValidity (txScriptValidity txbodycontent)) failures exUnitsMap' diff --git a/cardano-api/internal/Cardano/Api/Tx.hs b/cardano-api/internal/Cardano/Api/Tx.hs index e9d2dd5682..ef3ef81f06 100644 --- a/cardano-api/internal/Cardano/Api/Tx.hs +++ b/cardano-api/internal/Cardano/Api/Tx.hs @@ -50,6 +50,7 @@ module Cardano.Api.Tx ( import Cardano.Api.Address import Cardano.Api.Certificate import Cardano.Api.Eras +import Cardano.Api.Feature import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Byron import Cardano.Api.Keys.Class @@ -490,13 +491,13 @@ getTxBody (ShelleyTx era tx') = (Map.elems scriptWits) TxBodyNoScriptData (strictMaybeToMaybe txAuxData) - TxScriptValidityNone + NoFeatureValue getAlonzoTxBody :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera => L.AlonzoEraTx ledgerera => ScriptDataSupportedInEra era - -> TxScriptValiditySupportedInEra era + -> TxScriptValidityFeature era -> L.Tx ledgerera -> TxBody era getAlonzoTxBody scriptDataInEra txScriptValidityInEra tx = @@ -510,7 +511,7 @@ getTxBody (ShelleyTx era tx') = (Map.elems scriptWits) (TxBodyScriptData scriptDataInEra datsWits redeemerWits) (strictMaybeToMaybe txAuxData) - (TxScriptValidity txScriptValidityInEra (isValidToScriptValidity isValid)) + (FeatureValue txScriptValidityInEra (isValidToScriptValidity isValid)) getTxWitnesses :: forall era. Tx era -> [KeyWitness era] getTxWitnesses (ByronTx Byron.ATxAux { Byron.aTaWitness = witnesses }) = @@ -607,7 +608,7 @@ makeSignedTransaction witnesses (ShelleyTxBody era txbody (txCommon & L.witsTxL . L.datsTxWitsL .~ datums & L.witsTxL . L.rdmrsTxWitsL .~ redeemers - & L.isValidTxL .~ txScriptValidityToIsValid scriptValidity) + & L.isValidTxL .~ scriptValidityToIsValid (valueOrDefault defaultScriptValidity scriptValidity)) where (datums, redeemers) = case txscriptdata of diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 1f16dcc341..f6ce46cb3a 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -57,15 +57,14 @@ module Cardano.Api.TxBody ( setTxScriptValidity, TxBodyError(..), TxBodyScriptData(..), - TxScriptValidity(..), - TxScriptValiditySupportedInEra(..), ScriptValidity(..), + defaultScriptValidity, + + TxScriptValidityFeature(..), + scriptValidityToIsValid, isValidToScriptValidity, - scriptValidityToTxScriptValidity, - txScriptValidityToIsValid, - txScriptValidityToScriptValidity, -- * Transaction Ids TxId(..), @@ -105,7 +104,6 @@ module Cardano.Api.TxBody ( TxExtraKeyWitnesses(..), TxWithdrawals(..), TxCertificates(..), - TxUpdateProposal(..), TxMintValue(..), -- ** Building vs viewing transactions @@ -115,8 +113,8 @@ module Cardano.Api.TxBody ( -- * Era-dependent transaction body features CollateralSupportedInEra(..), - MultiAssetSupportedInEra(..), - OnlyAdaSupportedInEra(..), + MultiAssetFeature(..), + OnlyAdaFeature(..), TxFeesExplicitInEra(..), TxFeesImplicitInEra(..), ValidityUpperBoundSupportedInEra(..), @@ -128,12 +126,13 @@ module Cardano.Api.TxBody ( ScriptDataSupportedInEra(..), WithdrawalsSupportedInEra(..), CertificatesSupportedInEra(..), - UpdateProposalSupportedInEra(..), + UpdateProposalFeature(..), TxTotalAndReturnCollateralSupportedInEra(..), -- ** Feature availability functions collateralSupportedInEra, multiAssetSupportedInEra, + onlyAdaOrMultiAssetFeatureInEra, txFeesExplicitInEra, validityUpperBoundSupportedInEra, validityNoUpperBoundSupportedInEra, @@ -144,9 +143,6 @@ module Cardano.Api.TxBody ( scriptDataSupportedInEra, withdrawalsSupportedInEra, certificatesSupportedInEra, - updateProposalSupportedInEra, - txScriptValiditySupportedInShelleyBasedEra, - txScriptValiditySupportedInCardanoEra, totalAndReturnCollateralSupportedInEra, -- * Inspecting 'ScriptWitness'es @@ -188,6 +184,7 @@ import Cardano.Api.Convenience.Constraints import Cardano.Api.EraCast import Cardano.Api.Eras import Cardano.Api.Error +import Cardano.Api.Feature import Cardano.Api.Hash import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Byron @@ -300,58 +297,26 @@ isValidToScriptValidity :: L.IsValid -> ScriptValidity isValidToScriptValidity (L.IsValid False) = ScriptInvalid isValidToScriptValidity (L.IsValid True) = ScriptValid --- | A representation of whether the era supports tx script validity. --- --- The Alonzo and subsequent eras support script validity. --- -data TxScriptValidity era where - TxScriptValidityNone :: TxScriptValidity era - - -- | Tx script validity is supported in transactions in the 'Alonzo' era onwards. - TxScriptValidity - :: TxScriptValiditySupportedInEra era - -> ScriptValidity - -> TxScriptValidity era - -deriving instance Eq (TxScriptValiditySupportedInEra era) -deriving instance Show (TxScriptValiditySupportedInEra era) - -data TxScriptValiditySupportedInEra era where - TxScriptValiditySupportedInAlonzoEra :: TxScriptValiditySupportedInEra AlonzoEra - TxScriptValiditySupportedInBabbageEra :: TxScriptValiditySupportedInEra BabbageEra - TxScriptValiditySupportedInConwayEra :: TxScriptValiditySupportedInEra ConwayEra - -deriving instance Eq (TxScriptValidity era) -deriving instance Show (TxScriptValidity era) - -txScriptValiditySupportedInCardanoEra :: CardanoEra era -> Maybe (TxScriptValiditySupportedInEra era) -txScriptValiditySupportedInCardanoEra ByronEra = Nothing -txScriptValiditySupportedInCardanoEra ShelleyEra = Nothing -txScriptValiditySupportedInCardanoEra AllegraEra = Nothing -txScriptValiditySupportedInCardanoEra MaryEra = Nothing -txScriptValiditySupportedInCardanoEra AlonzoEra = Just TxScriptValiditySupportedInAlonzoEra -txScriptValiditySupportedInCardanoEra BabbageEra = Just TxScriptValiditySupportedInBabbageEra -txScriptValiditySupportedInCardanoEra ConwayEra = Just TxScriptValiditySupportedInConwayEra - -txScriptValiditySupportedInShelleyBasedEra :: ShelleyBasedEra era -> Maybe (TxScriptValiditySupportedInEra era) -txScriptValiditySupportedInShelleyBasedEra ShelleyBasedEraShelley = Nothing -txScriptValiditySupportedInShelleyBasedEra ShelleyBasedEraAllegra = Nothing -txScriptValiditySupportedInShelleyBasedEra ShelleyBasedEraMary = Nothing -txScriptValiditySupportedInShelleyBasedEra ShelleyBasedEraAlonzo = Just TxScriptValiditySupportedInAlonzoEra -txScriptValiditySupportedInShelleyBasedEra ShelleyBasedEraBabbage = Just TxScriptValiditySupportedInBabbageEra -txScriptValiditySupportedInShelleyBasedEra ShelleyBasedEraConway = Just TxScriptValiditySupportedInConwayEra - -txScriptValidityToScriptValidity :: TxScriptValidity era -> ScriptValidity -txScriptValidityToScriptValidity TxScriptValidityNone = ScriptValid -txScriptValidityToScriptValidity (TxScriptValidity _ scriptValidity) = scriptValidity - -scriptValidityToTxScriptValidity :: ShelleyBasedEra era -> ScriptValidity -> TxScriptValidity era -scriptValidityToTxScriptValidity era scriptValidity = case txScriptValiditySupportedInShelleyBasedEra era of - Nothing -> TxScriptValidityNone - Just witness -> TxScriptValidity witness scriptValidity - -txScriptValidityToIsValid :: TxScriptValidity era -> L.IsValid -txScriptValidityToIsValid = scriptValidityToIsValid . txScriptValidityToScriptValidity +data TxScriptValidityFeature era where + TxScriptValiditySupportedInAlonzoEra :: TxScriptValidityFeature AlonzoEra + TxScriptValiditySupportedInBabbageEra :: TxScriptValidityFeature BabbageEra + TxScriptValiditySupportedInConwayEra :: TxScriptValidityFeature ConwayEra + +deriving instance Eq (TxScriptValidityFeature era) +deriving instance Show (TxScriptValidityFeature era) + +instance FeatureInEra TxScriptValidityFeature where + featureInEra no yes = \case + ByronEra -> no + ShelleyEra -> no + AllegraEra -> no + MaryEra -> no + AlonzoEra -> yes TxScriptValiditySupportedInAlonzoEra + BabbageEra -> yes TxScriptValiditySupportedInBabbageEra + ConwayEra -> yes TxScriptValiditySupportedInConwayEra + +defaultScriptValidity :: ScriptValidity +defaultScriptValidity = ScriptValid -- ---------------------------------------------------------------------------- -- Transaction outputs @@ -930,56 +895,83 @@ collateralSupportedInEra ConwayEra = Just CollateralInConwayEra -- -- The Mary and subsequent eras support multi-asset transactions. -- --- The negation of this is 'OnlyAdaSupportedInEra'. +-- The negation of this is 'OnlyAdaFeature'. -- -data MultiAssetSupportedInEra era where +data MultiAssetFeature era where -- | Multi-asset transactions are supported in the 'Mary' era. - MultiAssetInMaryEra :: MultiAssetSupportedInEra MaryEra + MultiAssetInMaryEra :: MultiAssetFeature MaryEra -- | Multi-asset transactions are supported in the 'Alonzo' era. - MultiAssetInAlonzoEra :: MultiAssetSupportedInEra AlonzoEra + MultiAssetInAlonzoEra :: MultiAssetFeature AlonzoEra -- | Multi-asset transactions are supported in the 'Babbage' era. - MultiAssetInBabbageEra :: MultiAssetSupportedInEra BabbageEra + MultiAssetInBabbageEra :: MultiAssetFeature BabbageEra -- | Multi-asset transactions are supported in the 'Conway' era. - MultiAssetInConwayEra :: MultiAssetSupportedInEra ConwayEra + MultiAssetInConwayEra :: MultiAssetFeature ConwayEra -deriving instance Eq (MultiAssetSupportedInEra era) -deriving instance Show (MultiAssetSupportedInEra era) +deriving instance Eq (MultiAssetFeature era) +deriving instance Show (MultiAssetFeature era) -instance ToJSON (MultiAssetSupportedInEra era) where +instance ToJSON (MultiAssetFeature era) where toJSON = Aeson.String . Text.pack . show +instance FeatureInEra MultiAssetFeature where + featureInEra no yes = \case + ByronEra -> no + ShelleyEra -> no + AllegraEra -> no + MaryEra -> yes MultiAssetInMaryEra + AlonzoEra -> yes MultiAssetInAlonzoEra + BabbageEra -> yes MultiAssetInBabbageEra + ConwayEra -> yes MultiAssetInConwayEra + -- | A representation of whether the era supports only ada transactions. -- -- Prior to the Mary era only ada transactions are supported. Multi-assets are -- supported from the Mary era onwards. -- --- This is the negation of 'MultiAssetSupportedInEra'. It exists since we need +-- This is the negation of 'MultiAssetFeature'. It exists since we need -- evidence to be positive. -- -data OnlyAdaSupportedInEra era where - - AdaOnlyInByronEra :: OnlyAdaSupportedInEra ByronEra - AdaOnlyInShelleyEra :: OnlyAdaSupportedInEra ShelleyEra - AdaOnlyInAllegraEra :: OnlyAdaSupportedInEra AllegraEra - -deriving instance Eq (OnlyAdaSupportedInEra era) -deriving instance Show (OnlyAdaSupportedInEra era) +data OnlyAdaFeature era where + + AdaOnlyInByronEra :: OnlyAdaFeature ByronEra + AdaOnlyInShelleyEra :: OnlyAdaFeature ShelleyEra + AdaOnlyInAllegraEra :: OnlyAdaFeature AllegraEra + +deriving instance Eq (OnlyAdaFeature era) +deriving instance Show (OnlyAdaFeature era) + +instance FeatureInEra OnlyAdaFeature where + featureInEra no yes = \case + ByronEra -> yes AdaOnlyInByronEra + ShelleyEra -> yes AdaOnlyInShelleyEra + AllegraEra -> yes AdaOnlyInAllegraEra + MaryEra -> no + AlonzoEra -> no + BabbageEra -> no + ConwayEra -> no + +onlyAdaOrMultiAssetFeatureInEra :: () + => (OnlyAdaFeature era -> a) -- ^ Value to use if the feature is not supported in the era + -> (MultiAssetFeature era -> b) -- ^ Function to get thealue to use if the feature is supported in the era + -> CardanoEra era -- ^ Era to check + -> Either a b +onlyAdaOrMultiAssetFeatureInEra onlyAda multiAsset era = + featureInEra + (featureInEra + (error "IMPOSSIBLE: This is checked by prop_total_onlyAdaOrMultiAssetFeatureInEra") + (Left . onlyAda) + era) + (Right . multiAsset) + era multiAssetSupportedInEra :: CardanoEra era - -> Either (OnlyAdaSupportedInEra era) - (MultiAssetSupportedInEra era) -multiAssetSupportedInEra ByronEra = Left AdaOnlyInByronEra -multiAssetSupportedInEra ShelleyEra = Left AdaOnlyInShelleyEra -multiAssetSupportedInEra AllegraEra = Left AdaOnlyInAllegraEra -multiAssetSupportedInEra MaryEra = Right MultiAssetInMaryEra -multiAssetSupportedInEra AlonzoEra = Right MultiAssetInAlonzoEra -multiAssetSupportedInEra BabbageEra = Right MultiAssetInBabbageEra -multiAssetSupportedInEra ConwayEra = Right MultiAssetInConwayEra - + -> Either (OnlyAdaFeature era) + (MultiAssetFeature era) +multiAssetSupportedInEra = onlyAdaOrMultiAssetFeatureInEra id id -- | A representation of whether the era requires explicitly specified fees in -- transactions. @@ -1281,27 +1273,26 @@ certificatesSupportedInEra ConwayEra = Just CertificatesInConwayEra -- era has a notion of an update proposal, but it is a standalone chain object -- and not embedded in a transaction. -- -data UpdateProposalSupportedInEra era where - - UpdateProposalInShelleyEra :: UpdateProposalSupportedInEra ShelleyEra - UpdateProposalInAllegraEra :: UpdateProposalSupportedInEra AllegraEra - UpdateProposalInMaryEra :: UpdateProposalSupportedInEra MaryEra - UpdateProposalInAlonzoEra :: UpdateProposalSupportedInEra AlonzoEra - UpdateProposalInBabbageEra :: UpdateProposalSupportedInEra BabbageEra - UpdateProposalInConwayEra :: UpdateProposalSupportedInEra ConwayEra - -deriving instance Eq (UpdateProposalSupportedInEra era) -deriving instance Show (UpdateProposalSupportedInEra era) - -updateProposalSupportedInEra :: CardanoEra era - -> Maybe (UpdateProposalSupportedInEra era) -updateProposalSupportedInEra ByronEra = Nothing -updateProposalSupportedInEra ShelleyEra = Just UpdateProposalInShelleyEra -updateProposalSupportedInEra AllegraEra = Just UpdateProposalInAllegraEra -updateProposalSupportedInEra MaryEra = Just UpdateProposalInMaryEra -updateProposalSupportedInEra AlonzoEra = Just UpdateProposalInAlonzoEra -updateProposalSupportedInEra BabbageEra = Just UpdateProposalInBabbageEra -updateProposalSupportedInEra ConwayEra = Just UpdateProposalInConwayEra +data UpdateProposalFeature era where + UpdateProposalInShelleyEra :: UpdateProposalFeature ShelleyEra + UpdateProposalInAllegraEra :: UpdateProposalFeature AllegraEra + UpdateProposalInMaryEra :: UpdateProposalFeature MaryEra + UpdateProposalInAlonzoEra :: UpdateProposalFeature AlonzoEra + UpdateProposalInBabbageEra :: UpdateProposalFeature BabbageEra + UpdateProposalInConwayEra :: UpdateProposalFeature ConwayEra + +deriving instance Eq (UpdateProposalFeature era) +deriving instance Show (UpdateProposalFeature era) + +instance FeatureInEra UpdateProposalFeature where + featureInEra no yes = \case + ByronEra -> no + ShelleyEra -> yes UpdateProposalInShelleyEra + AllegraEra -> yes UpdateProposalInAllegraEra + MaryEra -> yes UpdateProposalInMaryEra + AlonzoEra -> yes UpdateProposalInAlonzoEra + BabbageEra -> yes UpdateProposalInBabbageEra + ConwayEra -> yes UpdateProposalInConwayEra -- ---------------------------------------------------------------------------- -- Building vs viewing transactions @@ -1356,9 +1347,9 @@ deriving instance Show (TxInsReference build era) data TxOutValue era where - TxOutAdaOnly :: OnlyAdaSupportedInEra era -> Lovelace -> TxOutValue era + TxOutAdaOnly :: OnlyAdaFeature era -> Lovelace -> TxOutValue era - TxOutValue :: MultiAssetSupportedInEra era -> Value -> TxOutValue era + TxOutValue :: MultiAssetFeature era -> Value -> TxOutValue era instance EraCast TxOutValue where eraCast toEra v = case v of @@ -1366,7 +1357,7 @@ instance EraCast TxOutValue where case multiAssetSupportedInEra toEra of Left adaOnly -> Right $ TxOutAdaOnly adaOnly lovelace Right multiAssetSupp -> Right $ TxOutValue multiAssetSupp $ lovelaceToValue lovelace - TxOutValue (_ :: MultiAssetSupportedInEra fromEra) value -> + TxOutValue (_ :: MultiAssetFeature fromEra) value -> case multiAssetSupportedInEra toEra of Left _adaOnly -> Left $ EraCastError v (cardanoEra @fromEra) toEra Right multiAssetSupp -> Right $ TxOutValue multiAssetSupp value @@ -1696,21 +1687,6 @@ data TxCertificates build era where deriving instance Eq (TxCertificates build era) deriving instance Show (TxCertificates build era) --- ---------------------------------------------------------------------------- --- Transaction update proposal (era-dependent) --- - -data TxUpdateProposal era where - - TxUpdateProposalNone :: TxUpdateProposal era - - TxUpdateProposal :: UpdateProposalSupportedInEra era - -> UpdateProposal - -> TxUpdateProposal era - -deriving instance Eq (TxUpdateProposal era) -deriving instance Show (TxUpdateProposal era) - -- ---------------------------------------------------------------------------- -- Value minting within transactions (era-dependent) -- @@ -1719,7 +1695,7 @@ data TxMintValue build era where TxMintNone :: TxMintValue build era - TxMintValue :: MultiAssetSupportedInEra era + TxMintValue :: MultiAssetFeature era -> Value -> BuildTxWith build (Map PolicyId (ScriptWitness WitCtxMint era)) @@ -1749,9 +1725,9 @@ data TxBodyContent build era = txProtocolParams :: BuildTxWith build (Maybe ProtocolParameters), txWithdrawals :: TxWithdrawals build era, txCertificates :: TxCertificates build era, - txUpdateProposal :: TxUpdateProposal era, + txUpdateProposal :: FeatureValue UpdateProposalFeature era UpdateProposal, txMintValue :: TxMintValue build era, - txScriptValidity :: TxScriptValidity era + txScriptValidity :: FeatureValue TxScriptValidityFeature era ScriptValidity } deriving (Eq, Show) @@ -1771,9 +1747,9 @@ defaultTxBodyContent = TxBodyContent , txProtocolParams = BuildTxWith Nothing , txWithdrawals = TxWithdrawalsNone , txCertificates = TxCertificatesNone - , txUpdateProposal = TxUpdateProposalNone + , txUpdateProposal = NoFeatureValue , txMintValue = TxMintNone - , txScriptValidity = TxScriptValidityNone + , txScriptValidity = NoFeatureValue } setTxIns :: TxIns build era -> TxBodyContent build era -> TxBodyContent build era @@ -1830,13 +1806,13 @@ setTxWithdrawals v txBodyContent = txBodyContent { txWithdrawals = v } setTxCertificates :: TxCertificates build era -> TxBodyContent build era -> TxBodyContent build era setTxCertificates v txBodyContent = txBodyContent { txCertificates = v } -setTxUpdateProposal :: TxUpdateProposal era -> TxBodyContent build era -> TxBodyContent build era +setTxUpdateProposal :: FeatureValue UpdateProposalFeature era UpdateProposal -> TxBodyContent build era -> TxBodyContent build era setTxUpdateProposal v txBodyContent = txBodyContent { txUpdateProposal = v } setTxMintValue :: TxMintValue build era -> TxBodyContent build era -> TxBodyContent build era setTxMintValue v txBodyContent = txBodyContent { txMintValue = v } -setTxScriptValidity :: TxScriptValidity era -> TxBodyContent build era -> TxBodyContent build era +setTxScriptValidity :: FeatureValue TxScriptValidityFeature era ScriptValidity -> TxBodyContent build era -> TxBodyContent build era setTxScriptValidity v txBodyContent = txBodyContent { txScriptValidity = v } -- ---------------------------------------------------------------------------- @@ -1872,7 +1848,7 @@ data TxBody era where -- auxiliary data. -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) - -> TxScriptValidity era -- ^ Mark script as expected to pass or fail validation + -> FeatureValue TxScriptValidityFeature era ScriptValidity -- ^ Mark script as expected to pass or fail validation -> TxBody era -- The 'ShelleyBasedEra' GADT tells us what era we are in. @@ -2104,7 +2080,7 @@ serialiseShelleyBasedTxBody -> [Ledger.Script ledgerera] -> TxBodyScriptData era -> Maybe (L.TxAuxData ledgerera) - -> TxScriptValidity era -- ^ Mark script as expected to pass or fail validation + -> FeatureValue TxScriptValidityFeature era ScriptValidity -- ^ Mark script as expected to pass or fail validation -> ByteString serialiseShelleyBasedTxBody era txbody txscripts TxBodyNoScriptData txmetadata scriptValidity = @@ -2118,21 +2094,21 @@ serialiseShelleyBasedTxBody era txbody txscripts $ CBOR.encodeListLen 4 <> CBOR.encCBOR txbody <> CBOR.encCBOR txscripts - <> CBOR.encCBOR (txScriptValidityToScriptValidity scriptValidity) + <> CBOR.encCBOR (valueOrDefault defaultScriptValidity scriptValidity) <> CBOR.encodeNullMaybe CBOR.encCBOR txmetadata ShelleyBasedEraBabbage -> CBOR.serialize' (L.eraProtVerLow @L.Babbage) $ CBOR.encodeListLen 4 <> CBOR.encCBOR txbody <> CBOR.encCBOR txscripts - <> CBOR.encCBOR (txScriptValidityToScriptValidity scriptValidity) + <> CBOR.encCBOR (valueOrDefault defaultScriptValidity scriptValidity) <> CBOR.encodeNullMaybe CBOR.encCBOR txmetadata ShelleyBasedEraConway -> CBOR.serialize' (L.eraProtVerLow @L.Babbage) $ CBOR.encodeListLen 4 <> CBOR.encCBOR txbody <> CBOR.encCBOR txscripts - <> CBOR.encCBOR (txScriptValidityToScriptValidity scriptValidity) + <> CBOR.encCBOR (valueOrDefault defaultScriptValidity scriptValidity) <> CBOR.encodeNullMaybe CBOR.encCBOR txmetadata where preAlonzo v = CBOR.serialize' v @@ -2150,7 +2126,7 @@ serialiseShelleyBasedTxBody _era txbody txscripts <> CBOR.encCBOR txscripts <> CBOR.encCBOR datums <> CBOR.encCBOR redeemers - <> CBOR.encCBOR (txScriptValidityToScriptValidity txBodyScriptValidity) + <> CBOR.encCBOR (valueOrDefault defaultScriptValidity txBodyScriptValidity) <> CBOR.encodeNullMaybe CBOR.encCBOR txmetadata deserialiseShelleyBasedTxBody @@ -2187,7 +2163,7 @@ deserialiseShelleyBasedTxBody era bs = [] -- scripts (flip CBOR.runAnnotator fbs (return TxBodyNoScriptData)) (fmap (flip CBOR.runAnnotator fbs) txmetadata) - (flip CBOR.runAnnotator fbs (return TxScriptValidityNone)) + (flip CBOR.runAnnotator fbs (return NoFeatureValue)) 3 -> do txbody <- CBOR.decCBOR txscripts <- CBOR.decCBOR @@ -2198,10 +2174,10 @@ deserialiseShelleyBasedTxBody era bs = (map (flip CBOR.runAnnotator fbs) txscripts) (flip CBOR.runAnnotator fbs (return TxBodyNoScriptData)) (fmap (flip CBOR.runAnnotator fbs) txmetadata) - (flip CBOR.runAnnotator fbs (return TxScriptValidityNone)) + (flip CBOR.runAnnotator fbs (return NoFeatureValue)) 4 -> do sValiditySupported <- - case txScriptValiditySupportedInShelleyBasedEra era of + case featureInShelleyBasedEra Nothing Just era of Nothing -> fail $ mconcat [ "deserialiseShelleyBasedTxBody: Expected an era that supports the " , "script validity flag but got: " @@ -2219,7 +2195,7 @@ deserialiseShelleyBasedTxBody era bs = (map (flip CBOR.runAnnotator fbs) txscripts) (flip CBOR.runAnnotator fbs (return TxBodyNoScriptData)) (fmap (flip CBOR.runAnnotator fbs) txmetadata) - (flip CBOR.runAnnotator fbs (return $ TxScriptValidity sValiditySupported scriptValidity)) + (flip CBOR.runAnnotator fbs (return $ FeatureValue sValiditySupported scriptValidity)) 6 -> do sDataSupported <- case scriptDataSupportedInEra (shelleyBasedToCardanoEra era) of @@ -2231,7 +2207,7 @@ deserialiseShelleyBasedTxBody era bs = Just supported -> return supported sValiditySupported <- - case txScriptValiditySupportedInShelleyBasedEra era of + case featureInShelleyBasedEra Nothing Just era of Nothing -> fail $ mconcat [ "deserialiseShelleyBasedTxBody: Expected an era that supports the " , "script validity flag but got: " @@ -2257,7 +2233,7 @@ deserialiseShelleyBasedTxBody era bs = (map (flip CBOR.runAnnotator fbs) txscripts) (flip CBOR.runAnnotator fbs txscriptdata) (fmap (flip CBOR.runAnnotator fbs) txmetadata) - (flip CBOR.runAnnotator fbs (return $ TxScriptValidity sValiditySupported scriptValidity)) + (flip CBOR.runAnnotator fbs (return $ FeatureValue sValiditySupported scriptValidity)) _ -> fail $ "expected tx body tuple of size 2, 3, 4 or 6, got " <> show len instance IsCardanoEra era => HasTextEnvelope (TxBody era) where @@ -2709,7 +2685,7 @@ getTxBodyContent (ShelleyTxBody era body _scripts scriptdata mAux scriptValidity fromLedgerTxBody :: ShelleyBasedEra era - -> TxScriptValidity era + -> FeatureValue TxScriptValidityFeature era ScriptValidity -> Ledger.TxBody (ShelleyLedgerEra era) -> TxBodyScriptData era -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) @@ -2852,7 +2828,7 @@ fromAlonzoTxOut :: forall era ledgerera. => L.AlonzoEraTxOut ledgerera => Ledger.EraCrypto ledgerera ~ StandardCrypto => Ledger.Value ledgerera ~ MaryValue StandardCrypto - => MultiAssetSupportedInEra era + => MultiAssetFeature era -> ScriptDataSupportedInEra era -> Map (L.DataHash StandardCrypto) (L.Data ledgerera) @@ -2881,7 +2857,7 @@ fromBabbageTxOut => ShelleyLedgerEra era ~ ledgerera => Ledger.EraCrypto ledgerera ~ StandardCrypto => Ledger.Value ledgerera ~ MaryValue StandardCrypto - => MultiAssetSupportedInEra era + => MultiAssetFeature era -> ScriptDataSupportedInEra era -> ReferenceTxInsScriptsInlineDatumsSupportedInEra era -> Map (L.DataHash StandardCrypto) @@ -3285,45 +3261,35 @@ fromLedgerTxCertificates era body = fromLedgerTxUpdateProposal :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) - -> TxUpdateProposal era + -> FeatureValue UpdateProposalFeature era UpdateProposal fromLedgerTxUpdateProposal era body = case era of ShelleyBasedEraShelley -> case body ^. L.updateTxBodyL of - SNothing -> TxUpdateProposalNone - SJust p -> - TxUpdateProposal UpdateProposalInShelleyEra - (fromLedgerUpdate era p) + SNothing -> NoFeatureValue + SJust p -> FeatureValue UpdateProposalInShelleyEra (fromLedgerUpdate era p) ShelleyBasedEraAllegra -> case body ^. L.updateTxBodyL of - SNothing -> TxUpdateProposalNone - SJust p -> - TxUpdateProposal UpdateProposalInAllegraEra - (fromLedgerUpdate era p) + SNothing -> NoFeatureValue + SJust p -> FeatureValue UpdateProposalInAllegraEra (fromLedgerUpdate era p) ShelleyBasedEraMary -> case body ^. L.updateTxBodyL of - SNothing -> TxUpdateProposalNone - SJust p -> - TxUpdateProposal UpdateProposalInMaryEra - (fromLedgerUpdate era p) + SNothing -> NoFeatureValue + SJust p -> FeatureValue UpdateProposalInMaryEra (fromLedgerUpdate era p) ShelleyBasedEraAlonzo -> case body ^. L.updateTxBodyL of - SNothing -> TxUpdateProposalNone - SJust p -> - TxUpdateProposal UpdateProposalInAlonzoEra - (fromLedgerUpdate era p) + SNothing -> NoFeatureValue + SJust p -> FeatureValue UpdateProposalInAlonzoEra (fromLedgerUpdate era p) ShelleyBasedEraBabbage -> case body ^. L.updateTxBodyL of - SNothing -> TxUpdateProposalNone - SJust p -> - TxUpdateProposal UpdateProposalInBabbageEra - (fromLedgerUpdate era p) + SNothing -> NoFeatureValue + SJust p -> FeatureValue UpdateProposalInBabbageEra (fromLedgerUpdate era p) - ShelleyBasedEraConway -> TxUpdateProposalNone + ShelleyBasedEraConway -> NoFeatureValue fromLedgerTxMintValue :: ShelleyBasedEra era @@ -3402,9 +3368,9 @@ getByronTxBodyContent (Annotated Byron.UnsafeTx{txInputs, txOutputs} _) = , txProtocolParams = ViewTx , txWithdrawals = TxWithdrawalsNone , txCertificates = TxCertificatesNone - , txUpdateProposal = TxUpdateProposalNone + , txUpdateProposal = NoFeatureValue , txMintValue = TxMintNone - , txScriptValidity = TxScriptValidityNone + , txScriptValidity = NoFeatureValue } convTxIns :: TxIns BuildTx era -> Set (L.TxIn StandardCrypto) @@ -3497,13 +3463,13 @@ convTxUpdateProposal :: forall era ledgerera. ShelleyLedgerEra era ~ ledgerera => Ledger.EraCrypto ledgerera ~ StandardCrypto => ShelleyBasedEra era - -> TxUpdateProposal era + -> FeatureValue UpdateProposalFeature era UpdateProposal -> Either TxBodyError (StrictMaybe (Ledger.Update ledgerera)) -- ^ 'Left' when there's protocol params conversion error, 'Right' otherwise, 'Right SNothing' means that -- there's no update proposal convTxUpdateProposal era = \case - TxUpdateProposalNone -> Right SNothing - TxUpdateProposal _ p -> bimap TxBodyProtocolParamsConversionError pure $ toLedgerUpdate era p + NoFeatureValue -> Right SNothing + FeatureValue _ p -> bimap TxBodyProtocolParamsConversionError pure $ toLedgerUpdate era p convMintValue :: TxMintValue build era -> MultiAsset StandardCrypto convMintValue txMintValue = @@ -3680,7 +3646,7 @@ makeShelleyTransactionBody era@ShelleyBasedEraShelley scripts_ TxBodyNoScriptData txAuxData - TxScriptValidityNone + NoFeatureValue where scripts_ :: [Ledger.Script StandardShelley] scripts_ = catMaybes @@ -3717,7 +3683,7 @@ makeShelleyTransactionBody era@ShelleyBasedEraAllegra scripts_ TxBodyNoScriptData txAuxData - TxScriptValidityNone + NoFeatureValue where scripts_ :: [Ledger.Script StandardAllegra] scripts_ = catMaybes @@ -3756,7 +3722,7 @@ makeShelleyTransactionBody era@ShelleyBasedEraMary scripts TxBodyNoScriptData txAuxData - TxScriptValidityNone + NoFeatureValue where scripts :: [Ledger.Script StandardMary] scripts = List.nub $ catMaybes diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index c26106dbad..9a8162662c 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -255,7 +255,6 @@ module Cardano.Api ( TxExtraKeyWitnesses(..), TxWithdrawals(..), TxCertificates(..), - TxUpdateProposal(..), TxMintValue(..), -- ** Building vs viewing transactions @@ -265,8 +264,8 @@ module Cardano.Api ( -- ** Era-dependent transaction body features CollateralSupportedInEra(..), - MultiAssetSupportedInEra(..), - OnlyAdaSupportedInEra(..), + MultiAssetFeature(..), + OnlyAdaFeature(..), TxFeesExplicitInEra(..), TxFeesImplicitInEra(..), ValidityUpperBoundSupportedInEra(..), @@ -278,12 +277,13 @@ module Cardano.Api ( ScriptDataSupportedInEra(..), WithdrawalsSupportedInEra(..), CertificatesSupportedInEra(..), - UpdateProposalSupportedInEra(..), + UpdateProposalFeature(..), TxTotalAndReturnCollateralSupportedInEra(..), FeatureInEra(..), -- ** Feature availability functions collateralSupportedInEra, + onlyAdaOrMultiAssetFeatureInEra, multiAssetSupportedInEra, txFeesExplicitInEra, validityUpperBoundSupportedInEra, @@ -294,7 +294,6 @@ module Cardano.Api ( extraKeyWitnessesSupportedInEra, withdrawalsSupportedInEra, certificatesSupportedInEra, - updateProposalSupportedInEra, scriptDataSupportedInEra, totalAndReturnCollateralSupportedInEra, @@ -325,13 +324,9 @@ module Cardano.Api ( makeTransactionBodyAutoBalance, BalancedTxBody(..), TxBodyErrorAutoBalance(..), - TxScriptValidity(..), ScriptValidity(..), - TxScriptValiditySupportedInEra(..), - scriptValidityToTxScriptValidity, - txScriptValiditySupportedInShelleyBasedEra, - txScriptValiditySupportedInCardanoEra, - txScriptValidityToScriptValidity, + TxScriptValidityFeature(..), + defaultScriptValidity, -- * Signing transactions -- | Creating transaction witnesses one by one, or all in one go. diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs index 6261216b76..95fcc1a546 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} module Test.Cardano.Api.Typed.TxBody ( tests @@ -14,8 +15,9 @@ import Test.Gen.Cardano.Api.Typed (genTxBodyContent) import Test.Cardano.Api.Typed.Orphans () -import Hedgehog (MonadTest, Property, annotateShow, failure, (===)) +import Hedgehog (MonadTest, Property, annotateShow, failure, forAll, (===)) import qualified Hedgehog as H +import qualified Hedgehog.Gen as Gen import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) @@ -74,7 +76,23 @@ prop_roundtrip_txbodycontent_txouts = (ReferenceScript _ (ScriptInAnyLang actual _)) -> isJust $ testEquality expected actual _ -> False +prop_disjoint_OnlyAdaFeature_MultiAssetFeature :: Property +prop_disjoint_OnlyAdaFeature_MultiAssetFeature = + H.property $ do + AnyCardanoEra era <- forAll $ Gen.element [minBound..maxBound] + let hasOnlyAdaFeature = featureInEra @OnlyAdaFeature False (const True) era + let hasMultiAssetFeature = featureInEra @MultiAssetFeature False (const True) era + hasOnlyAdaFeature === not hasMultiAssetFeature + +prop_total_onlyAdaOrMultiAssetFeatureInEra :: Property +prop_total_onlyAdaOrMultiAssetFeatureInEra = + H.property $ do + AnyCardanoEra era <- forAll $ Gen.element [minBound..maxBound] + either id id (onlyAdaOrMultiAssetFeatureInEra (const ()) (const ()) era) === () + tests :: TestTree tests = testGroup "Test.Cardano.Api.Typed.TxBody" [ testProperty "roundtrip txbodycontent txouts" prop_roundtrip_txbodycontent_txouts + , testProperty "disjoint OnlyAdaFeature MultiAssetFeature" prop_disjoint_OnlyAdaFeature_MultiAssetFeature + , testProperty "total onlyAdaOrMultiAssetFeatureInEra" prop_total_onlyAdaOrMultiAssetFeatureInEra ]