Merge pull request #1028 from IntersectMBO/mgalazyn/fix/correct-certificates-representation

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

Author: CarlosLopezDeLara

cabal.project

@@ -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

cardano-cli/cardano-cli.cabal

@@ -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,

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)

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
 --

cardano-cli/src/Cardano/CLI/Json/Friendly.hs

@@ -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
@@ -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
              ]
       ]
@@ -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 =
@@ -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