diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 0a5a4f839a..2fe8c3f277 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -650,12 +650,17 @@ genTxMintValue = inEonForEra (pure TxMintNone) $ \w -> do - values <- Gen.list (Range.constant 1 10) (genValueForMinting w) - witnessedValues <- forM values $ \v -> - (v,) . pure <$> genScriptWitnessForMint (maryEraOnwardsToShelleyBasedEra w) + 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 - , pure $ TxMintValue w witnessedValues + , pure $ TxMintValue w (fromList assets) ] genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era) diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 99660cd1f0..0b648c6e9a 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 #-} {-# LANGUAGE UndecidableInstances #-} -- | Fee calculation @@ -1353,10 +1354,8 @@ calculateChangeValue :: ShelleyBasedEra era -> Value -> TxBodyContent build era -> Value calculateChangeValue sbe incoming txbodycontent = let outgoing = calculateCreatedUTOValue sbe txbodycontent - mintedValues = case txMintValue txbodycontent of - TxMintNone -> mempty - TxMintValue _ vs -> fst <$> vs - in mconcat $ [incoming] <> mintedValues <> [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 @@ -1627,40 +1626,20 @@ substituteExecutionUnits :: TxMintValue BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxMintValue BuildTx era) mapScriptWitnessesMinting TxMintNone = Right TxMintNone - mapScriptWitnessesMinting (TxMintValue w valueWitnesses) = do - let valuesWithPoliciesWithWitnesses = fromList - [ (policyId, (value, witness)) - | let ValueNestedRep bundle = valueToNestedRep value - , ValueNestedBundle policyId _ <- bundle - , (value, witness) <- valueWitnesses + 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 ] - -- all policies sorted with correct indices - allPolicies = zip [0..] $ Map.keys valuesWithPoliciesWithWitnesses - forM valueWitnesses $ \(value, witness) -> - -- TODO - - -- TxMintValue supported value $ BuildTxWith $ fromList - let mappedScriptWitnesses - :: [(PolicyId, Either (TxBodyErrorAutoBalance era) (ScriptWitness WitCtxMint era))] - mappedScriptWitnesses = - [ (policyid, eWitness) - | -- 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 eWitness = substituteExecUnits (ScriptWitnessIndexMint ix) witness - ] - -- let mappedScriptWitnesses = - -- [(value, eWitness) | let eWitness substituteExecUnits witness - final <- traverseScriptWitnesses mappedScriptWitnesses - Right . TxMintValue w value . BuildTxWith $ - fromList final + 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 afc0070cd3..a20a33f8e4 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 (..)) @@ -676,6 +677,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 diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index aa1102229e..0e2d563e19 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -113,6 +113,8 @@ module Cardano.Api.Tx.Body , TxCertificates (..) , TxUpdateProposal (..) , TxMintValue (..) + , txMintValueToValue + , txMintValueToIndexed , TxVotingProcedures (..) , mkTxVotingProcedures , TxProposalProcedures (..) @@ -215,7 +217,6 @@ import Cardano.Api.ProtocolParameters import qualified Cardano.Api.ReexposeLedger as Ledger import Cardano.Api.Script import Cardano.Api.ScriptData -import Cardano.Api.ScriptData () import Cardano.Api.SerialiseCBOR import Cardano.Api.SerialiseJSON import Cardano.Api.SerialiseRaw @@ -1275,16 +1276,46 @@ data TxMintValue build era where TxMintNone :: TxMintValue build era TxMintValue :: MaryEraOnwards era - -- This seems ill-defined: - -- Value here should not contain coins, they are ignored down the line - -- this basically means it should be a policyId -> witness map - -> [(Value, BuildTxWith build (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) -- @@ -1588,7 +1619,7 @@ data TxBodyError | TxBodyOutputNegative !Quantity !TxOutInAnyEra | TxBodyOutputOverflow !Quantity !TxOutInAnyEra | TxBodyMetadataError ![(Word64, TxMetadataRangeError)] - | TxBodyMintAdaError + | TxBodyMintAdaError -- TODO remove - case nonexistent | TxBodyInIxOverflow !TxIn | TxBodyMissingProtocolParams | TxBodyProtocolParamsConversionError !ProtocolParametersConversionError @@ -1858,11 +1889,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 _ vs -> forM_ vs $ \(v, _) -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError +validateMintValue _txMintValue = pure () inputIndexDoesNotExceedMax :: [(TxIn, a)] -> Either TxBodyError () inputIndexDoesNotExceedMax txIns = @@ -2318,26 +2347,20 @@ fromLedgerTxMintValue :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> 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 - then TxMintNone - else TxMintValue w [(fromMaryValue mint, ViewTx)] - --- TxMintValue w undefined --- 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 :: () @@ -2451,13 +2474,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 _ vs -> - mconcat $ flip map vs $ \(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) @@ -3371,14 +3390,10 @@ collectTxBodyScriptWitnesses :: TxMintValue BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] scriptWitnessesMinting TxMintNone = [] - scriptWitnessesMinting (TxMintValue _ _vw) = undefined - -- FIXME - -- [ (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 :: TxVotingProcedures BuildTx era diff --git a/cardano-api/internal/Cardano/Api/Value.hs b/cardano-api/internal/Cardano/Api/Value.hs index ca64421a5b..c87591dfb4 100644 --- a/cardano-api/internal/Cardano/Api/Value.hs +++ b/cardano-api/internal/Cardano/Api/Value.hs @@ -323,6 +323,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'. diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 08f681038a..d44b167a5e 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -364,6 +364,8 @@ module Cardano.Api , TxCertificates (..) , TxUpdateProposal (..) , TxMintValue (..) + , txMintValueToValue + , txMintValueToIndexed , TxVotingProcedures (..) , mkTxVotingProcedures , TxProposalProcedures (..) @@ -527,6 +529,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 b9111cb58b..046ab8a40d 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,9 +83,7 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr let txMint = TxMintValue meo - undefined - -- [(AssetId policyId' "eeee", 1)] - -- (BuildTxWith [(policyId', plutusWitness)]) + [(policyId', [("eeee", 1, BuildTxWith plutusWitness)])] -- tx body content without an asset in TxOut let content = @@ -168,9 +166,7 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $ let txMint = TxMintValue meo - undefined - -- [(AssetId policyId' "eeee", 1)] - -- (BuildTxWith [(policyId', plutusWitness)]) + [(policyId', [("eeee", 1, BuildTxWith plutusWitness)])] let content = defaultTxBodyContent sbe