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.

Sign up for GitHub

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 missing redeemers in certificate deregistration #268

Merged
merged 1 commit into from
Sep 26, 2023
Merged

Fix missing redeemers in certificate deregistration #268

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
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
42 changes: 26 additions & 16 deletions cardano-api/internal/Cardano/Api/Certificate.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Copy link
Contributor

@Jimbo4350 Jimbo4350 Sep 26, 2023 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We need to think about our StakeCredential type because we are coercing from the keyrole Ledger.StakePool. We really should try to avoid breaking the ledger interface even if we think it looks "ok" to do so. The key role at the moment has no semantic meaning, it's just a tag, but we don't want to get bitten unexpectedly by this in the future because it's not guaranteed that this won't change.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

follow up: #341

Ledger.RetirePoolTxCert poolId _ ->
Just . Ledger.coerceKeyRole $ Ledger.KeyHashObj poolId
_ -> Nothing
Copy link
Contributor

@Jimbo4350 Jimbo4350 Sep 26, 2023 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Let's handle all of the certificates for completeness

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

follow up: #277


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
Expand Down
23 changes: 10 additions & 13 deletions cardano-api/internal/Cardano/Api/Fees.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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,
Expand All @@ -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
Expand Down Expand Up @@ -1276,19 +1274,18 @@ 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))]
mappedScriptWitnesses =
[ (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
Expand Down
11 changes: 6 additions & 5 deletions cardano-api/internal/Cardano/Api/ReexposeLedger.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,7 @@ module Cardano.Api.ReexposeLedger
, pattern ResignCommitteeColdTxCert
, pattern RegTxCert
, pattern UnRegTxCert
, pattern DelegStakeTxCert
, pattern RegDepositDelegTxCert
, pattern RegDRepTxCert

Expand Down Expand Up @@ -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,
Expand Down
8 changes: 5 additions & 3 deletions cardano-api/internal/Cardano/Api/TxBody.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -3508,6 +3509,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage
txAuxData :: Maybe (L.TxAuxData StandardBabbage)
txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts


makeShelleyTransactionBody sbe@ShelleyBasedEraConway
txbodycontent@TxBodyContent {
txIns,
Expand Down Expand Up @@ -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).
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)]
Expand Down