Merge pull request #776 from IntersectMBO/mgalazyn/refactor/pull-higher-witness-in-txmintvalue

Make 1-1 relationship of witness and policy ID in TxMintValue instead of 1-*

Author: carbolymer

cardano-api/cardano-api.cabal

@@ -146,6 +146,7 @@ library
     memory,
     microlens,
     microlens-aeson,
+    mono-traversable,
     mtl,
     network,
     network-mux,

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

@@ -2,7 +2,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
@@ -101,11 +100,11 @@ module Test.Gen.Cardano.Api.Typed
   , genTxInsReference
   , genTxMetadataInEra
   , genTxMintValue
+  , genPolicyAssets
   , genLovelace
   , genPositiveLovelace
   , genValue
   , genValueDefault
-  , genValueForRole
   , genVerificationKey
   , genVerificationKeyHash
   , genUpdateProposal
@@ -124,6 +123,8 @@ module Test.Gen.Cardano.Api.Typed
   , genPositiveQuantity
   , genValueForMinting
   , genValueForTxOut
+  , genLedgerValueForTxOut
+  , genLedgerMultiAssetValue
   , genWitnesses
   , genWitnessNetworkIdOrByronAddress
   , genRational
@@ -188,6 +189,7 @@ import qualified Hedgehog.Gen.QuickCheck as Q
 import qualified Hedgehog.Range as Range
 
 
+
 genAddressByron :: Gen (Address ByronAddr)
 genAddressByron =
   makeByronAddress
@@ -486,13 +488,10 @@ genLedgerValue w genAId genQuant =
 genValueDefault :: MaryEraOnwards era -> Gen (L.Value (ShelleyLedgerEra era))
 genValueDefault w = genLedgerValue w genAssetId genSignedNonZeroQuantity
 
-genValueForRole :: MaryEraOnwards era -> ParserValueRole -> Gen Value
-genValueForRole w =
-  \case
-    RoleMint ->
-      genValueForMinting
-    RoleUTxO ->
-      fromLedgerValue (convert w) <$> genValueForTxOut (convert w)
+-- | Generate a 'Value' suitable for use in a transaction output, with non-zero ADA,
+-- any asset IDs and with positive quantities
+genValueForTxOut :: ShelleyBasedEra era -> Gen Value
+genValueForTxOut w = fromLedgerValue w <$> genLedgerValueForTxOut w
 
 -- | Generate a 'Value' suitable for minting, i.e. non-ADA asset ID and a
 -- positive or negative quantity.
@@ -505,8 +504,8 @@ genValueForMinting =
 
 -- | Generate a 'Value' suitable for usage in a transaction output, i.e. any
 -- asset ID and a positive quantity.
-genValueForTxOut :: ShelleyBasedEra era -> Gen (L.Value (ShelleyLedgerEra era))
-genValueForTxOut sbe = do
+genLedgerValueForTxOut :: ShelleyBasedEra era -> Gen (L.Value (ShelleyLedgerEra era))
+genLedgerValueForTxOut sbe = do
   -- Generate at least one positive ADA, without it Value in TxOut makes no sense
   -- and will fail deserialization starting with ConwayEra
   ada <- A.mkAdaValue sbe . L.Coin <$> Gen.integral (Range.constant 1 2)
@@ -520,6 +519,9 @@ genValueForTxOut sbe = do
     )
     sbe
 
+genLedgerMultiAssetValue :: Gen (L.MultiAsset L.StandardCrypto)
+genLedgerMultiAssetValue = Q.arbitrary
+
 -- Note that we expect to sometimes generate duplicate policy id keys since we
 -- pick 90% of policy ids from a set of just three.
 genValueNestedRep :: Gen ValueNestedRep
@@ -631,7 +633,7 @@ genTxIndex :: Gen TxIx
 genTxIndex = TxIx . fromIntegral <$> Gen.word16 Range.constantBounded
 
 genTxOutValue :: ShelleyBasedEra era -> Gen (TxOutValue era)
