From a52cb17068f53a24aff9b835cf8b8923d48b3445 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 7 Nov 2023 00:09:17 +1100 Subject: [PATCH 01/11] Remove need for ByronToAllegraEra eon --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 3 +- cardano-api/internal/Cardano/Api/Eras/Case.hs | 18 +++++ cardano-api/internal/Cardano/Api/Fees.hs | 2 +- cardano-api/internal/Cardano/Api/TxBody.hs | 75 ++++++++++--------- cardano-api/src/Cardano/Api.hs | 1 + .../Test/Golden/ErrorsSpec.hs | 2 +- .../TxBodyOutputNegative.txt | 2 +- .../TxBodyOutputOverflow.txt | 2 +- 8 files changed, 66 insertions(+), 39 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 676fcd6b4f..36c161c704 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -497,7 +497,8 @@ genTxIndex = TxIx . fromIntegral <$> Gen.word16 Range.constantBounded genTxOutValue :: CardanoEra era -> Gen (TxOutValue era) genTxOutValue = - caseByronToAllegraOrMaryEraOnwards + caseByronOrShelleyToAllegraOrMaryEraOnwards + (\w -> TxOutAdaOnlyByron w <$> genPositiveLovelace) (\w -> TxOutAdaOnly w <$> genPositiveLovelace) (\w -> TxOutValue w <$> genValueForTxOut) diff --git a/cardano-api/internal/Cardano/Api/Eras/Case.hs b/cardano-api/internal/Cardano/Api/Eras/Case.hs index e5a95d4b98..f25337ae76 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Case.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Case.hs @@ -7,6 +7,7 @@ module Cardano.Api.Eras.Case ( -- Case on CardanoEra caseByronOrShelleyBasedEra + , caseByronOrShelleyToAllegraOrMaryEraOnwards , caseByronToAllegraOrMaryEraOnwards , caseByronToAlonzoOrBabbageEraOnwards @@ -76,6 +77,23 @@ caseByronToAllegraOrMaryEraOnwards l r = \case BabbageEra -> r MaryEraOnwardsBabbage ConwayEra -> r MaryEraOnwardsConway +-- | @caseByronOrShelleyToAllegraOrMaryEraOnwards l m r era@ applies @l@ to byron; @m@ to shelley, and allegra; +-- and @r@ to mary and later eras. +caseByronOrShelleyToAllegraOrMaryEraOnwards :: () + => (ByronEraOnlyConstraints era => ByronEraOnly era -> a) + -> (ShelleyToAllegraEraConstraints era => ShelleyToAllegraEra era -> a) + -> (MaryEraOnwardsConstraints era => MaryEraOnwards era -> a) + -> CardanoEra era + -> a +caseByronOrShelleyToAllegraOrMaryEraOnwards l m r = \case + ByronEra -> l ByronEraOnlyByron + ShelleyEra -> m ShelleyToAllegraEraShelley + AllegraEra -> m ShelleyToAllegraEraAllegra + MaryEra -> r MaryEraOnwardsMary + AlonzoEra -> r MaryEraOnwardsAlonzo + BabbageEra -> r MaryEraOnwardsBabbage + ConwayEra -> r MaryEraOnwardsConway + -- | @caseByronToAlonzoOrBabbageEraOnwards f g era@ applies @f@ to byron, shelley, allegra, mary, and alonzo; -- and @g@ to babbage and later eras. caseByronToAlonzoOrBabbageEraOnwards :: () diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 34a361215d..dc1db708ce 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -606,7 +606,7 @@ evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits u evalAdaOnly :: ShelleyToAllegraEra era -> TxOutValue era evalAdaOnly w = shelleyToAllegraEraConstraints w - $ TxOutAdaOnly (shelleyToAllegraEraToByronToAllegraEra w) . fromShelleyLovelace + $ TxOutAdaOnly w . fromShelleyLovelace $ L.evalBalanceTxBody pp lookupDelegDeposit diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index d79eda2ea7..4a2b63130e 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -156,10 +156,10 @@ import Cardano.Api.Eon.AllegraEraOnwards import Cardano.Api.Eon.AlonzoEraOnwards import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ByronEraOnly -import Cardano.Api.Eon.ByronToAllegraEra import Cardano.Api.Eon.ConwayEraOnwards import Cardano.Api.Eon.MaryEraOnwards import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eon.ShelleyToAllegraEra import Cardano.Api.Eon.ShelleyToBabbageEra import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core @@ -680,20 +680,20 @@ fromByronTxOut :: ByronEraOnly era -> Byron.TxOut -> TxOut ctx era fromByronTxOut ByronEraOnlyByron (Byron.TxOut addr value) = TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) - (TxOutAdaOnly ByronToAllegraEraByron (fromByronLovelace value)) + (TxOutAdaOnlyByron ByronEraOnlyByron (fromByronLovelace value)) TxOutDatumNone ReferenceScriptNone toByronTxOut :: ByronEraOnly era -> TxOut ctx era -> Maybe Byron.TxOut -toByronTxOut ByronEraOnlyByron (TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) - (TxOutAdaOnly ByronToAllegraEraByron value) _ _) = +toByronTxOut ByronEraOnlyByron = \case + TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) (TxOutAdaOnlyByron _ value) _ _ -> Byron.TxOut addr <$> toByronLovelace value - -toByronTxOut ByronEraOnlyByron (TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) - (TxOutValue w _) _ _) = case w of {} - -toByronTxOut ByronEraOnlyByron (TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress{}) - _ _ _) = case sbe of {} + TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) (TxOutAdaOnly _ value) _ _ -> + Byron.TxOut addr <$> toByronLovelace value + TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) (TxOutValue w _) _ _ -> + case w of {} + TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress{}) _ _ _ -> + case sbe of {} toShelleyTxOut :: forall era ledgerera. @@ -701,13 +701,13 @@ toShelleyTxOut :: forall era ledgerera. => ShelleyBasedEra era -> TxOut CtxUTxO era -> Ledger.TxOut ledgerera -toShelleyTxOut sbe (TxOut _ (TxOutAdaOnly ByronToAllegraEraByron _) _ _) = +toShelleyTxOut sbe (TxOut _ (TxOutAdaOnlyByron ByronEraOnlyByron _) _ _) = case sbe of {} -toShelleyTxOut _ (TxOut addr (TxOutAdaOnly ByronToAllegraEraShelley value) _ _) = +toShelleyTxOut _ (TxOut addr (TxOutAdaOnly ShelleyToAllegraEraShelley value) _ _) = L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) -toShelleyTxOut _ (TxOut addr (TxOutAdaOnly ByronToAllegraEraAllegra value) _ _) = +toShelleyTxOut _ (TxOut addr (TxOutAdaOnly ShelleyToAllegraEraAllegra value) _ _) = L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) toShelleyTxOut _ (TxOut addr (TxOutValue MaryEraOnwardsMary value) _ _) = @@ -738,7 +738,7 @@ fromShelleyTxOut sbe ledgerTxOut = do let txOutValue :: TxOutValue era txOutValue = caseShelleyToAllegraOrMaryEraOnwards - (\w -> TxOutAdaOnly (shelleyToAllegraEraToByronToAllegraEra w) (fromShelleyLovelace (ledgerTxOut ^. L.valueTxOutL))) + (\w -> TxOutAdaOnly w (fromShelleyLovelace (ledgerTxOut ^. L.valueTxOutL))) (\w -> TxOutValue w (fromMaryValue (ledgerTxOut ^. L.valueTxOutL))) sbe @@ -886,7 +886,9 @@ deriving instance Show (TxInsReference build era) data TxOutValue era where - TxOutAdaOnly :: ByronToAllegraEra era -> Lovelace -> TxOutValue era + TxOutAdaOnlyByron :: ByronEraOnly era -> Lovelace -> TxOutValue era + + TxOutAdaOnly :: ShelleyToAllegraEra era -> Lovelace -> TxOutValue era TxOutValue :: MaryEraOnwards era -> Value -> TxOutValue era @@ -895,12 +897,18 @@ deriving instance Show (TxOutValue era) deriving instance Generic (TxOutValue era) instance ToJSON (TxOutValue era) where - toJSON (TxOutAdaOnly _ ll) = toJSON ll - toJSON (TxOutValue _ val) = toJSON val + toJSON = \case + TxOutAdaOnlyByron _ ll -> toJSON ll + TxOutAdaOnly _ ll -> toJSON ll + TxOutValue _ val -> toJSON val instance IsCardanoEra era => FromJSON (TxOutValue era) where parseJSON = withObject "TxOutValue" $ \o -> - caseByronToAllegraOrMaryEraOnwards + caseByronOrShelleyToAllegraOrMaryEraOnwards + (\bo -> do + ll <- o .: "lovelace" + pure $ TxOutAdaOnlyByron bo $ selectLovelace ll + ) (\w -> do ll <- o .: "lovelace" pure $ TxOutAdaOnly w $ selectLovelace ll @@ -947,7 +955,8 @@ lovelaceToTxOutValue :: () -> Lovelace -> TxOutValue era lovelaceToTxOutValue era l = - caseByronToAllegraOrMaryEraOnwards + caseByronOrShelleyToAllegraOrMaryEraOnwards + (\w -> TxOutAdaOnlyByron w l) (\w -> TxOutAdaOnly w l) (\w -> TxOutValue w (lovelaceToValue l)) era @@ -955,12 +964,14 @@ lovelaceToTxOutValue era l = txOutValueToLovelace :: TxOutValue era -> Lovelace txOutValueToLovelace tv = case tv of + TxOutAdaOnlyByron _ l -> l TxOutAdaOnly _ l -> l TxOutValue _ v -> selectLovelace v txOutValueToValue :: TxOutValue era -> Value txOutValueToValue tv = case tv of + TxOutAdaOnlyByron _ l -> lovelaceToValue l TxOutAdaOnly _ l -> lovelaceToValue l TxOutValue _ v -> v @@ -2460,19 +2471,15 @@ makeByronTransactionBody eon TxBodyContent { txIns, txOuts } = do maxByronTxInIx = fromIntegral (maxBound :: Word32) classifyRangeError :: ByronEraOnly era -> TxOut CtxTx era -> TxBodyError -classifyRangeError ByronEraOnlyByron - txout@(TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) - (TxOutAdaOnly ByronToAllegraEraByron value) _ _) - | value < 0 = TxBodyOutputNegative (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) - | otherwise = TxBodyOutputOverflow (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) - -classifyRangeError ByronEraOnlyByron - (TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) - (TxOutValue w _) _ _) = case w of {} +classifyRangeError ByronEraOnlyByron txout = + case txout of + TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) (TxOutAdaOnlyByron ByronEraOnlyByron value) _ _ + | value < 0 -> TxBodyOutputNegative (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) + | otherwise -> TxBodyOutputOverflow (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) -classifyRangeError ByronEraOnlyByron - (TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress{}) - _ _ _) = case sbe of {} + TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) (TxOutAdaOnly w _) _ _ -> case w of {} + TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) (TxOutValue w _) _ _ -> case w of {} + TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress{}) _ _ _ -> case sbe of {} getByronTxBodyContent :: () => ByronEraOnly era @@ -3141,13 +3148,13 @@ toShelleyTxOutAny :: forall ctx era ledgerera. => ShelleyBasedEra era -> TxOut ctx era -> Ledger.TxOut ledgerera -toShelleyTxOutAny sbe (TxOut _ (TxOutAdaOnly ByronToAllegraEraByron _) _ _) = +toShelleyTxOutAny sbe (TxOut _ (TxOutAdaOnlyByron ByronEraOnlyByron _) _ _) = case sbe of {} -toShelleyTxOutAny _ (TxOut addr (TxOutAdaOnly ByronToAllegraEraShelley value) _ _) = +toShelleyTxOutAny _ (TxOut addr (TxOutAdaOnly ShelleyToAllegraEraShelley value) _ _) = L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) -toShelleyTxOutAny _ (TxOut addr (TxOutAdaOnly ByronToAllegraEraAllegra value) _ _) = +toShelleyTxOutAny _ (TxOut addr (TxOutAdaOnly ShelleyToAllegraEraAllegra value) _ _) = L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) toShelleyTxOutAny _ (TxOut addr (TxOutValue MaryEraOnwardsMary value) _ _) = diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 6dbdffc0d6..77476d04d8 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -136,6 +136,7 @@ module Cardano.Api ( -- ** Case on CardanoEra caseByronOrShelleyBasedEra, + caseByronOrShelleyToAllegraOrMaryEraOnwards, caseByronToAllegraOrMaryEraOnwards, caseByronToAlonzoOrBabbageEraOnwards, diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs index bcdf002a7a..57e303f201 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs @@ -116,7 +116,7 @@ changeaddr1 = (PaymentCredentialByKey (verificationKeyHash paymentVerKey1)) NoStakeAddress) txOutValue1 :: TxOutValue AllegraEra -txOutValue1 = TxOutAdaOnly ByronToAllegraEraAllegra 1 +txOutValue1 = TxOutAdaOnly ShelleyToAllegraEraAllegra 1 txout1 :: TxOut ctx AllegraEra txout1 = TxOut changeaddr1 txOutValue1 TxOutDatumNone ReferenceScriptNone diff --git a/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputNegative.txt b/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputNegative.txt index eed94129ee..7cbed2e6a9 100644 --- a/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputNegative.txt +++ b/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputNegative.txt @@ -1 +1 @@ -Negative quantity (1) in transaction output: TxOutInAnyEra AllegraEra (TxOut (AddressInEra (ShelleyAddressInEra ShelleyBasedEraAllegra) (ShelleyAddress Mainnet (KeyHashObj (KeyHash "250ca83514191f9ceaccee2eb3276d5ad964e17cc31a067691e04ca8")) StakeRefNull)) (TxOutAdaOnly ByronToAllegraEraAllegra (Lovelace 1)) TxOutDatumNone ReferenceScriptNone) \ No newline at end of file +Negative quantity (1) in transaction output: TxOutInAnyEra AllegraEra (TxOut (AddressInEra (ShelleyAddressInEra ShelleyBasedEraAllegra) (ShelleyAddress Mainnet (KeyHashObj (KeyHash "250ca83514191f9ceaccee2eb3276d5ad964e17cc31a067691e04ca8")) StakeRefNull)) (TxOutAdaOnly ShelleyToAllegraEraAllegra (Lovelace 1)) TxOutDatumNone ReferenceScriptNone) \ No newline at end of file diff --git a/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputOverflow.txt b/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputOverflow.txt index 34c4524709..7fb97af17a 100644 --- a/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputOverflow.txt +++ b/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputOverflow.txt @@ -1 +1 @@ -Quantity too large (1 >= 2^64) in transaction output: TxOutInAnyEra AllegraEra (TxOut (AddressInEra (ShelleyAddressInEra ShelleyBasedEraAllegra) (ShelleyAddress Mainnet (KeyHashObj (KeyHash "250ca83514191f9ceaccee2eb3276d5ad964e17cc31a067691e04ca8")) StakeRefNull)) (TxOutAdaOnly ByronToAllegraEraAllegra (Lovelace 1)) TxOutDatumNone ReferenceScriptNone) \ No newline at end of file +Quantity too large (1 >= 2^64) in transaction output: TxOutInAnyEra AllegraEra (TxOut (AddressInEra (ShelleyAddressInEra ShelleyBasedEraAllegra) (ShelleyAddress Mainnet (KeyHashObj (KeyHash "250ca83514191f9ceaccee2eb3276d5ad964e17cc31a067691e04ca8")) StakeRefNull)) (TxOutAdaOnly ShelleyToAllegraEraAllegra (Lovelace 1)) TxOutDatumNone ReferenceScriptNone) \ No newline at end of file From 0bef5e33a82d7dd100889af840bc39c0a45cc616 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 7 Nov 2023 00:14:01 +1100 Subject: [PATCH 02/11] Delete ByronToAllegraEra eon --- cardano-api/cardano-api.cabal | 1 - cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 3 +- .../Cardano/Api/Eon/ByronToAllegraEra.hs | 54 ------------------- cardano-api/internal/Cardano/Api/Eras.hs | 1 - cardano-api/internal/Cardano/Api/Eras/Case.hs | 24 --------- cardano-api/internal/Cardano/Api/Fees.hs | 3 +- cardano-api/src/Cardano/Api.hs | 7 --- 7 files changed, 4 insertions(+), 89 deletions(-) delete mode 100644 cardano-api/internal/Cardano/Api/Eon/ByronToAllegraEra.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 4a946a9864..5feb0344cf 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -62,7 +62,6 @@ library internal Cardano.Api.Eon.AlonzoEraOnwards Cardano.Api.Eon.BabbageEraOnwards Cardano.Api.Eon.ByronEraOnly - Cardano.Api.Eon.ByronToAllegraEra Cardano.Api.Eon.ByronToAlonzoEra Cardano.Api.Eon.ConwayEraOnwards Cardano.Api.Eon.MaryEraOnwards diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 36c161c704..5208b4261f 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -618,7 +618,8 @@ genTxUpdateProposal sbe = genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era) genTxMintValue = - caseByronToAllegraOrMaryEraOnwards + caseByronOrShelleyToAllegraOrMaryEraOnwards + (const (pure TxMintNone)) (const (pure TxMintNone)) (\supported -> Gen.choice diff --git a/cardano-api/internal/Cardano/Api/Eon/ByronToAllegraEra.hs b/cardano-api/internal/Cardano/Api/Eon/ByronToAllegraEra.hs deleted file mode 100644 index 0eafcb36a6..0000000000 --- a/cardano-api/internal/Cardano/Api/Eon/ByronToAllegraEra.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module Cardano.Api.Eon.ByronToAllegraEra - ( ByronToAllegraEra(..) - , byronToAllegraEraConstraints - , byronToAllegraEraToCardanoEra - - , ByronToAllegraEraConstraints - ) where - -import Cardano.Api.Eras.Core - -import Data.Typeable (Typeable) - -data ByronToAllegraEra era where - ByronToAllegraEraByron :: ByronToAllegraEra ByronEra - ByronToAllegraEraShelley :: ByronToAllegraEra ShelleyEra - ByronToAllegraEraAllegra :: ByronToAllegraEra AllegraEra - -deriving instance Show (ByronToAllegraEra era) -deriving instance Eq (ByronToAllegraEra era) - -instance ToCardanoEra ByronToAllegraEra where - toCardanoEra = \case - ByronToAllegraEraByron -> ByronEra - ByronToAllegraEraShelley -> ShelleyEra - ByronToAllegraEraAllegra -> AllegraEra - -type ByronToAllegraEraConstraints era = - ( IsCardanoEra era - , Typeable era - ) - -byronToAllegraEraConstraints :: () - => ByronToAllegraEra era - -> (ByronToAllegraEraConstraints era => a) - -> a -byronToAllegraEraConstraints = \case - ByronToAllegraEraByron -> id - ByronToAllegraEraShelley -> id - ByronToAllegraEraAllegra -> id - -byronToAllegraEraToCardanoEra :: ByronToAllegraEra era -> CardanoEra era -byronToAllegraEraToCardanoEra = \case - ByronToAllegraEraByron -> ByronEra - ByronToAllegraEraShelley -> ShelleyEra - ByronToAllegraEraAllegra -> AllegraEra diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index a25c52c98f..b9b8bfabef 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -42,7 +42,6 @@ module Cardano.Api.Eras , caseByronOrShelleyBasedEra -- ** Case on ShelleyBasedEra - , caseByronToAllegraOrMaryEraOnwards , caseByronToAlonzoOrBabbageEraOnwards , caseShelleyToAllegraOrMaryEraOnwards , caseShelleyToMaryOrAlonzoEraOnwards diff --git a/cardano-api/internal/Cardano/Api/Eras/Case.hs b/cardano-api/internal/Cardano/Api/Eras/Case.hs index f25337ae76..6c18b37d39 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Case.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Case.hs @@ -8,7 +8,6 @@ module Cardano.Api.Eras.Case ( -- Case on CardanoEra caseByronOrShelleyBasedEra , caseByronOrShelleyToAllegraOrMaryEraOnwards - , caseByronToAllegraOrMaryEraOnwards , caseByronToAlonzoOrBabbageEraOnwards -- Case on ShelleyBasedEra @@ -23,7 +22,6 @@ module Cardano.Api.Eras.Case , disjointByronEraOnlyAndShelleyBasedEra -- Conversions - , shelleyToAllegraEraToByronToAllegraEra , shelleyToAlonzoEraToShelleyToBabbageEra , alonzoEraOnwardsToMaryEraOnwards , babbageEraOnwardsToMaryEraOnwards @@ -34,7 +32,6 @@ import Cardano.Api.Eon.AllegraEraOnwards import Cardano.Api.Eon.AlonzoEraOnwards import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ByronEraOnly -import Cardano.Api.Eon.ByronToAllegraEra import Cardano.Api.Eon.ByronToAlonzoEra import Cardano.Api.Eon.ConwayEraOnwards import Cardano.Api.Eon.MaryEraOnwards @@ -61,22 +58,6 @@ caseByronOrShelleyBasedEra l r = \case BabbageEra -> r ShelleyBasedEraBabbage ConwayEra -> r ShelleyBasedEraConway --- | @caseByronToAllegraOrMaryEraOnwards f g era@ applies @f@ to byron, shelley, and allegra; --- and @g@ to mary and later eras. -caseByronToAllegraOrMaryEraOnwards :: () - => (ByronToAllegraEraConstraints era => ByronToAllegraEra era -> a) - -> (MaryEraOnwardsConstraints era => MaryEraOnwards era -> a) - -> CardanoEra era - -> a -caseByronToAllegraOrMaryEraOnwards l r = \case - ByronEra -> l ByronToAllegraEraByron - ShelleyEra -> l ByronToAllegraEraShelley - AllegraEra -> l ByronToAllegraEraAllegra - MaryEra -> r MaryEraOnwardsMary - AlonzoEra -> r MaryEraOnwardsAlonzo - BabbageEra -> r MaryEraOnwardsBabbage - ConwayEra -> r MaryEraOnwardsConway - -- | @caseByronOrShelleyToAllegraOrMaryEraOnwards l m r era@ applies @l@ to byron; @m@ to shelley, and allegra; -- and @r@ to mary and later eras. caseByronOrShelleyToAllegraOrMaryEraOnwards :: () @@ -192,11 +173,6 @@ noByronEraInShelleyBasedEra = flip disjointByronEraOnlyAndShelleyBasedEra disjointByronEraOnlyAndShelleyBasedEra :: ByronEraOnly era -> ShelleyBasedEra era -> a disjointByronEraOnlyAndShelleyBasedEra ByronEraOnlyByron sbe = case sbe of {} -shelleyToAllegraEraToByronToAllegraEra :: ShelleyToAllegraEra era -> ByronToAllegraEra era -shelleyToAllegraEraToByronToAllegraEra = \case - ShelleyToAllegraEraShelley -> ByronToAllegraEraShelley - ShelleyToAllegraEraAllegra -> ByronToAllegraEraAllegra - shelleyToAlonzoEraToShelleyToBabbageEra :: () => ShelleyToAlonzoEra era -> ShelleyToBabbageEra era diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index dc1db708ce..75240ddd6a 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -839,7 +839,8 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame , negateValue outgoingNonAda ] - let changeTxOut = caseByronToAllegraOrMaryEraOnwards + let changeTxOut = caseByronOrShelleyToAllegraOrMaryEraOnwards + (const $ lovelaceToTxOutValue era $ Lovelace (2^(64 :: Integer)) - 1) (const $ lovelaceToTxOutValue era $ Lovelace (2^(64 :: Integer)) - 1) (\w -> TxOutValue w (lovelaceToValue (Lovelace (2^(64 :: Integer)) - 1) <> nonAdaChange)) era diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 77476d04d8..743683611e 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -59,10 +59,6 @@ module Cardano.Api ( byronEraOnlyConstraints, byronEraOnlyToCardanoEra, - ByronToAllegraEra(..), - byronToAllegraEraConstraints, - byronToAllegraEraToCardanoEra, - ByronToAlonzoEra(..), byronToAlonzoEraConstraints, byronToAlonzoEraToCardanoEra, @@ -137,7 +133,6 @@ module Cardano.Api ( -- ** Case on CardanoEra caseByronOrShelleyBasedEra, caseByronOrShelleyToAllegraOrMaryEraOnwards, - caseByronToAllegraOrMaryEraOnwards, caseByronToAlonzoOrBabbageEraOnwards, -- ** Case on ShelleyBasedEra @@ -150,7 +145,6 @@ module Cardano.Api ( -- ** Eon relaxation -- *** for AlonzoEraOnly - shelleyToAllegraEraToByronToAllegraEra, shelleyToAlonzoEraToShelleyToBabbageEra, -- *** for AlonzoEraOnwards @@ -1001,7 +995,6 @@ import Cardano.Api.DRepMetadata import Cardano.Api.Eon.AlonzoEraOnwards import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ByronEraOnly -import Cardano.Api.Eon.ByronToAllegraEra import Cardano.Api.Eon.ByronToAlonzoEra import Cardano.Api.Eon.ConwayEraOnwards import Cardano.Api.Eon.MaryEraOnwards From 46ad8e4dca63ea71ddece15f6ef2500ff2ab84b0 Mon Sep 17 00:00:00 2001 From: John Ky Date: Sun, 5 Nov 2023 16:43:32 +1100 Subject: [PATCH 03/11] Delete ByronToMaryEra --- cardano-api/internal/Cardano/Api/Eras.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index b9b8bfabef..bf13a50240 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -42,6 +42,7 @@ module Cardano.Api.Eras , caseByronOrShelleyBasedEra -- ** Case on ShelleyBasedEra + , caseByronOrShelleyToAllegraOrMaryEraOnwards , caseByronToAlonzoOrBabbageEraOnwards , caseShelleyToAllegraOrMaryEraOnwards , caseShelleyToMaryOrAlonzoEraOnwards From f4fca134268c5779060343a44a3d54e7c8a1731a Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 8 Nov 2023 21:43:20 +1100 Subject: [PATCH 04/11] New smart constructor: mkAdaOnlyTxOut; and New lenses: adaAssetL and multiAssetL --- .../internal/Cardano/Api/Ledger/Lens.hs | 42 ++++++++++++++++++- 1 file changed, 40 insertions(+), 2 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs index 0fa906f874..bd1c89290f 100644 --- a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs +++ b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs @@ -4,7 +4,14 @@ {- HLINT ignore "Eta reduce" -} module Cardano.Api.Ledger.Lens - ( strictMaybeL + ( -- *Types + TxBody(..) + + -- * Constructors + , mkAdaOnlyTxOut + + -- * Lenses + , strictMaybeL , L.invalidBeforeL , L.invalidHereAfterL , invalidBeforeStrictL @@ -14,7 +21,6 @@ module Cardano.Api.Ledger.Lens , ttlAsInvalidHereAfterTxBodyL , updateTxBodyL - , TxBody(..) , txBodyL , mintTxBodyL , scriptIntegrityHashTxBodyL @@ -26,6 +32,8 @@ module Cardano.Api.Ledger.Lens , certsTxBodyL , votingProceduresTxBodyL , proposalProceduresTxBodyL + , adaAssetL + , multiAssetL ) where import Cardano.Api.Eon.AllegraEraOnwards @@ -35,6 +43,7 @@ import Cardano.Api.Eon.ConwayEraOnwards import Cardano.Api.Eon.MaryEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eon.ShelleyEraOnly +import Cardano.Api.Eon.ShelleyToAllegraEra import Cardano.Api.Eon.ShelleyToBabbageEra import Cardano.Api.Eras.Case @@ -165,3 +174,32 @@ votingProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.votingPr proposalProceduresTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) (L.OSet (L.ProposalProcedure (ShelleyLedgerEra era))) proposalProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.proposalProceduresTxBodyL +mkAdaOnlyTxOut :: ShelleyBasedEra era -> L.Addr (L.EraCrypto (ShelleyLedgerEra era)) -> L.Coin -> L.TxOut (ShelleyLedgerEra era) +mkAdaOnlyTxOut sbe addr coin = + caseShelleyToAllegraOrMaryEraOnwards + (const (L.mkBasicTxOut addr mempty)) + (const (L.mkBasicTxOut addr (L.MaryValue (L.unCoin coin) mempty))) + sbe + +adaAssetL :: ShelleyBasedEra era -> Lens' (L.Value (ShelleyLedgerEra era)) L.Coin +adaAssetL sbe = + caseShelleyToAllegraOrMaryEraOnwards + adaAssetShelleyToAllegraEraL + adaAssetMaryEraOnwardsL + sbe + +adaAssetShelleyToAllegraEraL :: ShelleyToAllegraEra era -> Lens' (L.Value (ShelleyLedgerEra era)) L.Coin +adaAssetShelleyToAllegraEraL w = + shelleyToAllegraEraConstraints w $ lens id const + +adaAssetMaryEraOnwardsL :: MaryEraOnwards era -> Lens' (L.MaryValue L.StandardCrypto) L.Coin +adaAssetMaryEraOnwardsL w = + maryEraOnwardsConstraints w $ lens + (\(L.MaryValue c _) -> L.Coin c) + (\(L.MaryValue _ ma) (L.Coin c) -> L.MaryValue c ma) + +multiAssetL :: MaryEraOnwards era -> Lens' (L.MaryValue L.StandardCrypto) (L.MultiAsset L.StandardCrypto) +multiAssetL w = + maryEraOnwardsConstraints w $ lens + (\(L.MaryValue _ ma) -> ma) + (\(L.MaryValue c _) ma -> L.MaryValue c ma) From d5e61c9c4f14889919349045b53e609e4f42ee27 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 8 Nov 2023 22:13:02 +1100 Subject: [PATCH 05/11] Tidy up toShelleyTxOut --- cardano-api/internal/Cardano/Api/TxBody.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 4a2b63130e..1846864b24 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -701,29 +701,30 @@ toShelleyTxOut :: forall era ledgerera. => ShelleyBasedEra era -> TxOut CtxUTxO era -> Ledger.TxOut ledgerera -toShelleyTxOut sbe (TxOut _ (TxOutAdaOnlyByron ByronEraOnlyByron _) _ _) = +toShelleyTxOut sbe = \case + TxOut _ (TxOutAdaOnlyByron ByronEraOnlyByron _) _ _ -> case sbe of {} -toShelleyTxOut _ (TxOut addr (TxOutAdaOnly ShelleyToAllegraEraShelley value) _ _) = + TxOut addr (TxOutAdaOnly ShelleyToAllegraEraShelley value) _ _ -> L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) -toShelleyTxOut _ (TxOut addr (TxOutAdaOnly ShelleyToAllegraEraAllegra value) _ _) = + TxOut addr (TxOutAdaOnly ShelleyToAllegraEraAllegra value) _ _ -> L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) -toShelleyTxOut _ (TxOut addr (TxOutValue MaryEraOnwardsMary value) _ _) = + TxOut addr (TxOutValue MaryEraOnwardsMary value) _ _ -> L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) -toShelleyTxOut _ (TxOut addr (TxOutValue MaryEraOnwardsAlonzo value) txoutdata _) = + TxOut addr (TxOutValue MaryEraOnwardsAlonzo value) txoutdata _ -> L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) & L.dataHashTxOutL .~ toAlonzoTxOutDataHash txoutdata -toShelleyTxOut sbe (TxOut addr (TxOutValue MaryEraOnwardsBabbage value) txoutdata refScript) = + TxOut addr (TxOutValue MaryEraOnwardsBabbage value) txoutdata refScript -> let cEra = shelleyBasedToCardanoEra sbe in L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript -toShelleyTxOut sbe (TxOut addr (TxOutValue MaryEraOnwardsConway value) txoutdata refScript) = + TxOut addr (TxOutValue MaryEraOnwardsConway value) txoutdata refScript -> let cEra = shelleyBasedToCardanoEra sbe in L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata From e462623aba2850967bbc5d778d895364512e89d8 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 8 Nov 2023 22:24:07 +1100 Subject: [PATCH 06/11] Rename TxOutAdaOnlyByron to TxOutValueByron --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 2 +- cardano-api/internal/Cardano/Api/TxBody.hs | 22 +++++++++---------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 5208b4261f..672257380b 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -498,7 +498,7 @@ genTxIndex = TxIx . fromIntegral <$> Gen.word16 Range.constantBounded genTxOutValue :: CardanoEra era -> Gen (TxOutValue era) genTxOutValue = caseByronOrShelleyToAllegraOrMaryEraOnwards - (\w -> TxOutAdaOnlyByron w <$> genPositiveLovelace) + (\w -> TxOutValueByron w <$> genPositiveLovelace) (\w -> TxOutAdaOnly w <$> genPositiveLovelace) (\w -> TxOutValue w <$> genValueForTxOut) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 1846864b24..f0a0ef3f73 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -680,13 +680,13 @@ fromByronTxOut :: ByronEraOnly era -> Byron.TxOut -> TxOut ctx era fromByronTxOut ByronEraOnlyByron (Byron.TxOut addr value) = TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) - (TxOutAdaOnlyByron ByronEraOnlyByron (fromByronLovelace value)) + (TxOutValueByron ByronEraOnlyByron (fromByronLovelace value)) TxOutDatumNone ReferenceScriptNone toByronTxOut :: ByronEraOnly era -> TxOut ctx era -> Maybe Byron.TxOut toByronTxOut ByronEraOnlyByron = \case - TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) (TxOutAdaOnlyByron _ value) _ _ -> + TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) (TxOutValueByron _ value) _ _ -> Byron.TxOut addr <$> toByronLovelace value TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) (TxOutAdaOnly _ value) _ _ -> Byron.TxOut addr <$> toByronLovelace value @@ -702,7 +702,7 @@ toShelleyTxOut :: forall era ledgerera. -> TxOut CtxUTxO era -> Ledger.TxOut ledgerera toShelleyTxOut sbe = \case - TxOut _ (TxOutAdaOnlyByron ByronEraOnlyByron _) _ _ -> + TxOut _ (TxOutValueByron ByronEraOnlyByron _) _ _ -> case sbe of {} TxOut addr (TxOutAdaOnly ShelleyToAllegraEraShelley value) _ _ -> @@ -887,7 +887,7 @@ deriving instance Show (TxInsReference build era) data TxOutValue era where - TxOutAdaOnlyByron :: ByronEraOnly era -> Lovelace -> TxOutValue era + TxOutValueByron :: ByronEraOnly era -> Lovelace -> TxOutValue era TxOutAdaOnly :: ShelleyToAllegraEra era -> Lovelace -> TxOutValue era @@ -899,7 +899,7 @@ deriving instance Generic (TxOutValue era) instance ToJSON (TxOutValue era) where toJSON = \case - TxOutAdaOnlyByron _ ll -> toJSON ll + TxOutValueByron _ ll -> toJSON ll TxOutAdaOnly _ ll -> toJSON ll TxOutValue _ val -> toJSON val @@ -908,7 +908,7 @@ instance IsCardanoEra era => FromJSON (TxOutValue era) where caseByronOrShelleyToAllegraOrMaryEraOnwards (\bo -> do ll <- o .: "lovelace" - pure $ TxOutAdaOnlyByron bo $ selectLovelace ll + pure $ TxOutValueByron bo $ selectLovelace ll ) (\w -> do ll <- o .: "lovelace" @@ -957,7 +957,7 @@ lovelaceToTxOutValue :: () -> TxOutValue era lovelaceToTxOutValue era l = caseByronOrShelleyToAllegraOrMaryEraOnwards - (\w -> TxOutAdaOnlyByron w l) + (\w -> TxOutValueByron w l) (\w -> TxOutAdaOnly w l) (\w -> TxOutValue w (lovelaceToValue l)) era @@ -965,14 +965,14 @@ lovelaceToTxOutValue era l = txOutValueToLovelace :: TxOutValue era -> Lovelace txOutValueToLovelace tv = case tv of - TxOutAdaOnlyByron _ l -> l + TxOutValueByron _ l -> l TxOutAdaOnly _ l -> l TxOutValue _ v -> selectLovelace v txOutValueToValue :: TxOutValue era -> Value txOutValueToValue tv = case tv of - TxOutAdaOnlyByron _ l -> lovelaceToValue l + TxOutValueByron _ l -> lovelaceToValue l TxOutAdaOnly _ l -> lovelaceToValue l TxOutValue _ v -> v @@ -2474,7 +2474,7 @@ makeByronTransactionBody eon TxBodyContent { txIns, txOuts } = do classifyRangeError :: ByronEraOnly era -> TxOut CtxTx era -> TxBodyError classifyRangeError ByronEraOnlyByron txout = case txout of - TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) (TxOutAdaOnlyByron ByronEraOnlyByron value) _ _ + TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) (TxOutValueByron ByronEraOnlyByron value) _ _ | value < 0 -> TxBodyOutputNegative (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) | otherwise -> TxBodyOutputOverflow (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) @@ -3149,7 +3149,7 @@ toShelleyTxOutAny :: forall ctx era ledgerera. => ShelleyBasedEra era -> TxOut ctx era -> Ledger.TxOut ledgerera -toShelleyTxOutAny sbe (TxOut _ (TxOutAdaOnlyByron ByronEraOnlyByron _) _ _) = +toShelleyTxOutAny sbe (TxOut _ (TxOutValueByron ByronEraOnlyByron _) _ _) = case sbe of {} toShelleyTxOutAny _ (TxOut addr (TxOutAdaOnly ShelleyToAllegraEraShelley value) _ _) = From 5cd65062197624207e98c33351a4d086357787fc Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 9 Nov 2023 01:27:21 +1100 Subject: [PATCH 07/11] Use ledger types for TxOutValue --- cardano-api/cardano-api.cabal | 2 + cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 48 +++-- .../Cardano/Api/Eon/AllegraEraOnwards.hs | 1 + .../Cardano/Api/Eon/AlonzoEraOnwards.hs | 1 + .../Cardano/Api/Eon/BabbageEraOnwards.hs | 1 + .../Cardano/Api/Eon/ConwayEraOnwards.hs | 1 + .../Cardano/Api/Eon/MaryEraOnwards.hs | 1 + .../Cardano/Api/Eon/ShelleyBasedEra.hs | 3 + .../Cardano/Api/Eon/ShelleyEraOnly.hs | 1 + .../Cardano/Api/Eon/ShelleyToAllegraEra.hs | 1 + .../Cardano/Api/Eon/ShelleyToAlonzoEra.hs | 1 + .../Cardano/Api/Eon/ShelleyToBabbageEra.hs | 1 + .../Cardano/Api/Eon/ShelleyToMaryEra.hs | 1 + cardano-api/internal/Cardano/Api/Fees.hs | 60 ++---- .../internal/Cardano/Api/Ledger/Lens.hs | 21 +- .../internal/Cardano/Api/ReexposeLedger.hs | 5 +- cardano-api/internal/Cardano/Api/TxBody.hs | 195 +++++++++--------- cardano-api/internal/Cardano/Api/Value.hs | 38 ++++ cardano-api/src/Cardano/Api.hs | 2 + .../Test/Golden/ErrorsSpec.hs | 3 +- .../TxBodyOutputNegative.txt | 2 +- .../TxBodyOutputOverflow.txt | 2 +- .../Test/Cardano/Api/Typed/Value.hs | 14 +- 23 files changed, 235 insertions(+), 170 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 5feb0344cf..e58c98a5a3 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -169,6 +169,7 @@ library internal , errors , filepath , formatting + , groups , iproute , memory , microlens @@ -222,6 +223,7 @@ library -- exposed by cardano-api-ledger Cardano.Api.Ledger + reexported-modules: Cardano.Api.Ledger.Lens build-depends: bytestring , cardano-api:internal diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 672257380b..643d570cc1 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -133,6 +133,8 @@ import Cardano.Api.Byron (KeyWitness (ByronKeyWitness), import Cardano.Api.Governance.Actions.VotingProcedure import Cardano.Api.Script (scriptInEraToRefScript) import Cardano.Api.Shelley +import qualified Cardano.Api.Ledger as L +import qualified Cardano.Api.Ledger.Lens as A import qualified Cardano.Binary as CBOR import qualified Cardano.Crypto.Hash as Crypto @@ -340,9 +342,8 @@ genPolicyId = ] genAssetId :: Gen AssetId -genAssetId = Gen.choice [ AssetId <$> genPolicyId <*> genAssetName - , return AdaAssetId - ] +genAssetId = + AssetId <$> genPolicyId <*> genAssetName genQuantity :: Range Integer -> Gen Quantity genQuantity range = fromInteger <$> Gen.integral range @@ -364,34 +365,42 @@ genUnsignedQuantity = genQuantity (Range.constant 0 2) genPositiveQuantity :: Gen Quantity genPositiveQuantity = genQuantity (Range.constant 1 2) -genValue :: Gen AssetId -> Gen Quantity -> Gen Value -genValue genAId genQuant = - valueFromList <$> +genValue :: MaryEraOnwards era -> Gen AssetId -> Gen Quantity -> Gen (L.Value (ShelleyLedgerEra era)) +genValue w genAId genQuant = + toLedgerValue w . valueFromList <$> Gen.list (Range.constant 0 10) ((,) <$> genAId <*> genQuant) -- | Generate a 'Value' with any asset ID and a positive or negative quantity. -genValueDefault :: Gen Value -genValueDefault = genValue genAssetId genSignedNonZeroQuantity +genValueDefault :: MaryEraOnwards era -> Gen (L.Value (ShelleyLedgerEra era)) +genValueDefault w = genValue w genAssetId genSignedNonZeroQuantity -- | Generate a 'Value' suitable for minting, i.e. non-ADA asset ID and a -- positive or negative quantity. -genValueForMinting :: Gen Value -genValueForMinting = genValue genAssetIdNoAda genSignedNonZeroQuantity +genValueForMinting :: MaryEraOnwards era -> Gen Value +genValueForMinting w = + fromLedgerValue sbe <$> genValue w genAssetIdNoAda genSignedNonZeroQuantity where + sbe = maryEraOnwardsToShelleyBasedEra w genAssetIdNoAda :: Gen AssetId genAssetIdNoAda = AssetId <$> genPolicyId <*> genAssetName -- | Generate a 'Value' suitable for usage in a transaction output, i.e. any -- asset ID and a positive quantity. -genValueForTxOut :: Gen Value -genValueForTxOut = do - -- Generate a potentially empty list with multi assets - val <- genValue genAssetId genPositiveQuantity +genValueForTxOut :: ShelleyBasedEra era -> Gen (L.Value (ShelleyLedgerEra era)) +genValueForTxOut sbe = do -- Generate at least one positive ADA, without it Value in TxOut makes no sense -- and will fail deserialization starting with ConwayEra - ada <- (,) AdaAssetId <$> genPositiveQuantity - pure $ valueFromList (ada : valueToList val) + ada <- A.mkAdaValue sbe . L.Coin <$> Gen.integral (Range.constant 1 2) + + -- Generate a potentially empty list with multi assets + caseShelleyToAllegraOrMaryEraOnwards + (const (pure ada)) + (\w -> do + v <- genValue w genAssetId genPositiveQuantity + pure $ ada <> v + ) + sbe -- Note that we expect to sometimes generate duplicate policy id keys since we @@ -497,10 +506,9 @@ genTxIndex = TxIx . fromIntegral <$> Gen.word16 Range.constantBounded genTxOutValue :: CardanoEra era -> Gen (TxOutValue era) genTxOutValue = - caseByronOrShelleyToAllegraOrMaryEraOnwards + caseByronOrShelleyBasedEra (\w -> TxOutValueByron w <$> genPositiveLovelace) - (\w -> TxOutAdaOnly w <$> genPositiveLovelace) - (\w -> TxOutValue w <$> genValueForTxOut) + (\sbe -> TxOutValueShelleyBased sbe <$> genValueForTxOut sbe) genTxOutTxContext :: CardanoEra era -> Gen (TxOut CtxTx era) genTxOutTxContext era = @@ -624,7 +632,7 @@ genTxMintValue = (\supported -> Gen.choice [ pure TxMintNone - , TxMintValue supported <$> genValueForMinting <*> return (BuildTxWith mempty) + , TxMintValue supported <$> genValueForMinting supported <*> return (BuildTxWith mempty) ] ) diff --git a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs index 11b153d1a7..0205a79138 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs @@ -78,6 +78,7 @@ type AllegraEraOnwardsConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto , L.AllegraEraTxBody (ShelleyLedgerEra era) , L.ShelleyEraTxBody (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs index bb498cc749..10643f804c 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs @@ -88,6 +88,7 @@ type AlonzoEraOnwardsConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) , L.EraUTxO (ShelleyLedgerEra era) , L.ExtendedUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index a1c4e5611e..c95faf1038 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs @@ -84,6 +84,7 @@ type BabbageEraOnwardsConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) , L.EraUTxO (ShelleyLedgerEra era) , L.ExtendedUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index 1595ce3f88..8eab8474c7 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -87,6 +87,7 @@ type ConwayEraOnwardsConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) , L.EraUTxO (ShelleyLedgerEra era) , L.ExtendedUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto diff --git a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs index 1a40f0a631..adecf5fba5 100644 --- a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs @@ -78,6 +78,7 @@ type MaryEraOnwardsConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) , L.EraUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto , L.MaryEraTxBody (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index f0384cbfc8..d84cd96874 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -48,6 +48,7 @@ import qualified Cardano.Ledger.BaseTypes as L import Cardano.Ledger.Binary (FromCBOR) import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.SafeHash as L +import qualified Cardano.Ledger.UTxO as L import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import Ouroboros.Consensus.Shelley.Eras as Consensus (StandardAllegra, StandardAlonzo, @@ -204,6 +205,8 @@ type ShelleyBasedEraConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) + , L.EraUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto , L.ShelleyEraTxBody (ShelleyLedgerEra era) , L.ShelleyEraTxCert (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs index 7a1c579fea..4bee0227fe 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs @@ -72,6 +72,7 @@ type ShelleyEraOnlyConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) , L.ExactEra L.ShelleyEra (ShelleyLedgerEra era) , L.ExactEra L.ShelleyEra (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs index 5115b73a4f..4981aafbb2 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs @@ -75,6 +75,7 @@ type ShelleyToAllegraEraConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) , L.EraUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto , L.ProtVerAtMost (ShelleyLedgerEra era) 4 diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs index 5b910df0d2..cc708db742 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs @@ -77,6 +77,7 @@ type ShelleyToAlonzoEraConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto , L.ProtVerAtMost (ShelleyLedgerEra era) 6 , L.ProtVerAtMost (ShelleyLedgerEra era) 8 diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs index fa96be8607..e6b0907b36 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs @@ -79,6 +79,7 @@ type ShelleyToBabbageEraConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto , L.ProtVerAtMost (ShelleyLedgerEra era) 8 , L.ShelleyEraTxBody (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs index 81c5d149f2..41c0b919a9 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs @@ -75,6 +75,7 @@ type ShelleyToMaryEraConstraints era = , L.EraPParams (ShelleyLedgerEra era) , L.EraTx (ShelleyLedgerEra era) , L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxOut (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto , L.ProtVerAtMost (ShelleyLedgerEra era) 4 , L.ProtVerAtMost (ShelleyLedgerEra era) 6 diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 75240ddd6a..43eea7906b 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -49,12 +49,11 @@ import Cardano.Api.Address import Cardano.Api.Certificate import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ByronEraOnly -import Cardano.Api.Eon.MaryEraOnwards import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eon.ShelleyToAllegraEra import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core import Cardano.Api.Error +import qualified Cardano.Api.Ledger.Lens as A import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import Cardano.Api.Query @@ -92,7 +91,7 @@ import Data.Ratio import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as Text -import Lens.Micro ((^.)) +import Lens.Micro ((^.), (.~)) import Prettyprinter import Prettyprinter.Render.String @@ -571,10 +570,15 @@ evaluateTransactionBalance sbe _ _ _ _ _ (ByronTxBody ByronEraOnlyByron _) = case sbe of {} evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo (ShelleyTxBody _ txbody _ _ _ _) = - caseShelleyToAllegraOrMaryEraOnwards - evalAdaOnly - evalMultiAsset - sbe + shelleyBasedEraConstraints sbe + $ TxOutValueShelleyBased sbe + $ L.evalBalanceTxBody + pp + lookupDelegDeposit + lookupDRepDeposit + isRegPool + (toLedgerUTxO sbe utxo) + txbody where isRegPool :: Ledger.KeyHash Ledger.StakePool Ledger.StandardCrypto -> Bool isRegPool kh = StakePoolKeyHash kh `Set.member` poolids @@ -591,30 +595,6 @@ evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits u toShelleyLovelace <$> Map.lookup drepCred drepDelegDeposits - evalMultiAsset :: MaryEraOnwards era -> TxOutValue era - evalMultiAsset w = - maryEraOnwardsConstraints w - $ TxOutValue w . fromMaryValue - $ L.evalBalanceTxBody - pp - lookupDelegDeposit - lookupDRepDeposit - isRegPool - (toLedgerUTxO sbe utxo) - txbody - - evalAdaOnly :: ShelleyToAllegraEra era -> TxOutValue era - evalAdaOnly w = - shelleyToAllegraEraConstraints w - $ TxOutAdaOnly w . fromShelleyLovelace - $ L.evalBalanceTxBody - pp - lookupDelegDeposit - lookupDRepDeposit - isRegPool - (toLedgerUTxO sbe utxo) - txbody - -- ---------------------------------------------------------------------------- -- Automated transaction building -- @@ -785,7 +765,8 @@ makeTransactionBodyAutoBalance :: forall era. () -> Maybe Word -- ^ Override key witnesses -> Either TxBodyErrorAutoBalance (BalancedTxBody era) makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParameters pp) poolids stakeDelegDeposits - drepDelegDeposits utxo txbodycontent changeaddr mnkeys = do + drepDelegDeposits utxo txbodycontent changeaddr mnkeys = + shelleyBasedEraConstraints sbe $ do -- Our strategy is to: -- 1. evaluate all the scripts to get the exec units, update with ex units -- 2. figure out the overall min fees @@ -828,21 +809,22 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame -- However, since at this point we know how much non-Ada change to give -- we can use the true values for that. - let outgoingNonAda = mconcat [filterValue isNotAda v | (TxOut _ (TxOutValue _ v) _ _) <- txOuts txbodycontent] - let incomingNonAda = mconcat [filterValue isNotAda v | (TxOut _ (TxOutValue _ v) _ _) <- Map.elems $ unUTxO utxo] + let outgoingNonAda = mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- txOuts txbodycontent] + let incomingNonAda = mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- Map.elems $ unUTxO utxo] let mintedNonAda = case txMintValue txbodycontent1 of TxMintNone -> mempty - TxMintValue _ v _ -> v + TxMintValue w v _ -> toLedgerValue w v let nonAdaChange = mconcat [ incomingNonAda , mintedNonAda - , negateValue outgoingNonAda + , negateLedgerValue sbe outgoingNonAda ] + let maxLovelace = Lovelace (2^(64 :: Integer)) - 1 let changeTxOut = caseByronOrShelleyToAllegraOrMaryEraOnwards - (const $ lovelaceToTxOutValue era $ Lovelace (2^(64 :: Integer)) - 1) - (const $ lovelaceToTxOutValue era $ Lovelace (2^(64 :: Integer)) - 1) - (\w -> TxOutValue w (lovelaceToValue (Lovelace (2^(64 :: Integer)) - 1) <> nonAdaChange)) + (const $ lovelaceToTxOutValue era maxLovelace) + (const $ lovelaceToTxOutValue era maxLovelace) + (const $ TxOutValueShelleyBased sbe (nonAdaChange & A.adaAssetL sbe .~ lovelaceToCoin maxLovelace)) era let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr diff --git a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs index bd1c89290f..5b569a7ad8 100644 --- a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs +++ b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs @@ -9,6 +9,7 @@ module Cardano.Api.Ledger.Lens -- * Constructors , mkAdaOnlyTxOut + , mkAdaValue -- * Lenses , strictMaybeL @@ -34,6 +35,8 @@ module Cardano.Api.Ledger.Lens , proposalProceduresTxBodyL , adaAssetL , multiAssetL + , valueTxOutL + , valueTxOutAdaAssetL ) where import Cardano.Api.Eon.AllegraEraOnwards @@ -176,9 +179,17 @@ proposalProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.propos mkAdaOnlyTxOut :: ShelleyBasedEra era -> L.Addr (L.EraCrypto (ShelleyLedgerEra era)) -> L.Coin -> L.TxOut (ShelleyLedgerEra era) mkAdaOnlyTxOut sbe addr coin = + mkBasicTxOut sbe addr (mkAdaValue sbe coin) + +mkBasicTxOut :: ShelleyBasedEra era -> L.Addr (L.EraCrypto (ShelleyLedgerEra era)) -> L.Value (ShelleyLedgerEra era) -> L.TxOut (ShelleyLedgerEra era) +mkBasicTxOut sbe addr value = + shelleyBasedEraConstraints sbe $ L.mkBasicTxOut addr value + +mkAdaValue :: ShelleyBasedEra era -> L.Coin -> L.Value (ShelleyLedgerEra era) +mkAdaValue sbe coin = caseShelleyToAllegraOrMaryEraOnwards - (const (L.mkBasicTxOut addr mempty)) - (const (L.mkBasicTxOut addr (L.MaryValue (L.unCoin coin) mempty))) + (const coin) + (const (L.MaryValue (L.unCoin coin) mempty)) sbe adaAssetL :: ShelleyBasedEra era -> Lens' (L.Value (ShelleyLedgerEra era)) L.Coin @@ -203,3 +214,9 @@ multiAssetL w = maryEraOnwardsConstraints w $ lens (\(L.MaryValue _ ma) -> ma) (\(L.MaryValue c _) ma -> L.MaryValue c ma) + +valueTxOutL :: ShelleyBasedEra era -> Lens' (L.TxOut (ShelleyLedgerEra era)) (L.Value (ShelleyLedgerEra era)) +valueTxOutL sbe = shelleyBasedEraConstraints sbe L.valueTxOutL + +valueTxOutAdaAssetL :: ShelleyBasedEra era -> Lens' (L.TxOut (ShelleyLedgerEra era)) L.Coin +valueTxOutAdaAssetL sbe = valueTxOutL sbe . adaAssetL sbe diff --git a/cardano-api/internal/Cardano/Api/ReexposeLedger.hs b/cardano-api/internal/Cardano/Api/ReexposeLedger.hs index ec5caf831f..4374ab7720 100644 --- a/cardano-api/internal/Cardano/Api/ReexposeLedger.hs +++ b/cardano-api/internal/Cardano/Api/ReexposeLedger.hs @@ -41,6 +41,7 @@ module Cardano.Api.ReexposeLedger , PoolCert(..) , PParams(..) , PParamsUpdate + , Value , addDeltaCoin , toDeltaCoin , toEraCBOR @@ -124,7 +125,7 @@ import Cardano.Ledger.Conway.Governance (Anchor (..), GovActionId (..) Vote (..), Voter (..), VotingProcedure (..)) import Cardano.Ledger.Conway.TxCert (ConwayDelegCert (..), ConwayEraTxCert (..), ConwayGovCert (..), ConwayTxCert (..), Delegatee (..), pattern UpdateDRepTxCert) -import Cardano.Ledger.Core (EraCrypto, PParams (..), PoolCert (..), fromEraCBOR, +import Cardano.Ledger.Core (EraCrypto, PParams (..), PoolCert (..), Value, fromEraCBOR, toEraCBOR) import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Crypto (Crypto, StandardCrypto) @@ -135,5 +136,3 @@ import Cardano.Ledger.Shelley.TxCert (EraTxCert (..), GenesisDelegCert MIRPot (..), MIRTarget (..), ShelleyDelegCert (..), ShelleyEraTxCert (..), ShelleyTxCert (..)) import Cardano.Slotting.Slot (EpochNo (..)) - - diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index f0a0ef3f73..a3b0a40f7e 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -159,7 +159,6 @@ import Cardano.Api.Eon.ByronEraOnly import Cardano.Api.Eon.ConwayEraOnwards import Cardano.Api.Eon.MaryEraOnwards import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eon.ShelleyToAllegraEra import Cardano.Api.Eon.ShelleyToBabbageEra import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core @@ -251,7 +250,6 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) import Data.Word (Word16, Word32, Word64) -import GHC.Generics import Lens.Micro hiding (ix) import Lens.Micro.Extras (view) import qualified Text.Parsec as Parsec @@ -688,9 +686,7 @@ toByronTxOut :: ByronEraOnly era -> TxOut ctx era -> Maybe Byron.TxOut toByronTxOut ByronEraOnlyByron = \case TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) (TxOutValueByron _ value) _ _ -> Byron.TxOut addr <$> toByronLovelace value - TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) (TxOutAdaOnly _ value) _ _ -> - Byron.TxOut addr <$> toByronLovelace value - TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) (TxOutValue w _) _ _ -> + TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) (TxOutValueShelleyBased w _) _ _ -> case w of {} TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress{}) _ _ _ -> case sbe of {} @@ -701,50 +697,39 @@ toShelleyTxOut :: forall era ledgerera. => ShelleyBasedEra era -> TxOut CtxUTxO era -> Ledger.TxOut ledgerera -toShelleyTxOut sbe = \case +toShelleyTxOut sbe = \case -- jky simplify TxOut _ (TxOutValueByron ByronEraOnlyByron _) _ _ -> case sbe of {} - TxOut addr (TxOutAdaOnly ShelleyToAllegraEraShelley value) _ _ -> - L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) - - TxOut addr (TxOutAdaOnly ShelleyToAllegraEraAllegra value) _ _ -> - L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) - - TxOut addr (TxOutValue MaryEraOnwardsMary value) _ _ -> - L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) - - TxOut addr (TxOutValue MaryEraOnwardsAlonzo value) txoutdata _ -> - L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) - & L.dataHashTxOutL .~ toAlonzoTxOutDataHash txoutdata - - TxOut addr (TxOutValue MaryEraOnwardsBabbage value) txoutdata refScript -> - let cEra = shelleyBasedToCardanoEra sbe - in L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) - & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata - & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript - - TxOut addr (TxOutValue MaryEraOnwardsConway value) txoutdata refScript -> - let cEra = shelleyBasedToCardanoEra sbe - in L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) - & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata - & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript - -fromShelleyTxOut :: forall era ledgerera ctx. () - => ShelleyLedgerEra era ~ ledgerera + TxOut addr (TxOutValueShelleyBased _ value) txoutdata refScript -> + let cEra = shelleyBasedToCardanoEra sbe in + case sbe of + ShelleyBasedEraShelley -> + L.mkBasicTxOut (toShelleyAddr addr) value + ShelleyBasedEraAllegra -> + L.mkBasicTxOut (toShelleyAddr addr) value + ShelleyBasedEraMary -> + L.mkBasicTxOut (toShelleyAddr addr) value + ShelleyBasedEraAlonzo -> + L.mkBasicTxOut (toShelleyAddr addr) value + & L.dataHashTxOutL .~ toAlonzoTxOutDataHash txoutdata + ShelleyBasedEraBabbage -> + L.mkBasicTxOut (toShelleyAddr addr) value + & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata + & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript + ShelleyBasedEraConway -> + L.mkBasicTxOut (toShelleyAddr addr) value + & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata + & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript + + +fromShelleyTxOut :: forall era ctx. () => ShelleyBasedEra era - -> Core.TxOut ledgerera + -> Core.TxOut (ShelleyLedgerEra era) -> TxOut ctx era -fromShelleyTxOut sbe ledgerTxOut = do - let txOutValue :: TxOutValue era - txOutValue = - caseShelleyToAllegraOrMaryEraOnwards - (\w -> TxOutAdaOnly w (fromShelleyLovelace (ledgerTxOut ^. L.valueTxOutL))) - (\w -> TxOutValue w (fromMaryValue (ledgerTxOut ^. L.valueTxOutL))) - sbe - - let addressInEra :: AddressInEra era - addressInEra = shelleyBasedEraConstraints sbe $ fromShelleyAddr sbe $ ledgerTxOut ^. L.addrTxOutL +fromShelleyTxOut sbe ledgerTxOut = shelleyBasedEraConstraints sbe $ do + let txOutValue = TxOutValueShelleyBased sbe $ ledgerTxOut ^. A.valueTxOutL sbe + let addressInEra = fromShelleyAddr sbe $ ledgerTxOut ^. L.addrTxOutL case sbe of ShelleyBasedEraShelley -> @@ -887,37 +872,50 @@ deriving instance Show (TxInsReference build era) data TxOutValue era where - TxOutValueByron :: ByronEraOnly era -> Lovelace -> TxOutValue era - - TxOutAdaOnly :: ShelleyToAllegraEra era -> Lovelace -> TxOutValue era + TxOutValueByron + :: ByronEraOnly era + -> Lovelace + -> TxOutValue era - TxOutValue :: MaryEraOnwards era -> Value -> TxOutValue era + TxOutValueShelleyBased + :: ( Eq (Ledger.Value (ShelleyLedgerEra era)) + , Show (Ledger.Value (ShelleyLedgerEra era)) + ) + => ShelleyBasedEra era + -> L.Value (ShelleyLedgerEra era) + -> TxOutValue era deriving instance Eq (TxOutValue era) deriving instance Show (TxOutValue era) -deriving instance Generic (TxOutValue era) -instance ToJSON (TxOutValue era) where +instance IsCardanoEra era => ToJSON (TxOutValue era) where toJSON = \case - TxOutValueByron _ ll -> toJSON ll - TxOutAdaOnly _ ll -> toJSON ll - TxOutValue _ val -> toJSON val + TxOutValueByron _ ll -> + toJSON ll + TxOutValueShelleyBased sbe val -> + shelleyBasedEraConstraints sbe $ toJSON (fromLedgerValue sbe val) instance IsCardanoEra era => FromJSON (TxOutValue era) where parseJSON = withObject "TxOutValue" $ \o -> - caseByronOrShelleyToAllegraOrMaryEraOnwards + caseByronOrShelleyBasedEra (\bo -> do ll <- o .: "lovelace" pure $ TxOutValueByron bo $ selectLovelace ll ) - (\w -> do - ll <- o .: "lovelace" - pure $ TxOutAdaOnly w $ selectLovelace ll - ) - (\w -> do - let l = KeyMap.toList o - vals <- mapM decodeAssetId l - pure $ TxOutValue w $ mconcat vals + (\sbe -> + caseShelleyToAllegraOrMaryEraOnwards + (const $ do + ll <- o .: "lovelace" + pure + $ TxOutValueShelleyBased sbe + $ A.mkAdaValue sbe $ lovelaceToCoin ll + ) + (\w -> do + let l = KeyMap.toList o + vals <- mapM decodeAssetId l + pure $ TxOutValueShelleyBased sbe $ toLedgerValue w $ mconcat vals + ) + sbe ) cardanoEra where @@ -955,26 +953,23 @@ lovelaceToTxOutValue :: () => CardanoEra era -> Lovelace -> TxOutValue era -lovelaceToTxOutValue era l = - caseByronOrShelleyToAllegraOrMaryEraOnwards - (\w -> TxOutValueByron w l) - (\w -> TxOutAdaOnly w l) - (\w -> TxOutValue w (lovelaceToValue l)) +lovelaceToTxOutValue era ll = + caseByronOrShelleyBasedEra + (\w -> TxOutValueByron w ll) + (\w -> TxOutValueShelleyBased w $ A.mkAdaValue w $ lovelaceToCoin ll) era txOutValueToLovelace :: TxOutValue era -> Lovelace txOutValueToLovelace tv = case tv of - TxOutValueByron _ l -> l - TxOutAdaOnly _ l -> l - TxOutValue _ v -> selectLovelace v + TxOutValueByron _ l -> l + TxOutValueShelleyBased sbe v -> coinToLovelace $ v ^. A.adaAssetL sbe txOutValueToValue :: TxOutValue era -> Value txOutValueToValue tv = case tv of - TxOutValueByron _ l -> lovelaceToValue l - TxOutAdaOnly _ l -> lovelaceToValue l - TxOutValue _ v -> v + TxOutValueByron _ l -> lovelaceToValue l + TxOutValueShelleyBased sbe v -> fromLedgerValue sbe v prettyRenderTxOut :: TxOutInAnyEra -> Text prettyRenderTxOut (TxOutInAnyEra _ (TxOut (AddressInEra _ addr) txOutVal _ _)) = @@ -2214,9 +2209,11 @@ fromAlonzoTxOut w txdatums txOut = alonzoEraOnwardsConstraints w $ TxOut (fromShelleyAddr shelleyBasedEra (txOut ^. L.addrTxOutL)) - (TxOutValue (alonzoEraOnwardsToMaryEraOnwards w) (fromMaryValue (txOut ^. L.valueTxOutL))) + (TxOutValueShelleyBased sbe (txOut ^. L.valueTxOutL)) (fromAlonzoTxOutDatum w txdatums (txOut ^. L.dataHashTxOutL)) ReferenceScriptNone + where + sbe = alonzoEraOnwardsToShelleyBasedEra w fromAlonzoTxOutDatum :: () => AlonzoEraOnwards era @@ -2238,13 +2235,15 @@ fromBabbageTxOut w txdatums txout = babbageEraOnwardsConstraints w $ TxOut (fromShelleyAddr shelleyBasedEra (txout ^. L.addrTxOutL)) - (TxOutValue (babbageEraOnwardsToMaryEraOnwards w) (fromMaryValue (txout ^. L.valueTxOutL))) + (TxOutValueShelleyBased sbe (txout ^. L.valueTxOutL)) babbageTxOutDatum (case txout ^. L.referenceScriptTxOutL of SNothing -> ReferenceScriptNone SJust rScript -> fromShelleyScriptToReferenceScript shelleyBasedEra rScript ) where + sbe = babbageEraOnwardsToShelleyBasedEra w + -- NOTE: This is different to 'fromBabbageTxOutDatum' as it may resolve -- 'DatumHash' values using the datums included in the transaction. babbageTxOutDatum :: TxOutDatum CtxTx era @@ -2478,8 +2477,7 @@ classifyRangeError ByronEraOnlyByron txout = | value < 0 -> TxBodyOutputNegative (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) | otherwise -> TxBodyOutputOverflow (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) - TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) (TxOutAdaOnly w _) _ _ -> case w of {} - TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) (TxOutValue w _) _ _ -> case w of {} + TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) (TxOutValueShelleyBased w _) _ _ -> case w of {} TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress{}) _ _ _ -> case sbe of {} getByronTxBodyContent :: () @@ -3149,33 +3147,36 @@ toShelleyTxOutAny :: forall ctx era ledgerera. => ShelleyBasedEra era -> TxOut ctx era -> Ledger.TxOut ledgerera -toShelleyTxOutAny sbe (TxOut _ (TxOutValueByron ByronEraOnlyByron _) _ _) = +toShelleyTxOutAny sbe = \case + TxOut _ (TxOutValueByron ByronEraOnlyByron _) _ _ -> case sbe of {} -toShelleyTxOutAny _ (TxOut addr (TxOutAdaOnly ShelleyToAllegraEraShelley value) _ _) = - L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) + TxOut addr (TxOutValueShelleyBased _ value) txoutdata refScript -> + case sbe of + ShelleyBasedEraShelley -> + L.mkBasicTxOut (toShelleyAddr addr) value -toShelleyTxOutAny _ (TxOut addr (TxOutAdaOnly ShelleyToAllegraEraAllegra value) _ _) = - L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) + ShelleyBasedEraAllegra -> + L.mkBasicTxOut (toShelleyAddr addr) value -toShelleyTxOutAny _ (TxOut addr (TxOutValue MaryEraOnwardsMary value) _ _) = - L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) + ShelleyBasedEraMary -> + L.mkBasicTxOut (toShelleyAddr addr) value -toShelleyTxOutAny _ (TxOut addr (TxOutValue MaryEraOnwardsAlonzo value) txoutdata _) = - L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) - & L.dataHashTxOutL .~ toAlonzoTxOutDataHash' txoutdata + ShelleyBasedEraAlonzo -> + L.mkBasicTxOut (toShelleyAddr addr) value + & L.dataHashTxOutL .~ toAlonzoTxOutDataHash' txoutdata -toShelleyTxOutAny sbe (TxOut addr (TxOutValue MaryEraOnwardsBabbage value) txoutdata refScript) = - let cEra = shelleyBasedToCardanoEra sbe - in L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) - & L.datumTxOutL .~ toBabbageTxOutDatum' txoutdata - & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript + ShelleyBasedEraBabbage -> + L.mkBasicTxOut (toShelleyAddr addr) value + & L.datumTxOutL .~ toBabbageTxOutDatum' txoutdata + & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript -toShelleyTxOutAny sbe (TxOut addr (TxOutValue MaryEraOnwardsConway value) txoutdata refScript) = - let cEra = shelleyBasedToCardanoEra sbe - in L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) - & L.datumTxOutL .~ toBabbageTxOutDatum' txoutdata - & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript + ShelleyBasedEraConway -> + L.mkBasicTxOut (toShelleyAddr addr) value + & L.datumTxOutL .~ toBabbageTxOutDatum' txoutdata + & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript + where + cEra = shelleyBasedToCardanoEra sbe toAlonzoTxOutDataHash' :: TxOutDatum ctx AlonzoEra -> StrictMaybe (L.DataHash StandardCrypto) diff --git a/cardano-api/internal/Cardano/Api/Value.hs b/cardano-api/internal/Cardano/Api/Value.hs index d306af16a1..62380b2e91 100644 --- a/cardano-api/internal/Cardano/Api/Value.hs +++ b/cardano-api/internal/Cardano/Api/Value.hs @@ -24,6 +24,7 @@ module Cardano.Api.Value , valueToList , filterValue , negateValue + , negateLedgerValue , calcMinimumDeposit -- ** Ada \/ Lovelace specifically @@ -51,13 +52,21 @@ module Cardano.Api.Value , fromShelleyDeltaLovelace , toMaryValue , fromMaryValue + , fromLedgerValue + , lovelaceToCoin + , toLedgerValue + , coinToLovelace -- * Data family instances , AsType(..) ) where +import Cardano.Api.Eon.MaryEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Case import Cardano.Api.Error (displayError) import Cardano.Api.HasTypeProxy +import qualified Cardano.Api.Ledger.Lens as A import Cardano.Api.Script import Cardano.Api.SerialiseCBOR import Cardano.Api.SerialiseRaw @@ -65,6 +74,7 @@ import Cardano.Api.SerialiseUsing import Cardano.Api.Utils (failEitherWith) import qualified Cardano.Chain.Common as Byron +import qualified Cardano.Ledger.Allegra.Core as L import qualified Cardano.Ledger.Coin as Shelley import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Ledger.Mary.TxOut as Mary (scaledMinDeposit) @@ -81,6 +91,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Short as Short import Data.Data (Data) +import Data.Function ((&)) +import Data.Group (invert) import qualified Data.Map.Merge.Strict as Map import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -88,6 +100,7 @@ import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import Lens.Micro ((%~)) -- ---------------------------------------------------------------------------- -- Lovelace @@ -245,6 +258,13 @@ valueToList (Value m) = Map.toList m negateValue :: Value -> Value negateValue (Value m) = Value (Map.map negate m) +negateLedgerValue :: ShelleyBasedEra era -> L.Value (ShelleyLedgerEra era) -> L.Value (ShelleyLedgerEra era) +negateLedgerValue sbe v = + caseShelleyToAllegraOrMaryEraOnwards + (\_ -> v & A.adaAssetL sbe %~ Shelley.Coin . negate . Shelley.unCoin) + (\w -> v & A.multiAssetL w %~ invert) + sbe + filterValue :: (AssetId -> Bool) -> Value -> Value filterValue p (Value m) = Value (Map.filterWithKey (\k _v -> p k) m) @@ -254,6 +274,15 @@ selectLovelace = quantityToLovelace . flip selectAsset AdaAssetId lovelaceToValue :: Lovelace -> Value lovelaceToValue = Value . Map.singleton AdaAssetId . lovelaceToQuantity +lovelaceToCoin :: Lovelace -> Shelley.Coin +lovelaceToCoin (Lovelace ll) = Shelley.Coin ll + +coinToLovelace :: Shelley.Coin -> Lovelace +coinToLovelace (Shelley.Coin ll) = Lovelace ll + +coinToValue :: Shelley.Coin -> Value +coinToValue = lovelaceToValue . coinToLovelace + -- | Check if the 'Value' consists of /only/ 'Lovelace' and no other assets, -- and if so then return the Lovelace. -- @@ -281,6 +310,15 @@ toMaryValue v = toMaryAssetName :: AssetName -> Mary.AssetName toMaryAssetName (AssetName n) = Mary.AssetName $ Short.toShort n +toLedgerValue :: MaryEraOnwards era -> Value -> L.Value (ShelleyLedgerEra era) +toLedgerValue w = maryEraOnwardsConstraints w toMaryValue + +fromLedgerValue :: ShelleyBasedEra era -> L.Value (ShelleyLedgerEra era) -> Value +fromLedgerValue sbe v = + caseShelleyToAllegraOrMaryEraOnwards + (const (coinToValue v)) + (const (fromMaryValue v)) + sbe fromMaryValue :: MaryValue StandardCrypto -> Value fromMaryValue (MaryValue lovelace other) = diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 743683611e..c35637189a 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -270,6 +270,8 @@ module Cardano.Api ( valueFromNestedRep, renderValue, renderValuePretty, + toLedgerValue, + fromLedgerValue, -- ** Ada \/ Lovelace within multi-asset values quantityToLovelace, diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs index 57e303f201..9cac543f6c 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs @@ -39,6 +39,7 @@ import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Ledger import qualified Cardano.Ledger.Alonzo.TxInfo as Ledger import qualified Cardano.Ledger.Alonzo.TxWits as Ledger +import qualified Cardano.Ledger.Coin as L import qualified PlutusCore.Evaluation.Machine.CostModelInterface as Plutus import qualified PlutusLedgerApi.Common as Plutus @@ -116,7 +117,7 @@ changeaddr1 = (PaymentCredentialByKey (verificationKeyHash paymentVerKey1)) NoStakeAddress) txOutValue1 :: TxOutValue AllegraEra -txOutValue1 = TxOutAdaOnly ShelleyToAllegraEraAllegra 1 +txOutValue1 = TxOutValueShelleyBased ShelleyBasedEraAllegra (L.Coin 1) txout1 :: TxOut ctx AllegraEra txout1 = TxOut changeaddr1 txOutValue1 TxOutDatumNone ReferenceScriptNone diff --git a/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputNegative.txt b/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputNegative.txt index 7cbed2e6a9..69bff6d983 100644 --- a/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputNegative.txt +++ b/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputNegative.txt @@ -1 +1 @@ -Negative quantity (1) in transaction output: TxOutInAnyEra AllegraEra (TxOut (AddressInEra (ShelleyAddressInEra ShelleyBasedEraAllegra) (ShelleyAddress Mainnet (KeyHashObj (KeyHash "250ca83514191f9ceaccee2eb3276d5ad964e17cc31a067691e04ca8")) StakeRefNull)) (TxOutAdaOnly ShelleyToAllegraEraAllegra (Lovelace 1)) TxOutDatumNone ReferenceScriptNone) \ No newline at end of file +Negative quantity (1) in transaction output: TxOutInAnyEra AllegraEra (TxOut (AddressInEra (ShelleyAddressInEra ShelleyBasedEraAllegra) (ShelleyAddress Mainnet (KeyHashObj (KeyHash "250ca83514191f9ceaccee2eb3276d5ad964e17cc31a067691e04ca8")) StakeRefNull)) (TxOutValueShelleyBased ShelleyBasedEraAllegra (Coin 1)) TxOutDatumNone ReferenceScriptNone) \ No newline at end of file diff --git a/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputOverflow.txt b/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputOverflow.txt index 7fb97af17a..29eca45e72 100644 --- a/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputOverflow.txt +++ b/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.TxBody.TxBodyError/TxBodyOutputOverflow.txt @@ -1 +1 @@ -Quantity too large (1 >= 2^64) in transaction output: TxOutInAnyEra AllegraEra (TxOut (AddressInEra (ShelleyAddressInEra ShelleyBasedEraAllegra) (ShelleyAddress Mainnet (KeyHashObj (KeyHash "250ca83514191f9ceaccee2eb3276d5ad964e17cc31a067691e04ca8")) StakeRefNull)) (TxOutAdaOnly ShelleyToAllegraEraAllegra (Lovelace 1)) TxOutDatumNone ReferenceScriptNone) \ No newline at end of file +Quantity too large (1 >= 2^64) in transaction output: TxOutInAnyEra AllegraEra (TxOut (AddressInEra (ShelleyAddressInEra ShelleyBasedEraAllegra) (ShelleyAddress Mainnet (KeyHashObj (KeyHash "250ca83514191f9ceaccee2eb3276d5ad964e17cc31a067691e04ca8")) StakeRefNull)) (TxOutValueShelleyBased ShelleyBasedEraAllegra (Coin 1)) TxOutDatumNone ReferenceScriptNone) \ No newline at end of file diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Value.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Value.hs index d13c521f82..262c791f92 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Value.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Value.hs @@ -2,8 +2,8 @@ module Test.Cardano.Api.Typed.Value ( tests ) where -import Cardano.Api (ValueNestedBundle (..), ValueNestedRep (..), valueFromNestedRep, - valueToNestedRep) +import Cardano.Api (MaryEraOnwards (..), ShelleyBasedEra (..), ValueNestedBundle (..), + ValueNestedRep (..), fromLedgerValue, valueFromNestedRep, valueToNestedRep) import Prelude @@ -19,14 +19,16 @@ import Test.Tasty.Hedgehog (testProperty) prop_roundtrip_Value_JSON :: Property prop_roundtrip_Value_JSON = - property $ do v <- forAll genValueDefault - tripping v encode eitherDecode + property $ do + v <- forAll $ fromLedgerValue ShelleyBasedEraConway <$> genValueDefault MaryEraOnwardsConway + tripping v encode eitherDecode prop_roundtrip_Value_flatten_unflatten :: Property prop_roundtrip_Value_flatten_unflatten = - property $ do v <- forAll genValueDefault - valueFromNestedRep (valueToNestedRep v) === v + property $ do + v <- forAll $ fromLedgerValue ShelleyBasedEraConway <$> genValueDefault MaryEraOnwardsConway + valueFromNestedRep (valueToNestedRep v) === v prop_roundtrip_Value_unflatten_flatten :: Property prop_roundtrip_Value_unflatten_flatten = From 589fb2046cc2203bc86508004b633d9439f9ea38 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 9 Nov 2023 01:39:03 +1100 Subject: [PATCH 08/11] Delete caseByronOrShelleyToAllegraOrMaryEraOnwards --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 5 ++--- cardano-api/internal/Cardano/Api/Eras.hs | 1 - cardano-api/internal/Cardano/Api/Eras/Case.hs | 18 ------------------ cardano-api/internal/Cardano/Api/Fees.hs | 11 ++++++----- cardano-api/src/Cardano/Api.hs | 1 - 5 files changed, 8 insertions(+), 28 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 643d570cc1..0dea0ee6ac 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -626,9 +626,8 @@ genTxUpdateProposal sbe = genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era) genTxMintValue = - caseByronOrShelleyToAllegraOrMaryEraOnwards - (const (pure TxMintNone)) - (const (pure TxMintNone)) + inEonForEra + (pure TxMintNone) (\supported -> Gen.choice [ pure TxMintNone diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index bf13a50240..b9b8bfabef 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -42,7 +42,6 @@ module Cardano.Api.Eras , caseByronOrShelleyBasedEra -- ** Case on ShelleyBasedEra - , caseByronOrShelleyToAllegraOrMaryEraOnwards , caseByronToAlonzoOrBabbageEraOnwards , caseShelleyToAllegraOrMaryEraOnwards , caseShelleyToMaryOrAlonzoEraOnwards diff --git a/cardano-api/internal/Cardano/Api/Eras/Case.hs b/cardano-api/internal/Cardano/Api/Eras/Case.hs index 6c18b37d39..202315da7c 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Case.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Case.hs @@ -7,7 +7,6 @@ module Cardano.Api.Eras.Case ( -- Case on CardanoEra caseByronOrShelleyBasedEra - , caseByronOrShelleyToAllegraOrMaryEraOnwards , caseByronToAlonzoOrBabbageEraOnwards -- Case on ShelleyBasedEra @@ -58,23 +57,6 @@ caseByronOrShelleyBasedEra l r = \case BabbageEra -> r ShelleyBasedEraBabbage ConwayEra -> r ShelleyBasedEraConway --- | @caseByronOrShelleyToAllegraOrMaryEraOnwards l m r era@ applies @l@ to byron; @m@ to shelley, and allegra; --- and @r@ to mary and later eras. -caseByronOrShelleyToAllegraOrMaryEraOnwards :: () - => (ByronEraOnlyConstraints era => ByronEraOnly era -> a) - -> (ShelleyToAllegraEraConstraints era => ShelleyToAllegraEra era -> a) - -> (MaryEraOnwardsConstraints era => MaryEraOnwards era -> a) - -> CardanoEra era - -> a -caseByronOrShelleyToAllegraOrMaryEraOnwards l m r = \case - ByronEra -> l ByronEraOnlyByron - ShelleyEra -> m ShelleyToAllegraEraShelley - AllegraEra -> m ShelleyToAllegraEraAllegra - MaryEra -> r MaryEraOnwardsMary - AlonzoEra -> r MaryEraOnwardsAlonzo - BabbageEra -> r MaryEraOnwardsBabbage - ConwayEra -> r MaryEraOnwardsConway - -- | @caseByronToAlonzoOrBabbageEraOnwards f g era@ applies @f@ to byron, shelley, allegra, mary, and alonzo; -- and @g@ to babbage and later eras. caseByronToAlonzoOrBabbageEraOnwards :: () diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 43eea7906b..cc2edd6913 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -49,6 +49,7 @@ import Cardano.Api.Address import Cardano.Api.Certificate import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ByronEraOnly +import Cardano.Api.Eon.MaryEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core @@ -821,11 +822,11 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame ] let maxLovelace = Lovelace (2^(64 :: Integer)) - 1 - let changeTxOut = caseByronOrShelleyToAllegraOrMaryEraOnwards - (const $ lovelaceToTxOutValue era maxLovelace) - (const $ lovelaceToTxOutValue era maxLovelace) - (const $ TxOutValueShelleyBased sbe (nonAdaChange & A.adaAssetL sbe .~ lovelaceToCoin maxLovelace)) - era + let changeTxOut = forShelleyBasedEraInEon sbe + (lovelaceToTxOutValue era maxLovelace) + (\w -> maryEraOnwardsConstraints w + $ TxOutValueShelleyBased sbe (nonAdaChange & A.adaAssetL sbe .~ lovelaceToCoin maxLovelace) + ) let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr txbody1 <- first TxBodyError $ -- TODO: impossible to fail now diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index c35637189a..2071f2188f 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -132,7 +132,6 @@ module Cardano.Api ( -- ** Case on CardanoEra caseByronOrShelleyBasedEra, - caseByronOrShelleyToAllegraOrMaryEraOnwards, caseByronToAlonzoOrBabbageEraOnwards, -- ** Case on ShelleyBasedEra From 984ebfafa273edcd77d9574decf3614ce5aeaae5 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 9 Nov 2023 02:13:52 +1100 Subject: [PATCH 09/11] The dataHashTxOutL appears to be a feature only used Alonzo. We can simplify the code by deleting the feature we no longer use --- cardano-api/internal/Cardano/Api/TxBody.hs | 56 ++-------------------- 1 file changed, 4 insertions(+), 52 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index a3b0a40f7e..dc5749e6e8 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -712,7 +712,6 @@ toShelleyTxOut sbe = \case -- jky simplify L.mkBasicTxOut (toShelleyAddr addr) value ShelleyBasedEraAlonzo -> L.mkBasicTxOut (toShelleyAddr addr) value - & L.dataHashTxOutL .~ toAlonzoTxOutDataHash txoutdata ShelleyBasedEraBabbage -> L.mkBasicTxOut (toShelleyAddr addr) value & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata @@ -742,12 +741,7 @@ fromShelleyTxOut sbe ledgerTxOut = shelleyBasedEraConstraints sbe $ do TxOut addressInEra txOutValue TxOutDatumNone ReferenceScriptNone ShelleyBasedEraAlonzo -> - TxOut addressInEra - txOutValue - (fromAlonzoTxOutDataHash AlonzoEraOnwardsAlonzo datahash) - ReferenceScriptNone - where - datahash = ledgerTxOut ^. L.dataHashTxOutL + TxOut addressInEra txOutValue TxOutDatumNone ReferenceScriptNone ShelleyBasedEraBabbage -> TxOut addressInEra @@ -779,25 +773,6 @@ fromShelleyTxOut sbe ledgerTxOut = shelleyBasedEraConstraints sbe $ do datum = ledgerTxOut ^. L.datumTxOutL mRefScript = ledgerTxOut ^. L.referenceScriptTxOutL - --- TODO: If ledger creates an open type family for datums --- we can consolidate this function with the Babbage version -toAlonzoTxOutDataHash - :: TxOutDatum CtxUTxO AlonzoEra - -> StrictMaybe (L.DataHash StandardCrypto) -toAlonzoTxOutDataHash TxOutDatumNone = SNothing -toAlonzoTxOutDataHash (TxOutDatumHash _ (ScriptDataHash dh)) = SJust dh -toAlonzoTxOutDataHash (TxOutDatumInline inlineDatumSupp _sd) = - case inlineDatumSupp :: BabbageEraOnwards AlonzoEra of {} - -fromAlonzoTxOutDataHash :: AlonzoEraOnwards era - -> StrictMaybe (L.DataHash StandardCrypto) - -> TxOutDatum ctx era -fromAlonzoTxOutDataHash _ SNothing = TxOutDatumNone -fromAlonzoTxOutDataHash s (SJust dh) = TxOutDatumHash s (ScriptDataHash dh) - --- TODO: If ledger creates an open type family for datums --- we can consolidate this function with the Alonzo version toBabbageTxOutDatum :: (L.Era (ShelleyLedgerEra era), Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) => TxOutDatum CtxUTxO era -> Babbage.Datum (ShelleyLedgerEra era) @@ -2174,10 +2149,8 @@ fromLedgerTxOuts sbe body scriptdata = ShelleyBasedEraAlonzo -> [ fromAlonzoTxOut AlonzoEraOnwardsAlonzo - txdatums txout - | let txdatums = selectTxDatums scriptdata - , txout <- toList (body ^. L.outputsTxBodyL) ] + | txout <- toList (body ^. L.outputsTxBodyL) ] ShelleyBasedEraBabbage -> [ fromBabbageTxOut @@ -2202,30 +2175,18 @@ fromLedgerTxOuts sbe body scriptdata = fromAlonzoTxOut :: () => AlonzoEraOnwards era - -> Map (L.DataHash StandardCrypto) (L.Data ledgerera) -> L.TxOut (ShelleyLedgerEra era) -> TxOut CtxTx era -fromAlonzoTxOut w txdatums txOut = +fromAlonzoTxOut w txOut = alonzoEraOnwardsConstraints w $ TxOut (fromShelleyAddr shelleyBasedEra (txOut ^. L.addrTxOutL)) (TxOutValueShelleyBased sbe (txOut ^. L.valueTxOutL)) - (fromAlonzoTxOutDatum w txdatums (txOut ^. L.dataHashTxOutL)) + TxOutDatumNone ReferenceScriptNone where sbe = alonzoEraOnwardsToShelleyBasedEra w -fromAlonzoTxOutDatum :: () - => AlonzoEraOnwards era - -> Map (L.DataHash StandardCrypto) (L.Data ledgerera) - -> StrictMaybe (L.DataHash StandardCrypto) - -> TxOutDatum CtxTx era -fromAlonzoTxOutDatum w txdatums = \case - SNothing -> TxOutDatumNone - SJust dh - | Just d <- Map.lookup dh txdatums -> TxOutDatumInTx' w (ScriptDataHash dh) (fromAlonzoData d) - | otherwise -> TxOutDatumHash w (ScriptDataHash dh) - fromBabbageTxOut :: forall era. () => BabbageEraOnwards era -> Map (L.DataHash StandardCrypto) (L.Data (ShelleyLedgerEra era)) @@ -3164,7 +3125,6 @@ toShelleyTxOutAny sbe = \case ShelleyBasedEraAlonzo -> L.mkBasicTxOut (toShelleyAddr addr) value - & L.dataHashTxOutL .~ toAlonzoTxOutDataHash' txoutdata ShelleyBasedEraBabbage -> L.mkBasicTxOut (toShelleyAddr addr) value @@ -3178,14 +3138,6 @@ toShelleyTxOutAny sbe = \case where cEra = shelleyBasedToCardanoEra sbe -toAlonzoTxOutDataHash' :: TxOutDatum ctx AlonzoEra - -> StrictMaybe (L.DataHash StandardCrypto) -toAlonzoTxOutDataHash' TxOutDatumNone = SNothing -toAlonzoTxOutDataHash' (TxOutDatumHash _ (ScriptDataHash dh)) = SJust dh -toAlonzoTxOutDataHash' (TxOutDatumInTx' _ (ScriptDataHash dh) _) = SJust dh -toAlonzoTxOutDataHash' (TxOutDatumInline inlineDatumSupp _sd) = - case inlineDatumSupp :: BabbageEraOnwards AlonzoEra of {} - -- TODO: Consolidate with alonzo function and rename toBabbageTxOutDatum' :: (L.Era (ShelleyLedgerEra era), Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) From 0008725529cb601d4acd58f9a3d05658e9aaa6e2 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 9 Nov 2023 02:18:54 +1100 Subject: [PATCH 10/11] Simplify TxOut construction --- cardano-api/internal/Cardano/Api/TxBody.hs | 47 +++++----------------- 1 file changed, 11 insertions(+), 36 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index dc5749e6e8..e69ea2322a 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -703,24 +703,14 @@ toShelleyTxOut sbe = \case -- jky simplify TxOut addr (TxOutValueShelleyBased _ value) txoutdata refScript -> let cEra = shelleyBasedToCardanoEra sbe in - case sbe of - ShelleyBasedEraShelley -> - L.mkBasicTxOut (toShelleyAddr addr) value - ShelleyBasedEraAllegra -> - L.mkBasicTxOut (toShelleyAddr addr) value - ShelleyBasedEraMary -> - L.mkBasicTxOut (toShelleyAddr addr) value - ShelleyBasedEraAlonzo -> - L.mkBasicTxOut (toShelleyAddr addr) value - ShelleyBasedEraBabbage -> - L.mkBasicTxOut (toShelleyAddr addr) value - & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata - & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript - ShelleyBasedEraConway -> + caseShelleyToAlonzoOrBabbageEraOnwards + (const $ L.mkBasicTxOut (toShelleyAddr addr) value) + (const $ L.mkBasicTxOut (toShelleyAddr addr) value & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript - + ) + sbe fromShelleyTxOut :: forall era ctx. () => ShelleyBasedEra era @@ -3113,30 +3103,15 @@ toShelleyTxOutAny sbe = \case case sbe of {} TxOut addr (TxOutValueShelleyBased _ value) txoutdata refScript -> - case sbe of - ShelleyBasedEraShelley -> - L.mkBasicTxOut (toShelleyAddr addr) value - - ShelleyBasedEraAllegra -> - L.mkBasicTxOut (toShelleyAddr addr) value - - ShelleyBasedEraMary -> - L.mkBasicTxOut (toShelleyAddr addr) value - - ShelleyBasedEraAlonzo -> - L.mkBasicTxOut (toShelleyAddr addr) value - - ShelleyBasedEraBabbage -> - L.mkBasicTxOut (toShelleyAddr addr) value - & L.datumTxOutL .~ toBabbageTxOutDatum' txoutdata - & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript - - ShelleyBasedEraConway -> + let cEra = shelleyBasedToCardanoEra sbe in + caseShelleyToAlonzoOrBabbageEraOnwards + (const $ L.mkBasicTxOut (toShelleyAddr addr) value) + (const $ L.mkBasicTxOut (toShelleyAddr addr) value & L.datumTxOutL .~ toBabbageTxOutDatum' txoutdata & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript - where - cEra = shelleyBasedToCardanoEra sbe + ) + sbe -- TODO: Consolidate with alonzo function and rename toBabbageTxOutDatum' From 9774286dff6296b6f2808a51d6fa26641be8bb31 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 9 Nov 2023 17:53:24 +1100 Subject: [PATCH 11/11] Rename binding names to be more accurate --- cardano-api/internal/Cardano/Api/Fees.hs | 30 +++++++++--------------- 1 file changed, 11 insertions(+), 19 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index cc2edd6913..26fa68e9e2 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -809,36 +809,28 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame -- of less than around 18 trillion ada (2^64-1 lovelace). -- However, since at this point we know how much non-Ada change to give -- we can use the true values for that. + let maxLovelaceChange = Lovelace (2^(64 :: Integer)) - 1 + let maxLovelaceFee = Lovelace (2^(32 :: Integer) - 1) - let outgoingNonAda = mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- txOuts txbodycontent] - let incomingNonAda = mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- Map.elems $ unUTxO utxo] - let mintedNonAda = case txMintValue txbodycontent1 of + let outgoing = mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- txOuts txbodycontent] + let incoming = mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- Map.elems $ unUTxO utxo] + let minted = case txMintValue txbodycontent1 of TxMintNone -> mempty TxMintValue w v _ -> toLedgerValue w v - let nonAdaChange = mconcat - [ incomingNonAda - , mintedNonAda - , negateLedgerValue sbe outgoingNonAda - ] - - let maxLovelace = Lovelace (2^(64 :: Integer)) - 1 + let change = mconcat [incoming, minted, negateLedgerValue sbe outgoing] + let changeWithMaxLovelace = change & A.adaAssetL sbe .~ lovelaceToCoin maxLovelaceChange let changeTxOut = forShelleyBasedEraInEon sbe - (lovelaceToTxOutValue era maxLovelace) - (\w -> maryEraOnwardsConstraints w - $ TxOutValueShelleyBased sbe (nonAdaChange & A.adaAssetL sbe .~ lovelaceToCoin maxLovelace) - ) + (lovelaceToTxOutValue era maxLovelaceChange) + (\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace) let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr txbody1 <- first TxBodyError $ -- TODO: impossible to fail now createAndValidateTransactionBody era txbodycontent1 { - txFee = TxFeeExplicit sbe $ Lovelace (2^(32 :: Integer) - 1), - txOuts = TxOut changeaddr - changeTxOut - TxOutDatumNone ReferenceScriptNone + txFee = TxFeeExplicit sbe maxLovelaceFee, + txOuts = TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone : txOuts txbodycontent, txReturnCollateral = dummyCollRet, txTotalCollateral = dummyTotColl - } let nkeys = fromMaybe (estimateTransactionKeyWitnessCount txbodycontent1)