From 2fa9f38da6ba53bee540cff30753beb9aca9c4e4 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Mon, 25 Sep 2023 11:03:30 +0200 Subject: [PATCH] input-output-hk/cardano-cli#299 Fix 'MissingRedeemers' error --- .../internal/Cardano/Api/Certificate.hs | 42 ++++++++++++------- cardano-api/internal/Cardano/Api/Fees.hs | 23 +++++----- .../internal/Cardano/Api/ReexposeLedger.hs | 11 ++--- cardano-api/internal/Cardano/Api/TxBody.hs | 8 ++-- 4 files changed, 47 insertions(+), 37 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 62656444b9..54779d2daf 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -664,22 +664,32 @@ makeStakeAddressAndDRepDelegationCertificate w cred delegatee deposit = -- selectStakeCredential - :: ShelleyBasedEra era -> Certificate era -> Maybe StakeCredential -selectStakeCredential sbe cert = - case cert of - ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert (Ledger.ShelleyDelegCert stakecred _)) - -> Just $ shelleyBasedEraConstraints sbe $ fromShelleyStakeCredential stakecred - ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool (Ledger.RegPool poolParams)) - -> let poolCred = Ledger.KeyHashObj $ Ledger.ppId poolParams - in Just $ shelleyBasedEraConstraints sbe $ fromShelleyStakeCredential $ Ledger.coerceKeyRole poolCred - - ConwayCertificate _ (Ledger.ConwayTxCertDeleg (Ledger.ConwayRegCert stakeCred _)) - -> Just $ shelleyBasedEraConstraints sbe $ fromShelleyStakeCredential stakeCred - ConwayCertificate _ (Ledger.ConwayTxCertPool (Ledger.RegPool poolParams)) - -> let poolCred = Ledger.KeyHashObj $ Ledger.ppId poolParams - in Just $ shelleyBasedEraConstraints sbe $ fromShelleyStakeCredential $ Ledger.coerceKeyRole poolCred - - _ -> Nothing + :: Certificate era -> Maybe StakeCredential +selectStakeCredential = fmap fromShelleyStakeCredential . \case + ShelleyRelatedCertificate stbEra shelleyCert -> shelleyToBabbageEraConstraints stbEra $ + case shelleyCert of + Ledger.RegTxCert sCred -> Just sCred + Ledger.UnRegTxCert sCred -> Just sCred + Ledger.DelegStakeTxCert sCred _ -> Just sCred + Ledger.RegPoolTxCert poolParams -> + Just . Ledger.coerceKeyRole . Ledger.KeyHashObj $ Ledger.ppId poolParams + Ledger.RetirePoolTxCert poolId _ -> + Just . Ledger.coerceKeyRole $ Ledger.KeyHashObj poolId + _ -> Nothing + + ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $ + case conwayCert of + Ledger.RegPoolTxCert poolParams -> + Just . Ledger.coerceKeyRole . Ledger.KeyHashObj $ Ledger.ppId poolParams + Ledger.RetirePoolTxCert kh _ -> + Just . Ledger.coerceKeyRole $ Ledger.KeyHashObj kh + Ledger.RegTxCert sCred -> Just sCred + Ledger.UnRegTxCert sCred -> Just sCred + Ledger.RegDepositTxCert sCred _ -> Just sCred + Ledger.UnRegDepositTxCert sCred _ -> Just sCred + Ledger.DelegTxCert sCred _ -> Just sCred + Ledger.RegDepositDelegTxCert sCred _ _ -> Just sCred + _ -> Nothing filterUnRegCreds :: ShelleyBasedEra era -> Certificate era -> Maybe StakeCredential diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index dc2110eb21..8039a1a5ce 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -954,7 +954,7 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters failures exUnitsMap' - txbodycontent1 <- substituteExecutionUnits sbe exUnitsMap' txbodycontent + txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent -- Make a txbody that we will use for calculating the fees. For the purpose -- of fees we just need to make a txbody of the right size in bytes. We do @@ -1177,12 +1177,11 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters (txOutInAnyEra txout) minUTxO -substituteExecutionUnits :: ShelleyBasedEra era - -> Map ScriptWitnessIndex ExecutionUnits +substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits -> TxBodyContent BuildTx era -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era) -substituteExecutionUnits sbe exUnitsMap = - mapTxScriptWitnesses f sbe +substituteExecutionUnits exUnitsMap = + mapTxScriptWitnesses f where f :: ScriptWitnessIndex -> ScriptWitness witctx era @@ -1199,10 +1198,9 @@ mapTxScriptWitnesses (forall witctx. ScriptWitnessIndex -> ScriptWitness witctx era -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)) - -> ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era) -mapTxScriptWitnesses f sbe txbodycontent@TxBodyContent { +mapTxScriptWitnesses f txbodycontent@TxBodyContent { txIns, txWithdrawals, txCertificates, @@ -1211,7 +1209,7 @@ mapTxScriptWitnesses f sbe txbodycontent@TxBodyContent { mappedTxIns <- mapScriptWitnessesTxIns txIns mappedWithdrawals <- mapScriptWitnessesWithdrawals txWithdrawals mappedMintedVals <- mapScriptWitnessesMinting txMintValue - mappedTxCertificates <- mapScriptWitnessesCertificates sbe txCertificates + mappedTxCertificates <- mapScriptWitnessesCertificates txCertificates Right $ txbodycontent & setTxIns mappedTxIns @@ -1276,11 +1274,10 @@ mapTxScriptWitnesses f sbe txbodycontent@TxBodyContent { adjustWitness g (ScriptWitness ctx witness') = ScriptWitness ctx <$> g witness' mapScriptWitnessesCertificates - :: ShelleyBasedEra era - -> TxCertificates BuildTx era + :: TxCertificates BuildTx era -> Either TxBodyErrorAutoBalance (TxCertificates BuildTx era) - mapScriptWitnessesCertificates _ TxCertificatesNone = Right TxCertificatesNone - mapScriptWitnessesCertificates sbe' (TxCertificates supported certs + mapScriptWitnessesCertificates TxCertificatesNone = Right TxCertificatesNone + mapScriptWitnessesCertificates (TxCertificates supported certs (BuildTxWith witnesses)) = let mappedScriptWitnesses :: [(StakeCredential, Either TxBodyErrorAutoBalance (Witness WitCtxStake era))] @@ -1288,7 +1285,7 @@ mapTxScriptWitnesses f sbe txbodycontent@TxBodyContent { [ (stakecred, ScriptWitness ctx <$> witness') -- The certs are indexed in list order | (ix, cert) <- zip [0..] certs - , stakecred <- maybeToList (selectStakeCredential sbe' cert) + , stakecred <- maybeToList (selectStakeCredential cert) , ScriptWitness ctx witness <- maybeToList (Map.lookup stakecred witnesses) , let witness' = f (ScriptWitnessIndexCertificate ix) witness diff --git a/cardano-api/internal/Cardano/Api/ReexposeLedger.hs b/cardano-api/internal/Cardano/Api/ReexposeLedger.hs index b5e57e1cfc..99ad760ebc 100644 --- a/cardano-api/internal/Cardano/Api/ReexposeLedger.hs +++ b/cardano-api/internal/Cardano/Api/ReexposeLedger.hs @@ -27,6 +27,7 @@ module Cardano.Api.ReexposeLedger , pattern ResignCommitteeColdTxCert , pattern RegTxCert , pattern UnRegTxCert + , pattern DelegStakeTxCert , pattern RegDepositDelegTxCert , pattern RegDRepTxCert @@ -91,11 +92,11 @@ module Cardano.Api.ReexposeLedger import Cardano.Crypto.Hash.Class (hashFromBytes, hashToBytes) import Cardano.Ledger.Alonzo.Core (CoinPerWord (..)) import Cardano.Ledger.Alonzo.Scripts (Prices (..)) -import Cardano.Ledger.Api.Tx.Cert (pattern AuthCommitteeHotKeyTxCert, pattern DelegTxCert, - pattern RegDRepTxCert, pattern RegDepositDelegTxCert, pattern RegDepositTxCert, - pattern RegPoolTxCert, pattern RegTxCert, pattern ResignCommitteeColdTxCert, - pattern RetirePoolTxCert, pattern UnRegDRepTxCert, pattern UnRegDepositTxCert, - pattern UnRegTxCert) +import Cardano.Ledger.Api.Tx.Cert (pattern AuthCommitteeHotKeyTxCert, + pattern DelegStakeTxCert, pattern DelegTxCert, pattern RegDRepTxCert, + pattern RegDepositDelegTxCert, pattern RegDepositTxCert, pattern RegPoolTxCert, + pattern RegTxCert, pattern ResignCommitteeColdTxCert, pattern RetirePoolTxCert, + pattern UnRegDRepTxCert, pattern UnRegDepositTxCert, pattern UnRegTxCert) import Cardano.Ledger.Babbage.Core (CoinPerByte (..)) import Cardano.Ledger.BaseTypes (DnsName, Network (..), StrictMaybe (..), Url, boundRational, dnsToText, maybeToStrictMaybe, portToWord16, strictMaybeToMaybe, diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index a0a4675de5..64f9b7ed3e 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -274,6 +274,7 @@ import qualified Text.Parsec as Parsec import Text.Parsec (()) import qualified Text.Parsec.String as Parsec + -- | Indicates whether a script is expected to fail or pass validation. data ScriptValidity = ScriptInvalid -- ^ Script is expected to fail validation. @@ -3508,6 +3509,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage txAuxData :: Maybe (L.TxAuxData StandardBabbage) txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts + makeShelleyTransactionBody sbe@ShelleyBasedEraConway txbodycontent@TxBodyContent { txIns, @@ -3609,7 +3611,6 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts - -- | A variant of 'toShelleyTxOutAny that is used only internally to this module -- that works with a 'TxOut' in any context (including CtxTx) by ignoring -- embedded datums (taking only their hash). @@ -3675,6 +3676,8 @@ toBabbageTxOutDatum' (TxOutDatumInline _ sd) = scriptDataToInlineDatum sd data AnyScriptWitness era where AnyScriptWitness :: ScriptWitness witctx era -> AnyScriptWitness era +deriving instance Show (AnyScriptWitness era) + -- | Identify the location of a 'ScriptWitness' within the context of a -- 'TxBody'. These are indexes of the objects within the transaction that -- need or can use script witnesses: inputs, minted assets, withdrawals and @@ -3791,11 +3794,10 @@ collectTxBodyScriptWitnesses sbe TxBodyContent { -- The certs are indexed in list order | (ix, cert) <- zip [0..] certs , ScriptWitness _ witness <- maybeToList $ do - stakecred <- shelleyBasedEraConstraints sbe $ selectStakeCredential sbe cert + stakecred <- shelleyBasedEraConstraints sbe $ selectStakeCredential cert Map.lookup stakecred witnesses ] - scriptWitnessesMinting :: TxMintValue BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)]