Skip to content

Commit ed64a00

Browse files
carbolymercarbolymer
committed
Make 1-1 relationship of witness and policy ID in TxMintValue instead of 1-*
 * Remove exports: `parseValue`, `ParserValueRole` * Add new type `PolicyAssets` representing minted assets within a single PolicyId * Add `mkTxMintValue` helper function
1 parent 7b5cd90 commit ed64a00

File tree

11 files changed

+246
-108
lines changed

11 files changed

+246
-108
lines changed

‎cardano-api/cardano-api.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -146,6 +146,7 @@ library
146146
memory,
147147
microlens,
148148
microlens-aeson,
149+
mono-traversable,
149150
mtl,
150151
network,
151152
network-mux,

‎cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs‎

Lines changed: 27 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,6 @@
22
{-# LANGUAGE DataKinds #-}
33
{-# LANGUAGE FlexibleContexts #-}
44
{-# LANGUAGE GADTs #-}
5-
{-# LANGUAGE LambdaCase #-}
65
{-# LANGUAGE NamedFieldPuns #-}
76
{-# LANGUAGE OverloadedStrings #-}
87
{-# LANGUAGE RankNTypes #-}
@@ -101,11 +100,11 @@ module Test.Gen.Cardano.Api.Typed
101100
, genTxInsReference
102101
, genTxMetadataInEra
103102
, genTxMintValue
103+
, genPolicyAssets
104104
, genLovelace
105105
, genPositiveLovelace
106106
, genValue
107107
, genValueDefault
108-
, genValueForRole
109108
, genVerificationKey
110109
, genVerificationKeyHash
111110
, genUpdateProposal
@@ -124,6 +123,8 @@ module Test.Gen.Cardano.Api.Typed
124123
, genPositiveQuantity
125124
, genValueForMinting
126125
, genValueForTxOut
126+
, genLedgerValueForTxOut
127+
, genLedgerMultiAssetValue
127128
, genWitnesses
128129
, genWitnessNetworkIdOrByronAddress
129130
, genRational
@@ -188,6 +189,7 @@ import qualified Hedgehog.Gen.QuickCheck as Q
188189
import qualified Hedgehog.Range as Range
189190

190191

192+
191193
genAddressByron :: Gen (Address ByronAddr)
192194
genAddressByron =
193195
makeByronAddress
@@ -486,13 +488,10 @@ genLedgerValue w genAId genQuant =
486488
genValueDefault :: MaryEraOnwards era -> Gen (L.Value (ShelleyLedgerEra era))
487489
genValueDefault w = genLedgerValue w genAssetId genSignedNonZeroQuantity
488490

489-
genValueForRole :: MaryEraOnwards era -> ParserValueRole -> Gen Value
490-
genValueForRole w =
491-
\case
492-
RoleMint ->
493-
genValueForMinting
494-
RoleUTxO ->
495-
fromLedgerValue (convert w) <$> genValueForTxOut (convert w)
491+
-- | Generate a 'Value' suitable for use in a transaction output, with non-zero ADA,
492+
-- any asset IDs and with positive quantities
493+
genValueForTxOut :: ShelleyBasedEra era -> Gen Value
494+
genValueForTxOut w = fromLedgerValue w <$> genLedgerValueForTxOut w
496495

497496
-- | Generate a 'Value' suitable for minting, i.e. non-ADA asset ID and a
498497
-- positive or negative quantity.
@@ -505,8 +504,8 @@ genValueForMinting =
505504

506505
-- | Generate a 'Value' suitable for usage in a transaction output, i.e. any
507506
-- asset ID and a positive quantity.
508-
genValueForTxOut :: ShelleyBasedEra era -> Gen (L.Value (ShelleyLedgerEra era))
509-
genValueForTxOut sbe = do
507+
genLedgerValueForTxOut :: ShelleyBasedEra era -> Gen (L.Value (ShelleyLedgerEra era))
508+
genLedgerValueForTxOut sbe = do
510509
-- Generate at least one positive ADA, without it Value in TxOut makes no sense
511510
-- and will fail deserialization starting with ConwayEra
512511
ada <- A.mkAdaValue sbe . L.Coin <$> Gen.integral (Range.constant 1 2)
@@ -520,6 +519,9 @@ genValueForTxOut sbe = do
520519
)
521520
sbe
522521

522+
genLedgerMultiAssetValue :: Gen (L.MultiAsset L.StandardCrypto)
523+
genLedgerMultiAssetValue = Q.arbitrary
524+
523525
-- Note that we expect to sometimes generate duplicate policy id keys since we
524526
-- pick 90% of policy ids from a set of just three.
525527
genValueNestedRep :: Gen ValueNestedRep
@@ -631,7 +633,7 @@ genTxIndex :: Gen TxIx
631633
genTxIndex = TxIx . fromIntegral <$> Gen.word16 Range.constantBounded
632634

633635
genTxOutValue :: ShelleyBasedEra era -> Gen (TxOutValue era)
634-
genTxOutValue sbe = shelleyBasedEraConstraints sbe $ TxOutValueShelleyBased sbe <$> genValueForTxOut sbe
636+
genTxOutValue sbe = shelleyBasedEraConstraints sbe $ TxOutValueShelleyBased sbe <$> genLedgerValueForTxOut sbe
635637

636638
genTxOutTxContext :: ShelleyBasedEra era -> Gen (TxOut CtxTx era)
637639
genTxOutTxContext era =
@@ -858,19 +860,25 @@ genTxMintValue =
858860
inEonForEra
859861
(pure TxMintNone)
860862
$ \w -> do
863+
-- TODO update this generator to generate witnesses, and then calculate policy id (via scriptHash) from the
864+
-- witnesses
861865
policies <- Gen.list (Range.constant 1 3) genPolicyId
862-
assets <- forM policies $ \policy ->
863-
(,) policy <$>
864-
Gen.list
865-
(Range.constant 1 3)
866-
((,,) <$> genAssetName
867-
<*> genPositiveQuantity
868-
<*> fmap (fmap pure) genScriptWitnessForMint (maryEraOnwardsToShelleyBasedEra w))
866+
assets <- forM policies $ \policy -> do
867+
mintValue <- genPolicyAssets
868+
witness <- genScriptWitnessForMint (maryEraOnwardsToShelleyBasedEra w)
869+
pure (policy, (mintValue, pure witness))
870+
869871
Gen.choice
870872
[ pure TxMintNone
871873
, pure $ TxMintValue w (fromList assets)
872874
]
873875

876+
genPolicyAssets :: Gen PolicyAssets
877+
genPolicyAssets = do
878+
assetQuantities <- Gen.list (Range.constant 0 5) $
879+
(,) <$> genAssetName <*> genPositiveQuantity
880+
pure $ fromList assetQuantities
881+
874882
genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era)
875883
genTxBodyContent sbe = do
876884
let era = toCardanoEra sbe

‎cardano-api/src/Cardano/Api.hs‎

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -234,8 +234,6 @@ module Cardano.Api
234234
, AssetName (..)
235235
, AssetId (..)
236236
, Value
237-
, ParserValueRole (..)
238-
, parseValue
239237
, parsePolicyId
240238
, parseAssetName
241239
, parseTxOutMultiAssetValue
@@ -251,9 +249,15 @@ module Cardano.Api
251249
, valueToNestedRep
252250
, valueFromNestedRep
253251
, renderValue
252+
, renderMultiAsset
254253
, renderValuePretty
254+
, renderMultiAssetPretty
255255
, toLedgerValue
256256
, fromLedgerValue
257+
, PolicyAssets (..)
258+
, policyAssetsToValue
259+
, valueToPolicyAssets
260+
, multiAssetToPolicyAssets
257261

258262
-- ** Ada \/ Lovelace within multi-asset values
259263
, Lovelace
@@ -395,6 +399,7 @@ module Cardano.Api
395399
, mkTxCertificates
396400
, TxUpdateProposal (..)
397401
, TxMintValue (..)
402+
, mkTxMintValue
398403
, txMintValueToValue
399404
, indexTxMintValue
400405
, TxVotingProcedures (..)

‎cardano-api/src/Cardano/Api/Internal/Experimental/Eras.hs‎

Lines changed: 13 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -148,6 +148,19 @@ instance FromJSON (Some Era) where
148148
)
149149
. eraFromStringLike
150150

151+
-- | A temporary compatibility instance for easier conversion between the experimental and old APIs.
152+
instance Eon Era where
153+
inEonForEra v f = \case
154+
Api.ConwayEra -> f ConwayEra
155+
Api.BabbageEra -> f BabbageEra
156+
_ -> v
157+
158+
-- | A temporary compatibility instance for easier conversion between the experimental and old APIs.
159+
instance Api.ToCardanoEra Era where
160+
toCardanoEra = \case
161+
BabbageEra -> Api.BabbageEra
162+
ConwayEra -> Api.ConwayEra
163+
151164
eraToStringLike :: IsString a => Era era -> a
152165
{-# INLINE eraToStringLike #-}
153166
eraToStringLike = \case
@@ -253,13 +266,6 @@ instance IsEra BabbageEra where
253266
instance IsEra ConwayEra where
254267
useEra = ConwayEra
255268

256-
-- | A temporary compatibility instance for easier conversion between the experimental and old APIs.
257-
instance Eon Era where
258-
inEonForEra v f = \case
259-
Api.ConwayEra -> f ConwayEra
260-
Api.BabbageEra -> f BabbageEra
261-
_ -> v
262-
263269
obtainCommonConstraints
264270
:: Era era
265271
-> (EraCommonConstraints era => a)

‎cardano-api/src/Cardano/Api/Internal/Fees.hs‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1878,11 +1878,13 @@ substituteExecutionUnits
18781878
mapScriptWitnessesMinting TxMintNone = Right TxMintNone
18791879
mapScriptWitnessesMinting txMintValue'@(TxMintValue w _) = do
18801880
let mappedScriptWitnesses =
1881-
[ (policyId, pure . (assetName',quantity,) <$> substitutedWitness)
1882-
| (ix, policyId, assetName', quantity, BuildTxWith witness) <- indexTxMintValue txMintValue'
1881+
[ (policyId, (assets,) <$> substitutedWitness)
1882+
| (ix, policyId, assets, BuildTxWith witness) <- indexTxMintValue txMintValue'
18831883
, let substitutedWitness = BuildTxWith <$> substituteExecUnits ix witness
18841884
]
1885-
final <- Map.fromListWith (<>) <$> traverseScriptWitnesses mappedScriptWitnesses
1885+
-- merge map values, wit1 == wit2 will always hold
1886+
mergeValues (assets1, wit1) (assets2, _wit2) = (assets1 <> assets2, wit1)
1887+
final <- Map.fromListWith mergeValues <$> traverseScriptWitnesses mappedScriptWitnesses
18861888
pure $ TxMintValue w final
18871889

18881890
traverseScriptWitnesses

‎cardano-api/src/Cardano/Api/Internal/ReexposeLedger.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,7 @@ module Cardano.Api.Internal.ReexposeLedger
5656
, TxId (..)
5757
, TxIn (..)
5858
, Value
59+
, MultiAsset (..)
5960
, addDeltaCoin
6061
, castSafeHash
6162
, toDeltaCoin
@@ -321,6 +322,7 @@ import Cardano.Ledger.Keys
321322
, hashWithSerialiser
322323
, toVRFVerKeyHash
323324
)
325+
import Cardano.Ledger.Mary.Value (MultiAsset (..))
324326
import Cardano.Ledger.Plutus.Data (Data (..), unData)
325327
import Cardano.Ledger.Plutus.Language (Language, Plutus, languageToText, plutusBinary)
326328
import Cardano.Ledger.PoolParams (PoolMetadata (..), PoolParams (..), StakePoolRelay (..))

‎cardano-api/src/Cardano/Api/Internal/Tx/Body.hs‎

Lines changed: 47 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -314,6 +314,7 @@ module Cardano.Api.Internal.Tx.Body
314314
, indexTxCertificates
315315
, TxUpdateProposal (..)
316316
, TxMintValue (..)
317+
, mkTxMintValue
317318
, txMintValueToValue
318319
, indexTxMintValue
319320
, TxVotingProcedures (..)
@@ -487,6 +488,7 @@ import Data.Map.Ordered.Strict (OMap)
487488
import Data.Map.Strict (Map)
488489
import Data.Map.Strict qualified as Map
489490
import Data.Maybe
491+
import Data.MonoTraversable (omap)
490492
import Data.Monoid
491493
import Data.OSet.Strict (OSet)
492494
import Data.OSet.Strict qualified as OSet
@@ -1105,6 +1107,9 @@ instance Applicative (BuildTxWith BuildTx) where
11051107
pure = BuildTxWith
11061108
(BuildTxWith f) <*> (BuildTxWith a) = BuildTxWith (f a)
11071109

1110+
instance Semigroup (BuildTxWith ViewTx a) where
1111+
ViewTx <> ViewTx = ViewTx
1112+
11081113
buildTxWithToMaybe :: BuildTxWith build a -> Maybe a
11091114
buildTxWithToMaybe ViewTx = Nothing
11101115
buildTxWithToMaybe (BuildTxWith a) = Just a
@@ -1536,25 +1541,46 @@ data TxMintValue build era where
15361541
:: MaryEraOnwards era
15371542
-> Map
15381543
PolicyId
1539-
[ ( AssetName
1540-
, Quantity
1541-
, BuildTxWith build (ScriptWitness WitCtxMint era)
1542-
)
1543-
]
1544+
( PolicyAssets
1545+
, BuildTxWith build (ScriptWitness WitCtxMint era)
1546+
)
15441547
-> TxMintValue build era
15451548

15461549
deriving instance Eq (TxMintValue build era)
15471550

15481551
deriving instance Show (TxMintValue build era)
15491552

1553+
instance Semigroup (TxMintValue build era) where
1554+
TxMintNone <> b = b
1555+
a <> TxMintNone = a
1556+
TxMintValue w a <> TxMintValue _ b = TxMintValue w $ Map.unionWith mergeElements a b
1557+
where
1558+
mergeElements (a1, w1) (a2, _w2) = (a1 <> a2, w1)
1559+
1560+
instance Monoid (TxMintValue build era) where
1561+
mempty = TxMintNone
1562+
mappend = (<>)
1563+
1564+
-- | A helper function for building 'TxMintValue' with present witnesses. Only the first witness
1565+
-- in the argument will be used for each policy id.
1566+
mkTxMintValue
1567+
:: MaryEraOnwards era
1568+
-> [(PolicyId, PolicyAssets, BuildTxWith build (ScriptWitness WitCtxMint era))]
1569+
-> TxMintValue build era
1570+
mkTxMintValue _ [] = TxMintNone
1571+
mkTxMintValue w vs =
1572+
mconcat $
1573+
[ TxMintValue w (fromList [(policyId, (assets, bWit))])
1574+
| (policyId, assets, bWit) <- vs
1575+
]
1576+
15501577
-- | Convert 'TxMintValue' to a more handy 'Value'.
15511578
txMintValueToValue :: TxMintValue build era -> Value
15521579
txMintValueToValue TxMintNone = mempty
15531580
txMintValueToValue (TxMintValue _ policiesWithAssets) =
1554-
fromList
1555-
[ (AssetId policyId' assetName', quantity)
1556-
| (policyId', assets) <- toList policiesWithAssets
1557-
, (assetName', quantity, _) <- assets
1581+
mconcat
1582+
[ policyAssetsToValue policyId assets
1583+
| (policyId, (assets, _witness)) <- toList policiesWithAssets
15581584
]
15591585

15601586
-- | Index the assets with witnesses in the order of policy ids.
@@ -1563,16 +1589,14 @@ indexTxMintValue
15631589
:: TxMintValue build era
15641590
-> [ ( ScriptWitnessIndex
15651591
, PolicyId
1566-
, AssetName
1567-
, Quantity
1592+
, PolicyAssets
15681593
, BuildTxWith build (ScriptWitness WitCtxMint era)
15691594
)
15701595
]
15711596
indexTxMintValue TxMintNone = []
15721597
indexTxMintValue (TxMintValue _ policiesWithAssets) =
1573-
[ (ScriptWitnessIndexMint ix, policyId', assetName', quantity, witness)
1574-
| (ix, (policyId', assets)) <- zip [0 ..] $ toList policiesWithAssets
1575-
, (assetName', quantity, witness) <- assets
1598+
[ (ScriptWitnessIndexMint ix, policyId, assets, witness)
1599+
| (ix, (policyId, (assets, witness))) <- zip [0 ..] $ toList policiesWithAssets
15761600
]
15771601

15781602
-- ----------------------------------------------------------------------------
@@ -1967,23 +1991,23 @@ modTxMintValue f tx = tx{txMintValue = f (txMintValue tx)}
19671991

19681992
addTxMintValue
19691993
:: IsMaryBasedEra era
1970-
=> Map PolicyId [(AssetName, Quantity, BuildTxWith build (ScriptWitness WitCtxMint era))]
1994+
=> Map PolicyId (PolicyAssets, BuildTxWith build (ScriptWitness WitCtxMint era))
19711995
-> TxBodyContent build era
19721996
-> TxBodyContent build era
19731997
addTxMintValue assets =
19741998
modTxMintValue
19751999
( \case
19762000
TxMintNone -> TxMintValue maryBasedEra assets
1977-
TxMintValue era t -> TxMintValue era (t <> assets)
2001+
TxMintValue era t -> TxMintValue era $ Map.unionWith (\(v1, w1) (v2, _w2) -> (v1 <> v2, w1)) assets t -- w1 == w2
19782002
)
19792003

19802004
-- | Adds the negation of the provided assets and quantities to the txMintValue field of the `TxBodyContent`.
19812005
subtractTxMintValue
19822006
:: IsMaryBasedEra era
1983-
=> Map PolicyId [(AssetName, Quantity, BuildTxWith build (ScriptWitness WitCtxMint era))]
2007+
=> Map PolicyId (PolicyAssets, BuildTxWith build (ScriptWitness WitCtxMint era))
19842008
-> TxBodyContent build era
19852009
-> TxBodyContent build era
1986-
subtractTxMintValue assets = addTxMintValue (fmap (fmap (\(x, y, z) -> (x, negate y, z))) assets)
2010+
subtractTxMintValue assets = addTxMintValue $ first (omap negate) <$> assets
19872011

19882012
setTxScriptValidity :: TxScriptValidity era -> TxBodyContent build era -> TxBodyContent build era
19892013
setTxScriptValidity v txBodyContent = txBodyContent{txScriptValidity = v}
@@ -2774,18 +2798,11 @@ fromLedgerTxMintValue
27742798
-> TxMintValue ViewTx era
27752799
fromLedgerTxMintValue sbe body = forEraInEon (toCardanoEra sbe) TxMintNone $ \w ->
27762800
maryEraOnwardsConstraints w $ do
2777-
let mint = MaryValue (Ledger.Coin 0) (body ^. L.mintTxBodyL)
2778-
if L.isZero mint
2801+
let multiAsset = body ^. L.mintTxBodyL
2802+
if L.isZero $ MaryValue (Ledger.Coin 0) multiAsset
27792803
then TxMintNone
2780-
else do
2781-
let assetMap = toList $ fromMaryValue mint
2782-
TxMintValue w $
2783-
Map.fromListWith
2784-
(<>)
2785-
[ (policyId', [(assetName', quantity, ViewTx)])
2786-
| -- only non-ada can be here
2787-
(AssetId policyId' assetName', quantity) <- toList assetMap
2788-
]
2804+
else
2805+
TxMintValue w $ (,ViewTx) <$> multiAssetToPolicyAssets multiAsset
27892806

27902807
makeByronTransactionBody
27912808
:: ()
@@ -3823,7 +3840,7 @@ collectTxBodyScriptWitnesses
38233840
scriptWitnessesMinting txMintValue' =
38243841
List.nub
38253842
[ (ix, AnyScriptWitness witness)
3826-
| (ix, _, _, _, BuildTxWith witness) <- indexTxMintValue txMintValue'
3843+
| (ix, _, _, BuildTxWith witness) <- indexTxMintValue txMintValue'
38273844
]
38283845

38293846
scriptWitnessesVoting

0 commit comments

Comments
 (0)