Fix costs calculation for transaction with more than one certificates…

… with the same stake credential and script witness
IntersectMBO · Feb 3, 2025 · 48a74d3 · 48a74d3
1 parent 7146c85
commit 48a74d3
Show file tree

Hide file tree

Showing 4 changed files with 7 additions and 48 deletions.
diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal
@@ -212,7 +212,7 @@ library
     binary,
     bytestring,
     canonical-json,
-    cardano-api ^>=10.6,
+    cardano-api ^>=10.7,
     cardano-binary,
     cardano-crypto,
     cardano-crypto-class ^>=2.1.2,

diff --git a/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs b/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs
@@ -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
 
@@ -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 <-
@@ -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)

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
@@ -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
@@ -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
@@ -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)
@@ -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
 --

diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs
@@ -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 =