-genTxOutValue sbe = shelleyBasedEraConstraints sbe $ TxOutValueShelleyBased sbe <$> genValueForTxOut sbe
+genTxOutValue sbe = shelleyBasedEraConstraints sbe $ TxOutValueShelleyBased sbe <$> genLedgerValueForTxOut sbe
 
 genTxOutTxContext :: ShelleyBasedEra era -> Gen (TxOut CtxTx era)
 genTxOutTxContext era =
@@ -858,19 +860,25 @@ genTxMintValue =
   inEonForEra
     (pure TxMintNone)
     $ \w -> do
+      -- TODO update this generator to generate witnesses, and then calculate policy id (via scriptHash) from the
+      -- witnesses
       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))
+      assets <- forM policies $ \policy -> do
+        mintValue <- genPolicyAssets
+        witness <- genScriptWitnessForMint (maryEraOnwardsToShelleyBasedEra w)
+        pure (policy, (mintValue, pure witness))
+
       Gen.choice
         [ pure TxMintNone
         , pure $ TxMintValue w (fromList assets)
         ]
 
+genPolicyAssets :: Gen PolicyAssets
+genPolicyAssets = do
+  assetQuantities <- Gen.list (Range.constant 0 5) $
+    (,) <$> genAssetName <*> genPositiveQuantity
+  pure $ fromList assetQuantities
+
 genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era)
 genTxBodyContent sbe = do
   let era = toCardanoEra sbe

cardano-api/src/Cardano/Api.hs

@@ -234,8 +234,6 @@ module Cardano.Api
   , AssetName (..)
   , AssetId (..)
   , Value
-  , ParserValueRole (..)
-  , parseValue
   , parsePolicyId
   , parseAssetName
   , parseTxOutMultiAssetValue
@@ -251,9 +249,15 @@ module Cardano.Api
   , valueToNestedRep
   , valueFromNestedRep
   , renderValue
+  , renderMultiAsset
   , renderValuePretty
+  , renderMultiAssetPretty
   , toLedgerValue
   , fromLedgerValue
+  , PolicyAssets (..)
+  , policyAssetsToValue
+  , valueToPolicyAssets
+  , multiAssetToPolicyAssets
 
     -- ** Ada \/ Lovelace within multi-asset values
   , Lovelace
@@ -395,6 +399,7 @@ module Cardano.Api
   , mkTxCertificates
   , TxUpdateProposal (..)
   , TxMintValue (..)
+  , mkTxMintValue
   , txMintValueToValue
   , indexTxMintValue
   , TxVotingProcedures (..)

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

@@ -148,6 +148,19 @@ instance FromJSON (Some Era) where
       )
         . eraFromStringLike
 
