Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix costs calculation for transaction with more than one certificates with the same stake credential and script witness #1028

Merged
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion cabal.project
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ repository cardano-haskell-packages
-- you need to run if you change them
index-state:
, hackage.haskell.org 2024-12-24T12:56:48Z
, cardano-haskell-packages 2025-01-15T09:59:24Z
, cardano-haskell-packages 2025-02-01T07:12:29Z

packages:
cardano-cli
Expand Down
2 changes: 1 addition & 1 deletion cardano-cli/cardano-cli.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -212,7 +212,7 @@ library
binary,
bytestring,
canonical-json,
cardano-api ^>=10.6,
cardano-api ^>=10.8,
cardano-binary,
cardano-crypto,
cardano-crypto-class ^>=2.1.2,
Expand Down
20 changes: 1 addition & 19 deletions cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs
Original file line number Diff line number Diff line change
Expand Up @@ -39,7 +39,6 @@ import Data.Function
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Text (Text)
import GHC.Exts (IsList (..))
import Options.Applicative
import qualified Options.Applicative as Opt

Expand Down Expand Up @@ -300,7 +299,7 @@ runCompatibleTransactionCmd
validatedRefInputs <-
liftEither . first CompatibleTxCmdError . validateTxInsReference $
certsRefInputs <> votesRefInputs <> proposalsRefInputs
let txCerts = convertCertificates certsAndMaybeScriptWits
let txCerts = mkTxCertificates sbe certsAndMaybeScriptWits

-- this body is only for witnesses
apiTxBody <-
Expand Down Expand Up @@ -331,23 +330,6 @@ runCompatibleTransactionCmd
newExceptT $
writeTxFileTextEnvelopeCddl sbe outputFp signedTx
where
convertCertificates
:: [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
-> TxCertificates BuildTx era
convertCertificates certsAndScriptWitnesses =
TxCertificates sbe certs $ BuildTxWith reqWits
where
certs = map fst certsAndScriptWitnesses
reqWits = fromList $ mapMaybe convert' certsAndScriptWitnesses
convert'
:: (Certificate era, Maybe (ScriptWitness WitCtxStake era))
-> Maybe (StakeCredential, Witness WitCtxStake era)
convert' (cert, mScriptWitnessFiles) = do
sCred <- selectStakeCredentialWitness cert
Just . (sCred,) $ case mScriptWitnessFiles of
Just sWit -> ScriptWitness ScriptWitnessForStakeAddr sWit
Nothing -> KeyWitness KeyWitnessForStakeAddr

validateTxInsReference
:: [TxIn]
-> Either TxCmdError (TxInsReference era)
Expand Down
31 changes: 4 additions & 27 deletions cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
Original file line number Diff line number Diff line change
Expand Up @@ -82,7 +82,7 @@ import Data.Function ((&))
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList)
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
Expand Down Expand Up @@ -954,7 +954,7 @@ constructTxBodyContent
& setTxExtraKeyWits validatedReqSigners
& setTxProtocolParams (BuildTxWith $ LedgerProtocolParameters <$> mPparams)
& setTxWithdrawals (TxWithdrawals sbe $ map convertWithdrawals withdrawals)
& setTxCertificates (convertCertificates sbe certsAndMaybeScriptWits)
& setTxCertificates (mkTxCertificates sbe certsAndMaybeScriptWits)
& setTxUpdateProposal txUpdateProposal
& setTxMintValue validatedMintValue
& setTxScriptValidity validatedTxScriptValidity
Expand Down Expand Up @@ -1071,15 +1071,11 @@ runTxBuild
testEquality era nodeEra
& hoistMaybe (TxCmdTxNodeEraMismatchError $ NodeEraMismatchError era nodeEra)

let certs =
case convertCertificates sbe certsAndMaybeScriptWits of
TxCertificates _ cs _ -> cs
_ -> []

let certsToQuery = fst <$> certsAndMaybeScriptWits
(txEraUtxo, pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits, _) <-
lift
( executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip $
queryStateForBalancedTx nodeEra allTxInputs certs
queryStateForBalancedTx nodeEra allTxInputs certsToQuery
)
& onLeft (left . TxCmdQueryConvenienceError . AcqFailure)
& onLeft (left . TxCmdQueryConvenienceError)
Expand Down Expand Up @@ -1140,25 +1136,6 @@ runTxBuild

return balancedTxBody

