diff --git a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs index d33f04103..786a81b9e 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs @@ -17,8 +17,6 @@ where import Cardano.Api.Address import Cardano.Api.Certificate import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eon.ShelleyToAlonzoEra -import Cardano.Api.Eras import Cardano.Api.Experimental.Eras import Cardano.Api.Experimental.Tx import Cardano.Api.Fees @@ -96,10 +94,7 @@ constructBalancedTx let alternateKeyWits = map (makeKeyWitness availableEra unsignedTx) shelleyWitSigningKeys signedTx = signTx availableEra [] alternateKeyWits unsignedTx - caseShelleyToAlonzoOrBabbageEraOnwards - (Left . TxBodyErrorDeprecatedEra . DeprecatedEra . shelleyToAlonzoEraToShelleyBasedEra) - (\w -> return $ ShelleyTx sbe $ obtainShimConstraints w signedTx) - sbe + return $ ShelleyTx sbe $ obtainCommonConstraints availableEra signedTx data TxInsExistError = TxInsDoNotExist [TxIn] diff --git a/cardano-api/internal/Cardano/Api/Experimental/Eras.hs b/cardano-api/internal/Cardano/Api/Experimental/Eras.hs index 893e96c99..90279ee8a 100644 --- a/cardano-api/internal/Cardano/Api/Experimental/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Experimental/Eras.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,27 +17,23 @@ module Cardano.Api.Experimental.Eras ( BabbageEra , ConwayEra , Era (..) + , IsEra (..) + , Some (..) , LedgerEra - , IsEra - , ApiEraToLedgerEra - , ExperimentalEraToApiEra - , ApiEraToExperimentalEra , DeprecatedEra (..) , EraCommonConstraints - , EraShimConstraints , obtainCommonConstraints - , obtainShimConstraints - , useEra , eraToSbe , babbageEraOnwardsToEra + , eraToBabbageEraOnwards , sbeToEra ) where import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra) -import Cardano.Api.Eras.Core (BabbageEra, ConwayEra) -import qualified Cardano.Api.Eras.Core as Api +import qualified Cardano.Api.Eras as Api +import Cardano.Api.Eras.Core (BabbageEra, ConwayEra, Eon (..)) import qualified Cardano.Api.ReexposeLedger as L import Cardano.Api.Via.ShowOf @@ -49,30 +46,46 @@ import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.UTxO as L import Control.Monad.Error.Class +import Data.Aeson (FromJSON (..), ToJSON, withText) +import Data.Aeson.Types (ToJSON (..)) import Data.Kind +import Data.Maybe (isJust) +import qualified Data.Text as Text +import Data.Type.Equality +import Data.Typeable +import GHC.Exts (IsString) import Prettyprinter -- | Users typically interact with the latest features on the mainnet or experiment with features -- from the upcoming era. Hence, the protocol versions are limited to the current mainnet era -- and the next era (upcoming era). - --- Allows us to gradually change the api without breaking things. --- This will eventually be removed. -type family ExperimentalEraToApiEra era = (r :: Type) | r -> era where - ExperimentalEraToApiEra BabbageEra = Api.BabbageEra - ExperimentalEraToApiEra ConwayEra = Api.ConwayEra - -type family ApiEraToExperimentalEra era = (r :: Type) | r -> era where - ApiEraToExperimentalEra Api.BabbageEra = BabbageEra - ApiEraToExperimentalEra Api.ConwayEra = ConwayEra - type family LedgerEra era = (r :: Type) | r -> era where LedgerEra BabbageEra = Ledger.Babbage LedgerEra ConwayEra = Ledger.Conway -type family ApiEraToLedgerEra era = (r :: Type) | r -> era where - ApiEraToLedgerEra Api.BabbageEra = Ledger.Babbage - ApiEraToLedgerEra Api.ConwayEra = Ledger.Conway +-- | An existential type for singleton types. Use to hold any era e.g. @Some Era@. One can then bring the +-- era witness back into scope for example using this pattern: +-- @ +-- anyEra = Some ConwayEra +-- -- then later in the code +-- Some era <- pure anyEra +-- obtainCommonConstraints era foo +-- @ +data Some (f :: Type -> Type) where + Some + :: forall f a + . (Typeable a, Typeable (f a)) + => f a + -> Some f + +-- | Assumes that @f@ is a singleton +instance Show (Some f) where + showsPrec _ (Some v) = showsTypeRep (typeOf v) + +-- | Assumes that @f@ is a singleton +instance TestEquality f => Eq (Some f) where + Some era1 == Some era2 = + isJust $ testEquality era1 era2 -- | Represents the eras in Cardano's blockchain. -- This type represents eras currently on mainnet and new eras which are @@ -89,6 +102,62 @@ data Era era where deriving instance Show (Era era) +deriving instance Eq (Era era) + +instance Pretty (Era era) where + pretty = eraToStringLike + +instance TestEquality Era where + testEquality BabbageEra BabbageEra = Just Refl + testEquality BabbageEra _ = Nothing + testEquality ConwayEra ConwayEra = Just Refl + testEquality ConwayEra _ = Nothing + +instance ToJSON (Era era) where + toJSON = eraToStringLike + +instance Bounded (Some Era) where + minBound = Some BabbageEra + maxBound = Some ConwayEra + +instance Enum (Some Era) where + toEnum 0 = Some BabbageEra + toEnum 1 = Some ConwayEra + toEnum i = error $ "Enum.toEnum: invalid argument " <> show i <> " - does not correspond to any era" + fromEnum (Some BabbageEra) = 0 + fromEnum (Some ConwayEra) = 1 + +instance Ord (Some Era) where + compare e1 e2 = compare (fromEnum e1) (fromEnum e2) + +instance Pretty (Some Era) where + pretty (Some era) = pretty era + +instance ToJSON (Some Era) where + toJSON (Some era) = toJSON era + +instance FromJSON (Some Era) where + parseJSON = + withText "Some Era" $ + ( \case + Right era -> pure era + Left era -> fail $ "Failed to parse unknown era: " <> Text.unpack era + ) + . eraFromStringLike + +eraToStringLike :: IsString a => Era era -> a +{-# INLINE eraToStringLike #-} +eraToStringLike = \case + BabbageEra -> "Babbage" + ConwayEra -> "Conway" + +eraFromStringLike :: (IsString a, Eq a) => a -> Either a (Some Era) +{-# INLINE eraFromStringLike #-} +eraFromStringLike = \case + "Babbage" -> pure $ Some BabbageEra + "Conway" -> pure $ Some ConwayEra + wrong -> Left wrong + -- | How to deprecate an era -- -- 1. Add DEPRECATED pragma to the era type tag and the era constructor at the same time: @@ -117,7 +186,7 @@ deriving instance Show (Era era) -- @ eraToSbe :: Era era - -> ShelleyBasedEra (ExperimentalEraToApiEra era) + -> ShelleyBasedEra era eraToSbe BabbageEra = ShelleyBasedEraBabbage eraToSbe ConwayEra = ShelleyBasedEraConway @@ -128,7 +197,9 @@ newtype DeprecatedEra era deriving via (ShowOf (DeprecatedEra era)) instance Pretty (DeprecatedEra era) sbeToEra - :: MonadError (DeprecatedEra era) m => ShelleyBasedEra era -> m (Era (ApiEraToExperimentalEra era)) + :: MonadError (DeprecatedEra era) m + => ShelleyBasedEra era + -> m (Era era) sbeToEra ShelleyBasedEraConway = return ConwayEra sbeToEra ShelleyBasedEraBabbage = return BabbageEra sbeToEra e@ShelleyBasedEraAlonzo = throwError $ DeprecatedEra e @@ -136,10 +207,14 @@ sbeToEra e@ShelleyBasedEraMary = throwError $ DeprecatedEra e sbeToEra e@ShelleyBasedEraAllegra = throwError $ DeprecatedEra e sbeToEra e@ShelleyBasedEraShelley = throwError $ DeprecatedEra e -babbageEraOnwardsToEra :: BabbageEraOnwards era -> Era (ApiEraToExperimentalEra era) +babbageEraOnwardsToEra :: BabbageEraOnwards era -> Era era babbageEraOnwardsToEra BabbageEraOnwardsBabbage = BabbageEra babbageEraOnwardsToEra BabbageEraOnwardsConway = ConwayEra +eraToBabbageEraOnwards :: Era era -> BabbageEraOnwards era +eraToBabbageEraOnwards BabbageEra = BabbageEraOnwardsBabbage +eraToBabbageEraOnwards ConwayEra = BabbageEraOnwardsConway + ------------------------------------------------------------------------- -- | Type class interface for the 'Era' type. @@ -152,20 +227,12 @@ instance IsEra BabbageEra where instance IsEra ConwayEra where useEra = ConwayEra -obtainShimConstraints - :: BabbageEraOnwards era - -> (EraShimConstraints era => a) - -> a -obtainShimConstraints BabbageEraOnwardsBabbage x = x -obtainShimConstraints BabbageEraOnwardsConway x = x - --- We need these constraints in order to propagate the new --- experimental api without changing the existing api -type EraShimConstraints era = - ( LedgerEra (ApiEraToExperimentalEra era) ~ ShelleyLedgerEra era - , ExperimentalEraToApiEra (ApiEraToExperimentalEra era) ~ era - , L.EraTx (ApiEraToLedgerEra era) - ) +-- | A temporary compatibility instance, for easier conversion between experimental and old API. +instance Eon Era where + inEonForEra v f = \case + Api.ConwayEra -> f ConwayEra + Api.BabbageEra -> f BabbageEra + _ -> v obtainCommonConstraints :: Era era @@ -180,6 +247,7 @@ type EraCommonConstraints era = , L.EraTx (LedgerEra era) , L.EraUTxO (LedgerEra era) , Ledger.EraCrypto (LedgerEra era) ~ L.StandardCrypto - , ShelleyLedgerEra (ExperimentalEraToApiEra era) ~ LedgerEra era + , ShelleyLedgerEra era ~ LedgerEra era , L.HashAnnotated (Ledger.TxBody (LedgerEra era)) EraIndependentTxBody L.StandardCrypto + , IsEra era ) diff --git a/cardano-api/internal/Cardano/Api/Experimental/Tx.hs b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs index 76566c0df..7356cb204 100644 --- a/cardano-api/internal/Cardano/Api/Experimental/Tx.hs +++ b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs @@ -21,9 +21,10 @@ module Cardano.Api.Experimental.Tx where import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Case +import Cardano.Api.Eras.Core (ToCardanoEra (toCardanoEra), forEraInEon) import Cardano.Api.Experimental.Eras import Cardano.Api.Feature +import Cardano.Api.Pretty (docToString, pretty) import Cardano.Api.ReexposeLedger (StrictMaybe (..), maybeToStrictMaybe) import qualified Cardano.Api.ReexposeLedger as L import Cardano.Api.Tx.Body @@ -41,6 +42,7 @@ import qualified Cardano.Ledger.SafeHash as L import qualified Data.Set as Set import GHC.Exts (IsList (..)) +import GHC.Stack import Lens.Micro -- | A transaction that can contain everything @@ -58,7 +60,7 @@ newtype UnsignedTxError makeUnsignedTx :: Era era - -> TxBodyContent BuildTx (ExperimentalEraToApiEra era) + -> TxBodyContent BuildTx era -> Either TxBodyError (UnsignedTx era) makeUnsignedTx era bc = obtainCommonConstraints era $ do let sbe = eraToSbe era @@ -133,7 +135,7 @@ makeUnsignedTx era bc = obtainCommonConstraints era $ do eraSpecificLedgerTxBody :: Era era -> Ledger.TxBody (LedgerEra era) - -> TxBodyContent BuildTx (ExperimentalEraToApiEra era) + -> TxBodyContent BuildTx era -> Either TxBodyError (Ledger.TxBody (LedgerEra era)) eraSpecificLedgerTxBody BabbageEra ledgerbody bc = do let sbe = eraToSbe BabbageEra @@ -154,7 +156,7 @@ eraSpecificLedgerTxBody ConwayEra ledgerbody bc = .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures) & L.treasuryDonationTxBodyL .~ maybe (L.Coin 0) unFeatured treasuryDonation & L.currentTreasuryValueTxBodyL - .~ L.maybeToStrictMaybe (maybe (Just $ L.Coin 0) unFeatured currentTresuryValue) + .~ L.maybeToStrictMaybe (unFeatured =<< currentTresuryValue) hashTxBody :: L.HashAnnotated (Ledger.TxBody era) EraIndependentTxBody L.StandardCrypto @@ -198,12 +200,12 @@ signTx era bootstrapWits shelleyKeyWits (UnsignedTx unsigned) = -- Compatibility related. Will be removed once the old api has been deprecated and deleted. convertTxBodyToUnsignedTx - :: ShelleyBasedEra era -> TxBody era -> UnsignedTx (ApiEraToExperimentalEra era) + :: HasCallStack => ShelleyBasedEra era -> TxBody era -> UnsignedTx era convertTxBodyToUnsignedTx sbe txbody = - caseShelleyToAlonzoOrBabbageEraOnwards - (const $ error "convertTxBodyToUnsignedTx: Error") - ( \w -> + forEraInEon + (toCardanoEra sbe) + (error $ "convertTxBodyToUnsignedTx: Error - unsupported era " <> docToString (pretty sbe)) + ( \w -> do let ShelleyTx _ unsignedLedgerTx = makeSignedTransaction [] txbody - in UnsignedTx $ obtainShimConstraints w unsignedLedgerTx + UnsignedTx $ obtainCommonConstraints w unsignedLedgerTx ) - sbe diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 2740f9f68..7f736b6f5 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -54,11 +54,10 @@ import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ConwayEraOnwards import Cardano.Api.Eon.MaryEraOnwards import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eon.ShelleyToAlonzoEra import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core import Cardano.Api.Error -import Cardano.Api.Experimental.Eras (obtainShimConstraints, sbeToEra) +import Cardano.Api.Experimental.Eras (obtainCommonConstraints, sbeToEra) import qualified Cardano.Api.Experimental.Eras as Exp import Cardano.Api.Experimental.Tx import Cardano.Api.Feature @@ -948,7 +947,7 @@ handleExUnitsErrors ScriptInvalid failuresMap exUnitsMap data BalancedTxBody era where BalancedTxBody :: (TxBodyContent BuildTx era) - -> (UnsignedTx (Exp.ApiEraToExperimentalEra era)) + -> (UnsignedTx era) -> (TxOut CtxTx era) -- ^ Transaction balance (change output) -> L.Coin @@ -956,7 +955,7 @@ data BalancedTxBody era where -> BalancedTxBody era deriving instance - (Exp.IsEra (Exp.ApiEraToExperimentalEra era), IsShelleyBasedEra era) => Show (BalancedTxBody era) + (Exp.IsEra era, IsShelleyBasedEra era) => Show (BalancedTxBody era) newtype RequiredShelleyKeyWitnesses = RequiredShelleyKeyWitnesses {unRequiredShelleyKeyWitnesses :: Int} @@ -1051,184 +1050,179 @@ makeTransactionBodyAutoBalance txbodycontent changeaddr mnkeys = - caseShelleyToAlonzoOrBabbageEraOnwards - (Left . TxBodyErrorDeprecatedEra . Exp.DeprecatedEra . shelleyToAlonzoEraToShelleyBasedEra) - ( \bEraOnwards -> - shelleyBasedEraConstraints sbe $ do - availableEra <- first TxBodyErrorDeprecatedEra $ sbeToEra sbe - - -- 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 - -- 3. update tx with fees - -- 4. balance the transaction and update tx change output - - let totalValueAtSpendableUTxO = fromLedgerValue sbe . calculateIncomingUTxOValue . Map.elems $ unUTxO utxo - change = - monoidForEraInEon (toCardanoEra sbe) $ \w -> - toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent - - UnsignedTx unsignedTx0 <- - first TxBodyError - $ makeUnsignedTx - availableEra - $ obtainShimConstraints bEraOnwards - $ txbodycontent - { txOuts = - txOuts txbodycontent - <> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone] - } - exUnitsMapWithLogs <- - first TxBodyErrorValidityInterval - $ evaluateTransactionExecutionUnitsShelley - sbe - systemstart - history - lpp - utxo - $ obtainShimConstraints bEraOnwards unsignedTx0 - - let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs - - exUnitsMap' <- - case Map.mapEither id exUnitsMap of - (failures, exUnitsMap') -> - handleExUnitsErrors - (txScriptValidityToScriptValidity (txScriptValidity txbodycontent)) - failures - exUnitsMap' - - txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent - - -- Make a txbody that we will use for calculating the fees. For the purpose - -- of fees we just need to make a txbody of the right size in bytes. We do - -- not need the right values for the fee or change output. We use - -- "big enough" values for the change output and set so that the CBOR - -- encoding size of the tx will be big enough to cover the size of the final - -- output and fee. Yes this means this current code will only work for - -- final fee of less than around 4000 ada (2^32-1 lovelace) and change output - -- 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 = L.Coin (2 ^ (64 :: Integer)) - 1 - let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1) - - let changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange - let changeTxOut = - forShelleyBasedEraInEon - sbe - (lovelaceToTxOutValue sbe maxLovelaceChange) - (\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace) - - let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput sbe txbodycontent changeaddr - UnsignedTx txbody1 <- - first TxBodyError - $ makeUnsignedTx -- TODO: impossible to fail now - availableEra - $ obtainShimConstraints bEraOnwards - $ txbodycontent1 - { txFee = TxFeeExplicit sbe maxLovelaceFee - , txOuts = - txOuts txbodycontent - <> [TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone] - , txReturnCollateral = dummyCollRet - , txTotalCollateral = dummyTotColl - } - -- NB: This has the potential to over estimate the fees because estimateTransactionKeyWitnessCount - -- makes the conservative assumption that all inputs are from distinct - -- addresses. - let nkeys = - fromMaybe - (estimateTransactionKeyWitnessCount txbodycontent1) - mnkeys - fee = - obtainShimConstraints bEraOnwards $ - L.calcMinFeeTx (toLedgerUTxO sbe utxo) pp txbody1 (fromIntegral nkeys) - (retColl, reqCol) = - caseShelleyToAlonzoOrBabbageEraOnwards - (const (TxReturnCollateralNone, TxTotalCollateralNone)) - ( \w -> - let collIns = case txInsCollateral txbodycontent of - TxInsCollateral _ collIns' -> collIns' - TxInsCollateralNone -> mempty - collateralOuts = catMaybes [Map.lookup txin (unUTxO utxo) | txin <- collIns] - totalPotentialCollateral = mconcat $ map (\(TxOut _ txOutVal _ _) -> txOutValueToLovelace txOutVal) collateralOuts - in calcReturnAndTotalCollateral - w - fee - pp - (txInsCollateral txbodycontent) - (txReturnCollateral txbodycontent) - (txTotalCollateral txbodycontent) - changeaddr - totalPotentialCollateral - ) - sbe - - -- Make a txbody for calculating the balance. For this the size of the tx - -- does not matter, instead it's just the values of the fee and outputs. - -- Here we do not want to start with any change output, since that's what - -- we need to calculate. - UnsignedTx txbody2 <- - first TxBodyError - $ makeUnsignedTx -- TODO: impossible to fail now - availableEra - $ obtainShimConstraints bEraOnwards - $ txbodycontent1 - { txFee = TxFeeExplicit sbe fee - , txReturnCollateral = retColl - , txTotalCollateral = reqCol - } - let balance = - TxOutValueShelleyBased sbe $ - obtainShimConstraints bEraOnwards $ - L.evalBalanceTxBody + shelleyBasedEraConstraints sbe $ do + availableEra <- first TxBodyErrorDeprecatedEra $ sbeToEra sbe + + -- 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 + -- 3. update tx with fees + -- 4. balance the transaction and update tx change output + + let totalValueAtSpendableUTxO = fromLedgerValue sbe . calculateIncomingUTxOValue . Map.elems $ unUTxO utxo + change = + monoidForEraInEon (toCardanoEra sbe) $ \w -> + toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent + + UnsignedTx unsignedTx0 <- + first TxBodyError + $ makeUnsignedTx + availableEra + $ obtainCommonConstraints availableEra + $ txbodycontent + { txOuts = + txOuts txbodycontent + <> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone] + } + exUnitsMapWithLogs <- + first TxBodyErrorValidityInterval + $ evaluateTransactionExecutionUnitsShelley + sbe + systemstart + history + lpp + utxo + $ obtainCommonConstraints availableEra unsignedTx0 + + let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs + + exUnitsMap' <- + case Map.mapEither id exUnitsMap of + (failures, exUnitsMap') -> + handleExUnitsErrors + (txScriptValidityToScriptValidity (txScriptValidity txbodycontent)) + failures + exUnitsMap' + + txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent + + -- Make a txbody that we will use for calculating the fees. For the purpose + -- of fees we just need to make a txbody of the right size in bytes. We do + -- not need the right values for the fee or change output. We use + -- "big enough" values for the change output and set so that the CBOR + -- encoding size of the tx will be big enough to cover the size of the final + -- output and fee. Yes this means this current code will only work for + -- final fee of less than around 4000 ada (2^32-1 lovelace) and change output + -- 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 = L.Coin (2 ^ (64 :: Integer)) - 1 + let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1) + + let changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange + let changeTxOut = + forShelleyBasedEraInEon + sbe + (lovelaceToTxOutValue sbe maxLovelaceChange) + (\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace) + + let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput sbe txbodycontent changeaddr + UnsignedTx txbody1 <- + first TxBodyError + $ makeUnsignedTx -- TODO: impossible to fail now + availableEra + $ obtainCommonConstraints availableEra + $ txbodycontent1 + { txFee = TxFeeExplicit sbe maxLovelaceFee + , txOuts = + txOuts txbodycontent + <> [TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone] + , txReturnCollateral = dummyCollRet + , txTotalCollateral = dummyTotColl + } + -- NB: This has the potential to over estimate the fees because estimateTransactionKeyWitnessCount + -- makes the conservative assumption that all inputs are from distinct + -- addresses. + let nkeys = + fromMaybe + (estimateTransactionKeyWitnessCount txbodycontent1) + mnkeys + fee = + obtainCommonConstraints availableEra $ + L.calcMinFeeTx (toLedgerUTxO sbe utxo) pp txbody1 (fromIntegral nkeys) + (retColl, reqCol) = + caseShelleyToAlonzoOrBabbageEraOnwards + (const (TxReturnCollateralNone, TxTotalCollateralNone)) + ( \w -> + let collIns = case txInsCollateral txbodycontent of + TxInsCollateral _ collIns' -> collIns' + TxInsCollateralNone -> mempty + collateralOuts = catMaybes [Map.lookup txin (unUTxO utxo) | txin <- collIns] + totalPotentialCollateral = mconcat $ map (\(TxOut _ txOutVal _ _) -> txOutValueToLovelace txOutVal) collateralOuts + in calcReturnAndTotalCollateral + w + fee pp - (lookupDelegDeposit stakeDelegDeposits) - (lookupDRepDeposit drepDelegDeposits) - (isRegPool poolids) - (toLedgerUTxO sbe utxo) - (txbody2 ^. L.bodyTxL) - - forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue sbe txout pp - - -- check if the balance is positive or negative - -- in one case we can produce change, in the other the inputs are insufficient - balanceCheck sbe pp changeaddr balance - - -- TODO: we could add the extra fee for the CBOR encoding of the change, - -- now that we know the magnitude of the change: i.e. 1-8 bytes extra. - - -- The txbody with the final fee and change output. This should work - -- provided that the fee and change are less than 2^32-1, and so will - -- fit within the encoding size we picked above when calculating the fee. - -- Yes this could be an over-estimate by a few bytes if the fee or change - -- would fit within 2^16-1. That's a possible optimisation. - let finalTxBodyContent = - txbodycontent1 - { txFee = TxFeeExplicit sbe fee - , txOuts = - accountForNoChange - (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) - (txOuts txbodycontent) - , txReturnCollateral = retColl - , txTotalCollateral = reqCol - } - txbody3 <- - first TxBodyError $ -- TODO: impossible to fail now. We need to implement a function - -- that simply creates a transaction body because we have already - -- validated the transaction body earlier within makeTransactionBodyAutoBalance - makeUnsignedTx availableEra $ - obtainShimConstraints bEraOnwards finalTxBodyContent - return - ( BalancedTxBody - finalTxBodyContent - txbody3 - (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) - fee + (txInsCollateral txbodycontent) + (txReturnCollateral txbodycontent) + (txTotalCollateral txbodycontent) + changeaddr + totalPotentialCollateral ) - ) - sbe + sbe + + -- Make a txbody for calculating the balance. For this the size of the tx + -- does not matter, instead it's just the values of the fee and outputs. + -- Here we do not want to start with any change output, since that's what + -- we need to calculate. + UnsignedTx txbody2 <- + first TxBodyError + $ makeUnsignedTx -- TODO: impossible to fail now + availableEra + $ obtainCommonConstraints availableEra + $ txbodycontent1 + { txFee = TxFeeExplicit sbe fee + , txReturnCollateral = retColl + , txTotalCollateral = reqCol + } + let balance = + TxOutValueShelleyBased sbe $ + obtainCommonConstraints availableEra $ + L.evalBalanceTxBody + pp + (lookupDelegDeposit stakeDelegDeposits) + (lookupDRepDeposit drepDelegDeposits) + (isRegPool poolids) + (toLedgerUTxO sbe utxo) + (txbody2 ^. L.bodyTxL) + + forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue sbe txout pp + + -- check if the balance is positive or negative + -- in one case we can produce change, in the other the inputs are insufficient + balanceCheck sbe pp changeaddr balance + + -- TODO: we could add the extra fee for the CBOR encoding of the change, + -- now that we know the magnitude of the change: i.e. 1-8 bytes extra. + + -- The txbody with the final fee and change output. This should work + -- provided that the fee and change are less than 2^32-1, and so will + -- fit within the encoding size we picked above when calculating the fee. + -- Yes this could be an over-estimate by a few bytes if the fee or change + -- would fit within 2^16-1. That's a possible optimisation. + let finalTxBodyContent = + txbodycontent1 + { txFee = TxFeeExplicit sbe fee + , txOuts = + accountForNoChange + (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) + (txOuts txbodycontent) + , txReturnCollateral = retColl + , txTotalCollateral = reqCol + } + txbody3 <- + first TxBodyError $ -- TODO: impossible to fail now. We need to implement a function + -- that simply creates a transaction body because we have already + -- validated the transaction body earlier within makeTransactionBodyAutoBalance + makeUnsignedTx availableEra $ + obtainCommonConstraints availableEra finalTxBodyContent + return + ( BalancedTxBody + finalTxBodyContent + txbody3 + (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) + fee + ) -- | In the event of spending the exact amount of lovelace in -- the specified input(s), this function excludes the change diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index 3a4716fe5..79984396e 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -9,8 +9,6 @@ module Cardano.Api.Experimental , signTx , convertTxBodyToUnsignedTx , EraCommonConstraints - , EraShimConstraints - , obtainShimConstraints , obtainCommonConstraints , hashTxBody , evaluateTransactionExecutionUnitsShelley @@ -18,15 +16,13 @@ module Cardano.Api.Experimental , BabbageEra , ConwayEra , Era (..) + , IsEra (..) + , Some (..) , LedgerEra - , IsEra - , ApiEraToLedgerEra - , ExperimentalEraToApiEra - , ApiEraToExperimentalEra , DeprecatedEra (..) - , useEra , eraToSbe , babbageEraOnwardsToEra + , eraToBabbageEraOnwards , sbeToEra ) where diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs index 320496519..58e91572b 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs @@ -239,7 +239,7 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr address Nothing -- the correct amount with manual balancing of assets - 335_729 === feeWithTxoutAsset + 335_475 === feeWithTxoutAsset -- autobalanced body has assets and ADA in the change txout (BalancedTxBody balancedContent _ _ fee) <-