diff --git a/cardano-api/src/Cardano/Api/Internal/Fees.hs b/cardano-api/src/Cardano/Api/Internal/Fees.hs index d80a2bcb89..a2caf0a166 100644 --- a/cardano-api/src/Cardano/Api/Internal/Fees.hs +++ b/cardano-api/src/Cardano/Api/Internal/Fees.hs @@ -1542,7 +1542,8 @@ substituteExecutionUnits (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures BuildTx era))) mapScriptWitnessesProposals Nothing = return Nothing mapScriptWitnessesProposals (Just (Featured era txpp)) = do - let eSubstitutedExecutionUnits = + let unwitnessedTxpp = getUnwitnessedProposals txpp + eSubstitutedExecutionUnits = [ (proposal, updatedWitness) | (ix, proposal, scriptWitness) <- indexTxProposalProcedures txpp , let updatedWitness = substituteExecUnits ix scriptWitness @@ -1554,7 +1555,8 @@ substituteExecutionUnits Featured era $ conwayEraOnwardsConstraints era $ mkTxProposalProcedures $ - second Just <$> substitutedExecutionUnits + map (,Nothing) unwitnessedTxpp + <> (second Just <$> substitutedExecutionUnits) mapScriptWitnessesMinting :: TxMintValue BuildTx era @@ -1569,6 +1571,12 @@ substituteExecutionUnits final <- Map.fromListWith (<>) <$> traverseScriptWitnesses mappedScriptWitnesses pure $ TxMintValue w final + getUnwitnessedProposals + :: TxProposalProcedures BuildTx era -> [L.ProposalProcedure (ShelleyLedgerEra era)] + getUnwitnessedProposals TxProposalProceduresNone = [] + getUnwitnessedProposals (TxProposalProcedures omap) = + [pp | (pp, BuildTxWith Nothing) <- toList omap] + traverseScriptWitnesses :: [(a, Either (TxBodyErrorAutoBalance era) b)] -> Either (TxBodyErrorAutoBalance era) [(a, b)] 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 616140d075..42cf70925e 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 @@ -31,6 +31,7 @@ import qualified Cardano.Slotting.EpochInfo as CS import qualified Cardano.Slotting.Slot as CS import qualified Cardano.Slotting.Time as CS +import Data.Aeson (eitherDecodeStrict) import qualified Data.ByteString as B import Data.Default (def) import Data.Function @@ -324,8 +325,111 @@ prop_calcReturnAndTotalCollateral = H.withTests 400 . H.property $ do H.note_ "Check that collateral balance is equal to collateral in tx body" resTotCollValue === collBalance +-- | Regression test for: https://github.com/IntersectMBO/cardano-cli/issues/1073 +prop_ensure_gov_actions_are_preserved_by_autobalance :: Property +prop_ensure_gov_actions_are_preserved_by_autobalance = H.propertyOnce $ do + let ceo = ConwayEraOnwardsConway + sbe = convert ceo + + systemStart <- parseSystemStart "2021-09-01T00:00:00Z" + let epochInfo = LedgerEpochInfo $ CS.fixedEpochInfo (CS.EpochSize 100) (CS.mkSlotLength 1000) + + pparams <- + LedgerProtocolParameters + <$> H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json" + + -- one UTXO with an asset - the same we're minting in the transaction + let utxos = mkSimpleUTxOs sbe + txInputs = map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) . toList . M.keys . unUTxO $ utxos + address <- H.forAll (genAddressInEra sbe) + + anchorUrl <- H.evalEither $ eitherDecodeStrict "\"https://tinyurl.com/cardano-qa-anchor\"" + anchorDataHash <- + H.evalEither $ + eitherDecodeStrict "\"f08cc9640136b1ae47428f646a9b5aadc0045fafb5529ca3ba1723784e6f0750\"" + let anchor = + L.Anchor + { L.anchorUrl = anchorUrl + , L.anchorDataHash = anchorDataHash + } + proposalProcedure = + L.ProposalProcedure + { L.pProcDeposit = 100_000_000 + , L.pProcReturnAddr = + L.RewardAccount + { L.raNetwork = L.Testnet + , L.raCredential = + L.KeyHashObj (L.KeyHash{L.unKeyHash = "0b1b872f7953bccfc4245f3282b3363f3d19e9e001a5c41e307363d7"}) + } + , L.pProcGovAction = L.InfoAction + , L.pProcAnchor = anchor + } + + -- tx body content without an asset in TxOut + let content = + defaultTxBodyContent sbe + & setTxIns txInputs + & setTxProtocolParams (pure $ pure pparams) + & setTxProposalProcedures + ( pure $ + Featured + ConwayEraOnwardsConway + ( TxProposalProcedures + (fromList [(proposalProcedure, BuildTxWith Nothing)]) + ) + ) + + -- autobalanced body has assets and ADA in the change txout + (BalancedTxBody _ balancedTxBody _ _) <- + H.leftFail $ + makeTransactionBodyAutoBalance + sbe + systemStart + epochInfo + pparams + mempty + mempty + mempty + utxos + content + address + Nothing + + let balancedContent = getTxBodyContent balancedTxBody + Featured _ (TxProposalProcedures balancedProposalProcedureOMap) <- + H.evalMaybe $ txProposalProcedures balancedContent + let balancedProposalProcedureList = toList balancedProposalProcedureOMap + balancedProposalProcedureList === [(proposalProcedure, ViewTx)] + -- * Utilities +mkSimpleUTxOs :: ShelleyBasedEra ConwayEra -> UTxO ConwayEra +mkSimpleUTxOs sbe = + UTxO + [ + ( TxIn + "01f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53" + (TxIx 0) + , TxOut + ( AddressInEra + (ShelleyAddressInEra sbe) + ( ShelleyAddress + L.Testnet + ( L.KeyHashObj $ + L.KeyHash "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137" + ) + L.StakeRefNull + ) + ) + ( lovelaceToTxOutValue + sbe + 2_000_000_000 + ) + TxOutDatumNone + ReferenceScriptNone + ) + ] + loadPlutusWitness :: HasCallStack => MonadFail m @@ -465,4 +569,7 @@ tests = "makeTransactionBodyAutoBalance autobalances when deregistering certificates" prop_make_transaction_body_autobalance_when_deregistering_certs , testProperty "calcReturnAndTotalCollateral constraints hold" prop_calcReturnAndTotalCollateral + , testProperty + "Governance actions are preserved by autobalance" + prop_ensure_gov_actions_are_preserved_by_autobalance ]