+-- | A temporary compatibility instance for easier conversion between the experimental and old APIs.
+instance Eon Era where
+  inEonForEra v f = \case
+    Api.ConwayEra -> f ConwayEra
+    Api.BabbageEra -> f BabbageEra
+    _ -> v
+
+-- | A temporary compatibility instance for easier conversion between the experimental and old APIs.
+instance Api.ToCardanoEra Era where
+  toCardanoEra = \case
+    BabbageEra -> Api.BabbageEra
+    ConwayEra -> Api.ConwayEra
+
 eraToStringLike :: IsString a => Era era -> a
 {-# INLINE eraToStringLike #-}
 eraToStringLike = \case
@@ -253,13 +266,6 @@ instance IsEra BabbageEra where
 instance IsEra ConwayEra where
   useEra = ConwayEra
 
--- | A temporary compatibility instance for easier conversion between the experimental and old APIs.
-instance Eon Era where
-  inEonForEra v f = \case
-    Api.ConwayEra -> f ConwayEra
-    Api.BabbageEra -> f BabbageEra
-    _ -> v
-
 obtainCommonConstraints
   :: Era era
   -> (EraCommonConstraints era => a)

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

@@ -1878,11 +1878,13 @@ substituteExecutionUnits
     mapScriptWitnessesMinting TxMintNone = Right TxMintNone
     mapScriptWitnessesMinting txMintValue'@(TxMintValue w _) = do
       let mappedScriptWitnesses =
-            [ (policyId, pure . (assetName',quantity,) <$> substitutedWitness)
-            | (ix, policyId, assetName', quantity, BuildTxWith witness) <- indexTxMintValue txMintValue'
+            [ (policyId, (assets,) <$> substitutedWitness)
+            | (ix, policyId, assets, BuildTxWith witness) <- indexTxMintValue txMintValue'
             , let substitutedWitness = BuildTxWith <$> substituteExecUnits ix witness
             ]
-      final <- Map.fromListWith (<>) <$> traverseScriptWitnesses mappedScriptWitnesses
+          -- merge map values, wit1 == wit2 will always hold
+          mergeValues (assets1, wit1) (assets2, _wit2) = (assets1 <> assets2, wit1)
+      final <- Map.fromListWith mergeValues <$> traverseScriptWitnesses mappedScriptWitnesses
       pure $ TxMintValue w final
 
 traverseScriptWitnesses

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

@@ -56,6 +56,7 @@ module Cardano.Api.Internal.ReexposeLedger
   , TxId (..)
   , TxIn (..)
   , Value
+  , MultiAsset (..)
   , addDeltaCoin
   , castSafeHash
   , toDeltaCoin
@@ -321,6 +322,7 @@ import Cardano.Ledger.Keys
   , hashWithSerialiser
   , toVRFVerKeyHash
   )
+import Cardano.Ledger.Mary.Value (MultiAsset (..))
 import Cardano.Ledger.Plutus.Data (Data (..), unData)
 import Cardano.Ledger.Plutus.Language (Language, Plutus, languageToText, plutusBinary)
 import Cardano.Ledger.PoolParams (PoolMetadata (..), PoolParams (..), StakePoolRelay (..))

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

@@ -314,6 +314,7 @@ module Cardano.Api.Internal.Tx.Body
   , indexTxCertificates
   , TxUpdateProposal (..)
   , TxMintValue (..)
+  , mkTxMintValue
   , txMintValueToValue
   , indexTxMintValue
   , TxVotingProcedures (..)
@@ -487,6 +488,7 @@ import Data.Map.Ordered.Strict (OMap)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Maybe
+import Data.MonoTraversable (omap)
 import Data.Monoid
 import Data.OSet.Strict (OSet)
 import Data.OSet.Strict qualified as OSet
@@ -1105,6 +1107,9 @@ instance Applicative (BuildTxWith BuildTx) where
   pure = BuildTxWith
   (BuildTxWith f) <*> (BuildTxWith a) = BuildTxWith (f a)
 
+instance Semigroup (BuildTxWith ViewTx a) where
+  ViewTx <> ViewTx = ViewTx
+
 buildTxWithToMaybe :: BuildTxWith build a -> Maybe a
 buildTxWithToMaybe ViewTx = Nothing
 buildTxWithToMaybe (BuildTxWith a) = Just a
@@ -1536,25 +1541,46 @@ data TxMintValue build era where
     :: MaryEraOnwards era
     -> Map
          PolicyId
-         [ ( AssetName
-           , Quantity
-           , BuildTxWith build (ScriptWitness WitCtxMint era)
-           )
-         ]
+         ( PolicyAssets
+         , BuildTxWith build (ScriptWitness WitCtxMint era)
+         )
     -> TxMintValue build era
 
 deriving instance Eq (TxMintValue build era)
 
 deriving instance Show (TxMintValue build era)
 
+instance Semigroup (TxMintValue build era) where
+  TxMintNone <> b = b
+  a <> TxMintNone = a
+  TxMintValue w a <> TxMintValue _ b = TxMintValue w $ Map.unionWith mergeElements a b
+   where
+    mergeElements (a1, w1) (a2, _w2) = (a1 <> a2, w1)
+
+instance Monoid (TxMintValue build era) where
+  mempty = TxMintNone
+  mappend = (<>)
+
+-- | A helper function for building 'TxMintValue' with present witnesses. Only the first witness
+-- in the argument will be used for each policy id.
+mkTxMintValue
+  :: MaryEraOnwards era
+  -> [(PolicyId, PolicyAssets, BuildTxWith build (ScriptWitness WitCtxMint era))]
+  -> TxMintValue build era
+mkTxMintValue _ [] = TxMintNone
+mkTxMintValue w vs =
+  mconcat $
+    [ TxMintValue w (fromList [(policyId, (assets, bWit))])
+    | (policyId, assets, bWit) <- vs
+    ]
+
 -- | 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
+  mconcat
+    [ policyAssetsToValue policyId assets
+    | (policyId, (assets, _witness)) <- toList policiesWithAssets
     ]
 
 -- | Index the assets with witnesses in the order of policy ids.
@@ -1563,16 +1589,14 @@ indexTxMintValue
   :: TxMintValue build era
   -> [ ( ScriptWitnessIndex
        , PolicyId
-       , AssetName
-       , Quantity
+       , PolicyAssets
        , BuildTxWith build (ScriptWitness WitCtxMint era)
        )
      ]
 indexTxMintValue TxMintNone = []
 indexTxMintValue (TxMintValue _ policiesWithAssets) =
-  [ (ScriptWitnessIndexMint ix, policyId', assetName', quantity, witness)
-  | (ix, (policyId', assets)) <- zip [0 ..] $ toList policiesWithAssets
-  , (assetName', quantity, witness) <- assets
+  [ (ScriptWitnessIndexMint ix, policyId, assets, witness)
+  | (ix, (policyId, (assets, witness))) <- zip [0 ..] $ toList policiesWithAssets
   ]
 
 -- ----------------------------------------------------------------------------
@@ -1967,23 +1991,23 @@ modTxMintValue f tx = tx{txMintValue = f (txMintValue tx)}
 
 addTxMintValue
   :: IsMaryBasedEra era
-  => Map PolicyId [(AssetName, Quantity, BuildTxWith build (ScriptWitness WitCtxMint era))]
+  => Map PolicyId (PolicyAssets, BuildTxWith build (ScriptWitness WitCtxMint era))
   -> TxBodyContent build era
   -> TxBodyContent build era
 addTxMintValue assets =
   modTxMintValue
     ( \case
         TxMintNone -> TxMintValue maryBasedEra assets
-        TxMintValue era t -> TxMintValue era (t <> assets)
+        TxMintValue era t -> TxMintValue era $ Map.unionWith (\(v1, w1) (v2, _w2) -> (v1 <> v2, w1)) assets t -- w1 == w2
     )
 
 -- | Adds the negation of the provided assets and quantities to the txMintValue field of the `TxBodyContent`.
 subtractTxMintValue
   :: IsMaryBasedEra era
-  => Map PolicyId [(AssetName, Quantity, BuildTxWith build (ScriptWitness WitCtxMint era))]
+  => Map PolicyId (PolicyAssets, BuildTxWith build (ScriptWitness WitCtxMint era))
   -> TxBodyContent build era
   -> TxBodyContent build era
-subtractTxMintValue assets = addTxMintValue (fmap (fmap (\(x, y, z) -> (x, negate y, z))) assets)
+subtractTxMintValue assets = addTxMintValue $ first (omap negate) <$> assets
 
 setTxScriptValidity :: TxScriptValidity era -> TxBodyContent build era -> TxBodyContent build era
 setTxScriptValidity v txBodyContent = txBodyContent{txScriptValidity = v}
@@ -2774,18 +2798,11 @@ fromLedgerTxMintValue
   -> TxMintValue ViewTx era
 fromLedgerTxMintValue sbe body = forEraInEon (toCardanoEra sbe) TxMintNone $ \w ->
   maryEraOnwardsConstraints w $ do
-    let mint = MaryValue (Ledger.Coin 0) (body ^. L.mintTxBodyL)
-    if L.isZero mint
+    let multiAsset = body ^. L.mintTxBodyL
+    if L.isZero $ MaryValue (Ledger.Coin 0) multiAsset
       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
-            ]
+      else
+        TxMintValue w $ (,ViewTx) <$> multiAssetToPolicyAssets multiAsset
 
 makeByronTransactionBody
   :: ()
@@ -3823,7 +3840,7 @@ collectTxBodyScriptWitnesses
     scriptWitnessesMinting txMintValue' =
       List.nub
         [ (ix, AnyScriptWitness witness)
-        | (ix, _, _, _, BuildTxWith witness) <- indexTxMintValue txMintValue'
+        | (ix, _, _, BuildTxWith witness) <- indexTxMintValue txMintValue'
         ]
 
     scriptWitnessesVoting