convertCertificates
:: ()
=> ShelleyBasedEra era
-> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
-> TxCertificates BuildTx era
convertCertificates sbe certsAndScriptWitnesses =
TxCertificates sbe certs $ BuildTxWith reqWits
where
certs = map fst certsAndScriptWitnesses
reqWits = fromList $ mapMaybe convertCert certsAndScriptWitnesses
convertCert
:: (Certificate era, Maybe (ScriptWitness WitCtxStake era))
-> Maybe (StakeCredential, Witness WitCtxStake era)
convertCert (cert, mScriptWitnessFiles) = do
sCred <- selectStakeCredentialWitness cert
Just $ case mScriptWitnessFiles of
Just sWit -> (sCred, ScriptWitness ScriptWitnessForStakeAddr sWit)
Nothing -> (sCred, KeyWitness KeyWitnessForStakeAddr)

-- ----------------------------------------------------------------------------
-- Transaction body validation and conversion
--
Expand Down
62 changes: 31 additions & 31 deletions cardano-cli/src/Cardano/CLI/Json/Friendly.hs
Original file line number Diff line number Diff line change
Expand Up @@ -223,38 +223,38 @@ friendlyTxBodyImpl era tb = do
, "withdrawals" .= friendlyWithdrawals txWithdrawals
]
++ ( monoidForEraInEon @AlonzoEraOnwards
era
(`getScriptWitnessDetails` tb)
era
(`getScriptWitnessDetails` tb)
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
( \cOnwards ->
conwayEraOnwardsConstraints cOnwards $
case txProposalProcedures of
Nothing -> []
Just (Featured _ TxProposalProceduresNone) -> []
Just (Featured _ pp) -> do
let lProposals = toList $ convProposalProcedures pp
["governance actions" .= (friendlyLedgerProposals cOnwards lProposals)]
)
era
( \cOnwards ->
conwayEraOnwardsConstraints cOnwards $
case txProposalProcedures of
Nothing -> []
Just (Featured _ TxProposalProceduresNone) -> []
Just (Featured _ pp) -> do
let lProposals = toList $ convProposalProcedures pp
["governance actions" .= (friendlyLedgerProposals cOnwards lProposals)]
)
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
( \cOnwards ->
case txVotingProcedures of
Nothing -> []
Just (Featured _ TxVotingProceduresNone) -> []
Just (Featured _ (TxVotingProcedures votes _witnesses)) ->
["voters" .= friendlyVotingProcedures cOnwards votes]
)
era
( \cOnwards ->
case txVotingProcedures of
Nothing -> []
Just (Featured _ TxVotingProceduresNone) -> []
Just (Featured _ (TxVotingProcedures votes _witnesses)) ->
["voters" .= friendlyVotingProcedures cOnwards votes]
)
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
(const ["currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue)])
era
(const ["currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue)])
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
(const ["treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation)])
era
(const ["treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation)])
)
)
where
Expand Down Expand Up @@ -545,9 +545,9 @@ friendlyUpdateProposal = \case
[ "epoch" .= epoch
, "updates"
.= [ object
[ "genesis key hash" .= genesisKeyHash
, "update" .= friendlyProtocolParametersUpdate parameterUpdate
]
[ "genesis key hash" .= genesisKeyHash
, "update" .= friendlyProtocolParametersUpdate parameterUpdate
]
| (genesisKeyHash, parameterUpdate) <- Map.assocs parameterUpdates
]
]
Expand Down Expand Up @@ -626,7 +626,7 @@ friendlyPrices ExecutionUnitPrices{priceExecutionMemory, priceExecutionSteps} =
friendlyCertificates :: ShelleyBasedEra era -> TxCertificates ViewTx era -> Aeson.Value
friendlyCertificates sbe = \case
TxCertificatesNone -> Null
TxCertificates _ cs _ -> array $ map (friendlyCertificate sbe) cs
TxCertificates _ cs -> array $ map (friendlyCertificate sbe . fst) $ toList cs

friendlyCertificate :: ShelleyBasedEra era -> Certificate era -> Aeson.Value
friendlyCertificate sbe =
Expand Down Expand Up @@ -802,9 +802,9 @@ friendlyMirTarget sbe = \case
L.StakeAddressesMIR addresses ->
"target stake addresses"
.= [ object
[ friendlyStakeCredential credential
, "amount" .= friendlyLovelace (L.Coin 0 `L.addDeltaCoin` lovelace)
]
[ friendlyStakeCredential credential
, "amount" .= friendlyLovelace (L.Coin 0 `L.addDeltaCoin` lovelace)
]
| (credential, lovelace) <- shelleyBasedEraConstraints sbe $ toList addresses
]
L.SendToOppositePotMIR amount -> "MIR amount" .= friendlyLovelace amount
Expand Down
6 changes: 3 additions & 3 deletions flake.lock

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading