From ef2b00c52559ac4dca495e151bb6870b73a16290 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 25 Oct 2024 11:51:52 +0200 Subject: [PATCH] wip --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 7 ++- cardano-api/internal/Cardano/Api/Fees.hs | 43 ++++++------- cardano-api/internal/Cardano/Api/Tx/Body.hs | 63 ++++++++++--------- .../Cardano/Api/Transaction/Autobalance.hs | 10 +-- 4 files changed, 66 insertions(+), 57 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 9f484b23bc..2029a76d1a 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -649,11 +649,12 @@ genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era) genTxMintValue = inEonForEra (pure TxMintNone) - $ \supported -> + $ \w -> do + values <- Gen.list (Range.constant 1 10) (genValueForMinting w) Gen.choice [ pure TxMintNone - -- TODO write a generator for the last parameter of 'TxMintValue' constructor - , TxMintValue supported <$> genValueForMinting supported <*> return (pure mempty) + -- TODO write a generator for ScriptWitness and use it here + , pure $ TxMintValue w ((, undefined) <$> values) -- FIXME ] 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 eb0b917714..9139cc40ac 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -1353,10 +1353,10 @@ calculateChangeValue :: ShelleyBasedEra era -> Value -> TxBodyContent build era -> Value calculateChangeValue sbe incoming txbodycontent = let outgoing = calculateCreatedUTOValue sbe txbodycontent - minted = case txMintValue txbodycontent of + mintedValues = case txMintValue txbodycontent of TxMintNone -> mempty - TxMintValue _ v _ -> v - in mconcat [incoming, minted, negateValue outgoing] + TxMintValue _ vs -> fst <$> vs + in mconcat $ [incoming] <> mintedValues <> [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 @@ -1629,24 +1629,25 @@ substituteExecutionUnits 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 + valueWitnesses + ) = undefined + +-- FIXME +-- -- 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 traverseScriptWitnesses :: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))] diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 36671f2651..b1b5ae7432 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -1249,10 +1249,7 @@ data TxMintValue build era where TxMintNone :: TxMintValue build era TxMintValue :: MaryEraOnwards era - -> Value - -> BuildTxWith - build - (Map PolicyId (ScriptWitness WitCtxMint era)) + -> [(Value, BuildTxWith build (ScriptWitness WitCtxMint era))] -> TxMintValue build era deriving instance Eq (TxMintValue build era) @@ -1829,7 +1826,7 @@ validateMintValue :: TxMintValue build era -> Either TxBodyError () validateMintValue txMintValue = case txMintValue of TxMintNone -> return () - TxMintValue _ v _ -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError + TxMintValue _ vs -> forM_ vs $ \(v, _) -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError inputIndexDoesNotExceedMax :: [(TxIn, a)] -> Either TxBodyError () inputIndexDoesNotExceedMax txIns = @@ -2287,20 +2284,26 @@ 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 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) makeByronTransactionBody :: () @@ -2417,9 +2420,10 @@ convMintValue :: TxMintValue build era -> MultiAsset StandardCrypto convMintValue txMintValue = case txMintValue of TxMintNone -> mempty - TxMintValue _ v _ -> - case toMaryValue v of - MaryValue _ ma -> ma + TxMintValue _ vs -> + mconcat $ flip map vs $ \(v, _) -> + case toMaryValue v of + MaryValue _ ma -> ma convExtraKeyWitnesses :: TxExtraKeyWitnesses era -> Set (Shelley.KeyHash Shelley.Witness StandardCrypto) @@ -3330,13 +3334,14 @@ 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 _ _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) + -- ] scriptWitnessesVoting :: TxVotingProcedures BuildTx era 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 6a82255176..b9111cb58b 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,9 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr let txMint = TxMintValue meo - [(AssetId policyId' "eeee", 1)] - (BuildTxWith [(policyId', plutusWitness)]) + undefined + -- [(AssetId policyId' "eeee", 1)] + -- (BuildTxWith [(policyId', plutusWitness)]) -- tx body content without an asset in TxOut let content = @@ -167,8 +168,9 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $ let txMint = TxMintValue meo - [(AssetId policyId' "eeee", 1)] - (BuildTxWith [(policyId', plutusWitness)]) + undefined + -- [(AssetId policyId' "eeee", 1)] + -- (BuildTxWith [(policyId', plutusWitness)]) let content = defaultTxBodyContent sbe