From 2e362978650048bbadce3dad1ef0ef86ff2c4805 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 25 Oct 2024 11:51:52 +0200 Subject: [PATCH] Refactor `TxMintValue` to better represent minting state --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 42 +++++++-- cardano-api/internal/Cardano/Api/Fees.hs | 42 +++------ cardano-api/internal/Cardano/Api/Script.hs | 28 ++++-- cardano-api/internal/Cardano/Api/Tx/Body.hs | 94 ++++++++++++------- cardano-api/internal/Cardano/Api/Value.hs | 3 +- cardano-api/src/Cardano/Api.hs | 3 + .../Cardano/Api/Transaction/Autobalance.hs | 6 +- 7 files changed, 134 insertions(+), 84 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 4a1f5caaa1..815f42d9cc 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -662,11 +662,18 @@ genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era) genTxMintValue = inEonForEra (pure TxMintNone) - $ \supported -> + $ \w -> do + policies <- Gen.list (Range.constant 1 3) genPolicyId + assets <- forM policies $ \policy -> + (,) policy <$> + Gen.list + (Range.constant 1 3) + ((,,) <$> genAssetName + <*> genPositiveQuantity + <*> fmap (fmap pure) genScriptWitnessForMint (maryEraOnwardsToShelleyBasedEra w)) Gen.choice [ pure TxMintNone - -- TODO write a generator for the last parameter of 'TxMintValue' constructor - , TxMintValue supported <$> genValueForMinting <*> return (pure mempty) + , pure $ TxMintValue w (fromList assets) ] genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era) @@ -1196,13 +1203,13 @@ genScriptWitnessForStake sbe = do SimpleScript simpleScript -> do simpleScriptOrReferenceInput <- Gen.choice [ pure $ SScript simpleScript - , SReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash + , SReferenceScript <$> genTxIn ] pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput PlutusScript plutusScriptVersion' plutusScript -> do plutusScriptOrReferenceInput <- Gen.choice [ pure $ PScript plutusScript - , PReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash + , PReferenceScript <$> genTxIn ] scriptRedeemer <- genHashableScriptData PlutusScriptWitness @@ -1213,6 +1220,27 @@ genScriptWitnessForStake sbe = do scriptRedeemer <$> genExecutionUnits - - +genScriptWitnessForMint :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxMint era) +genScriptWitnessForMint sbe = do + ScriptInEra scriptLangInEra script' <- genScriptInEra sbe + case script' of + SimpleScript simpleScript -> do + simpleScriptOrReferenceInput <- Gen.choice + [ pure $ SScript simpleScript + , SReferenceScript <$> genTxIn + ] + pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput + PlutusScript plutusScriptVersion' plutusScript -> do + plutusScriptOrReferenceInput <- Gen.choice + [ pure $ PScript plutusScript + , PReferenceScript <$> genTxIn + ] + scriptRedeemer <- genHashableScriptData + PlutusScriptWitness + scriptLangInEra + plutusScriptVersion' + plutusScriptOrReferenceInput + NoScriptDatumForMint + scriptRedeemer + <$> genExecutionUnits diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 25ecf80f79..da3cc02e31 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} -- | Fee calculation module Cardano.Api.Fees @@ -1325,10 +1326,8 @@ calculateChangeValue :: ShelleyBasedEra era -> Value -> TxBodyContent build era -> Value calculateChangeValue sbe incoming txbodycontent = let outgoing = calculateCreatedUTOValue sbe txbodycontent - minted = case txMintValue txbodycontent of - TxMintNone -> mempty - TxMintValue _ v _ -> v - in mconcat [incoming, minted, negateValue outgoing] + mintedValue = txMintValueToValue $ txMintValue txbodycontent + in mconcat [incoming, mintedValue, negateValue outgoing] -- | This is used in the balance calculation in the event where -- the user does not supply the UTxO(s) they intend to spend @@ -1598,33 +1597,20 @@ substituteExecutionUnits :: TxMintValue BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxMintValue BuildTx era) mapScriptWitnessesMinting TxMintNone = Right TxMintNone - mapScriptWitnessesMinting - ( TxMintValue - supported - value - (BuildTxWith witnesses) - ) = - -- TxMintValue supported value $ BuildTxWith $ fromList - let mappedScriptWitnesses - :: [(PolicyId, Either (TxBodyErrorAutoBalance era) (ScriptWitness WitCtxMint era))] - mappedScriptWitnesses = - [ (policyid, witness') - | -- The minting policies are indexed in policy id order in the value - let ValueNestedRep bundle = valueToNestedRep value - , (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle - , witness <- maybeToList (Map.lookup policyid witnesses) - , let witness' = substituteExecUnits (ScriptWitnessIndexMint ix) witness - ] - in do - final <- traverseScriptWitnesses mappedScriptWitnesses - Right . TxMintValue supported value . BuildTxWith $ - fromList final + mapScriptWitnessesMinting txMintValue'@(TxMintValue w _) = do + let mappedScriptWitnesses = + [ (policyId, pure . (assetName',quantity,) <$> substitutedWitness) + | (ix, policyId, assetName', quantity, BuildTxWith witness) <- txMintValueToIndexed txMintValue' + , let substitutedWitness = BuildTxWith <$> substituteExecUnits ix witness + ] + final <- Map.fromListWith (<>) <$> traverseScriptWitnesses mappedScriptWitnesses + pure $ TxMintValue w final traverseScriptWitnesses - :: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))] - -> Either (TxBodyErrorAutoBalance era) [(a, ScriptWitness ctx era)] + :: [(a, Either (TxBodyErrorAutoBalance era) b)] + -> Either (TxBodyErrorAutoBalance era) [(a, b)] traverseScriptWitnesses = - traverse (\(item, eScriptWitness) -> eScriptWitness >>= (\sWit -> Right (item, sWit))) + traverse (\(item, eRes) -> eRes >>= (\res -> Right (item, res))) calculateMinimumUTxO :: ShelleyBasedEra era diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index dfe3df1a84..da15aab24f 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -54,6 +54,7 @@ module Cardano.Api.Script , WitCtxMint , WitCtxStake , WitCtx (..) + , WitCtxMaybe (..) , ScriptWitness (..) , Witness (..) , KeyWitnessInCtx (..) @@ -165,7 +166,7 @@ import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) +import Data.Type.Equality (TestEquality (..), type (==), (:~:) (Refl)) import Data.Typeable (Typeable) import Data.Vector (Vector) import GHC.Exts (IsList (..)) @@ -679,6 +680,17 @@ data WitCtx witctx where WitCtxMint :: WitCtx WitCtxMint WitCtxStake :: WitCtx WitCtxStake +-- TODO: not needed anymore - remove + +-- | A typed version of a 'Maybe'. Allows to store value of type @a@ when @purpose ~ witctx@, otherwise it is empty. +data WitCtxMaybe purpose witctx a where + WitCtxJust :: WitCtx purpose -> a -> WitCtxMaybe purpose purpose a + WitCtxNothing :: (purpose == witctx) ~ False => WitCtxMaybe purpose witctx a + +instance Show a => Show (WitCtxMaybe p w a) where + show (WitCtxJust _ a) = "WitCtxJust " <> show a + show WitCtxNothing = "WitCtxNothing" + -- | Scripts can now exist in the UTxO at a transaction output. We can -- reference these scripts via specification of a reference transaction input -- in order to witness spending inputs, withdrawals, certificates @@ -688,20 +700,18 @@ data PlutusScriptOrReferenceInput lang | -- | Needed to construct the redeemer pointer map -- in the case of minting reference scripts where we don't -- have direct access to the script - PReferenceScript - TxIn - (Maybe ScriptHash) + PReferenceScript TxIn deriving (Eq, Show) data SimpleScriptOrReferenceInput lang = SScript SimpleScript - | SReferenceScript TxIn (Maybe ScriptHash) + | SReferenceScript TxIn deriving (Eq, Show) getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn -getScriptWitnessReferenceInput (SimpleScriptWitness _ (SReferenceScript txIn _)) = +getScriptWitnessReferenceInput (SimpleScriptWitness _ (SReferenceScript txIn)) = Just txIn -getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn _) _ _ _) = +getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _) = Just txIn getScriptWitnessReferenceInput (SimpleScriptWitness _ (SScript _)) = Nothing getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PScript _) _ _ _) = Nothing @@ -804,9 +814,9 @@ scriptWitnessScript (SimpleScriptWitness SimpleScriptInConway (SScript script)) Just $ ScriptInEra SimpleScriptInConway (SimpleScript script) scriptWitnessScript (PlutusScriptWitness langInEra version (PScript script) _ _ _) = Just $ ScriptInEra langInEra (PlutusScript version script) -scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _ _)) = +scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _)) = Nothing -scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _ _) _ _ _) = +scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _) _ _ _) = Nothing -- ---------------------------------------------------------------------------- diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 4189434b60..1ee6d790dd 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -111,6 +111,8 @@ module Cardano.Api.Tx.Body , TxCertificates (..) , TxUpdateProposal (..) , TxMintValue (..) + , txMintValueToValue + , txMintValueToIndexed , TxVotingProcedures (..) , mkTxVotingProcedures , TxProposalProcedures (..) @@ -1248,16 +1250,46 @@ data TxMintValue build era where TxMintNone :: TxMintValue build era TxMintValue :: MaryEraOnwards era - -> Value - -> BuildTxWith - build - (Map PolicyId (ScriptWitness WitCtxMint era)) + -> Map + PolicyId + [ ( AssetName + , Quantity + , BuildTxWith build (ScriptWitness WitCtxMint era) + ) + ] -> TxMintValue build era deriving instance Eq (TxMintValue build era) deriving instance Show (TxMintValue build era) +-- | Convert 'TxMintValue' to a more handy 'Value'. +txMintValueToValue :: TxMintValue build era -> Value +txMintValueToValue TxMintNone = mempty +txMintValueToValue (TxMintValue _ policiesWithAssets) = + fromList + [ (AssetId policyId' assetName', quantity) + | (policyId', assets) <- toList policiesWithAssets + , (assetName', quantity, _) <- assets + ] + +-- | Index the assets with witnesses in the order of policy ids. +txMintValueToIndexed + :: TxMintValue build era + -> [ ( ScriptWitnessIndex + , PolicyId + , AssetName + , Quantity + , BuildTxWith build (ScriptWitness WitCtxMint era) + ) + ] +txMintValueToIndexed TxMintNone = [] +txMintValueToIndexed (TxMintValue _ policiesWithAssets) = + [ (ScriptWitnessIndexMint ix, policyId', assetName', quantity, witness) + | (ix, (policyId', assets)) <- zip [0 ..] $ toList policiesWithAssets + , (assetName', quantity, witness) <- assets + ] + -- ---------------------------------------------------------------------------- -- Votes within transactions (era-dependent) -- @@ -1555,7 +1587,7 @@ data TxBodyError | TxBodyOutputNegative !Quantity !TxOutInAnyEra | TxBodyOutputOverflow !Quantity !TxOutInAnyEra | TxBodyMetadataError ![(Word64, TxMetadataRangeError)] - | TxBodyMintAdaError + | TxBodyMintAdaError -- TODO remove - case nonexistent | TxBodyInIxOverflow !TxIn | TxBodyMissingProtocolParams | TxBodyProtocolParamsConversionError !ProtocolParametersConversionError @@ -1824,11 +1856,9 @@ validateTxOuts sbe txOuts = do | txout@(TxOut _ v _ _) <- txOuts ] +-- TODO remove validateMintValue :: TxMintValue build era -> Either TxBodyError () -validateMintValue txMintValue = - case txMintValue of - TxMintNone -> return () - TxMintValue _ v _ -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError +validateMintValue _txMintValue = pure () inputIndexDoesNotExceedMax :: [(TxIn, a)] -> Either TxBodyError () inputIndexDoesNotExceedMax txIns = @@ -2285,20 +2315,20 @@ fromLedgerTxMintValue :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxMintValue ViewTx era -fromLedgerTxMintValue sbe body = - case sbe of - ShelleyBasedEraShelley -> TxMintNone - ShelleyBasedEraAllegra -> TxMintNone - ShelleyBasedEraMary -> toMintValue body MaryEraOnwardsMary - ShelleyBasedEraAlonzo -> toMintValue body MaryEraOnwardsAlonzo - ShelleyBasedEraBabbage -> toMintValue body MaryEraOnwardsBabbage - ShelleyBasedEraConway -> toMintValue body MaryEraOnwardsConway - where - toMintValue txBody maInEra - | L.isZero mint = TxMintNone - | otherwise = TxMintValue maInEra (fromMaryValue mint) ViewTx - where - mint = MaryValue (Ledger.Coin 0) (txBody ^. L.mintTxBodyL) +fromLedgerTxMintValue sbe body = forEraInEon (toCardanoEra sbe) TxMintNone $ \w -> + maryEraOnwardsConstraints w $ do + let mint = MaryValue (Ledger.Coin 0) (body ^. L.mintTxBodyL) + if L.isZero mint + then TxMintNone + else do + let assetMap = toList $ fromMaryValue mint + TxMintValue w $ + Map.fromListWith + (<>) + [ (policyId', [(assetName', quantity, ViewTx)]) + | -- only non-ada can be here + (AssetId policyId' assetName', quantity) <- toList assetMap + ] makeByronTransactionBody :: () @@ -2412,12 +2442,9 @@ convTxUpdateProposal sbe = \case TxUpdateProposal _ p -> bimap TxBodyProtocolParamsConversionError pure $ toLedgerUpdate sbe p convMintValue :: TxMintValue build era -> MultiAsset StandardCrypto -convMintValue txMintValue = - case txMintValue of - TxMintNone -> mempty - TxMintValue _ v _ -> - case toMaryValue v of - MaryValue _ ma -> ma +convMintValue txMintValue = do + let L.MaryValue _coin multiAsset = toMaryValue $ txMintValueToValue txMintValue + multiAsset convExtraKeyWitnesses :: TxExtraKeyWitnesses era -> Set (Shelley.KeyHash Shelley.Witness StandardCrypto) @@ -3328,12 +3355,9 @@ collectTxBodyScriptWitnesses :: TxMintValue BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] scriptWitnessesMinting TxMintNone = [] - scriptWitnessesMinting (TxMintValue _ value (BuildTxWith witnesses)) = - [ (ScriptWitnessIndexMint ix, AnyScriptWitness witness) - | -- The minting policies are indexed in policy id order in the value - let ValueNestedRep bundle = valueToNestedRep value - , (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle - , witness <- maybeToList (Map.lookup policyid witnesses) + scriptWitnessesMinting txMintValue' = + [ (ix, AnyScriptWitness witness) + | (ix, _, _, _, BuildTxWith witness) <- txMintValueToIndexed txMintValue' ] scriptWitnessesVoting diff --git a/cardano-api/internal/Cardano/Api/Value.hs b/cardano-api/internal/Cardano/Api/Value.hs index 070b4aba8e..c97133e2bc 100644 --- a/cardano-api/internal/Cardano/Api/Value.hs +++ b/cardano-api/internal/Cardano/Api/Value.hs @@ -328,6 +328,7 @@ calcMinimumDeposit v = -- ---------------------------------------------------------------------------- -- An alternative nested representation -- +-- TODO remove ? - it is now unused -- | An alternative nested representation for 'Value' that groups assets that -- share a 'PolicyId'. @@ -358,7 +359,7 @@ valueToNestedRep v = valueFromNestedRep :: ValueNestedRep -> Value valueFromNestedRep (ValueNestedRep bundles) = - valueFromList + fromList [ (aId, q) | bundle <- bundles , (aId, q) <- case bundle of diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index b98b2eb3eb..17891ba79f 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -368,6 +368,8 @@ module Cardano.Api , TxCertificates (..) , TxUpdateProposal (..) , TxMintValue (..) + , txMintValueToValue + , txMintValueToIndexed , TxVotingProcedures (..) , mkTxVotingProcedures , TxProposalProcedures (..) @@ -535,6 +537,7 @@ module Cardano.Api , WitCtxMint , WitCtxStake , WitCtx (..) + , WitCtxMaybe (..) , ScriptWitness (..) , Witness (..) , KeyWitnessInCtx (..) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs index 207cec7c25..2a3fc42dec 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs @@ -83,8 +83,7 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr let txMint = TxMintValue meo - [(AssetId policyId' "eeee", 1)] - (BuildTxWith [(policyId', plutusWitness)]) + [(policyId', [("eeee", 1, BuildTxWith plutusWitness)])] -- tx body content without an asset in TxOut let content = @@ -167,8 +166,7 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $ let txMint = TxMintValue meo - [(AssetId policyId' "eeee", 1)] - (BuildTxWith [(policyId', plutusWitness)]) + [(policyId', [("eeee", 1, BuildTxWith plutusWitness)])] let content = defaultTxBodyContent sbe