diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs index 2ccc99ba8c3..1571fb2eb4a 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs @@ -211,7 +211,9 @@ spec = do mkBasicTxBody & certsTxBodyL .~ SSeq.fromList - [UnRegTxCert stakeCred] + -- /~https://github.com/IntersectMBO/formal-ledger-specifications/issues/636 + -- we use this inplace of UnRegTxCert to make conformance-spec happy + [UnRegDepositTxCert stakeCred keyDeposit] & withdrawalsTxBodyL .~ Withdrawals ( Map.fromList @@ -476,6 +478,77 @@ spec = do expectNotRegistered cred expectNotDelegatedVote cred + describe "Delegate both stake and vote - separated out for conformance mismatch" $ + -- /~https://github.com/IntersectMBO/formal-ledger-specifications/issues/640 + -- TODO: Re-enable after issue is resolved, by removing this override + disableImpInitExpectLedgerRuleConformance $ do + it "Delegate, retire and re-register pool" $ do + expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL + cred <- KeyHashObj <$> freshKeyHash + poolKh <- freshKeyHash + rewardAccount <- registerRewardAccount + registerPool poolKh + drepCred <- KeyHashObj <$> registerDRep + + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL + .~ [ RegDepositDelegTxCert + cred + (DelegStakeVote poolKh (DRepCredential drepCred)) + expectedDeposit + ] + expectDelegatedToPool cred poolKh + expectDelegatedVote cred (DRepCredential drepCred) + + let poolLifetime = 2 + let poolExpiry = getsNES nesELL <&> \n -> addEpochInterval n $ EpochInterval poolLifetime + + poolExpiry >>= \pe -> + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe] + + -- when pool is re-registered after its expiration, all delegations are cleared + passNEpochs $ fromIntegral poolLifetime + expectNotDelegatedToPool cred + registerPoolWithRewardAccount poolKh rewardAccount + expectNotDelegatedToPool cred + -- the vote delegation is kept + expectDelegatedVote cred (DRepCredential drepCred) + + -- re-delegate + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL + .~ [ DelegTxCert + cred + (DelegStake poolKh) + ] + expectDelegatedToPool cred poolKh + + -- when pool is re-registered before its expiration, delegations are kept + poolExpiry >>= \pe -> + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe] + -- re-register the pool before the expiration time + passNEpochs $ fromIntegral poolLifetime - 1 + registerPoolWithRewardAccount poolKh rewardAccount + expectDelegatedToPool cred poolKh + passNEpochs 2 + expectDelegatedToPool cred poolKh + + -- when pool is retired and re-registered in the same transaction, delegations are kept + pps <- poolParams poolKh rewardAccount + poolExpiry >>= \pe -> + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe, RegPoolTxCert pps] + + expectDelegatedToPool cred poolKh + passNEpochs $ fromIntegral poolLifetime + expectDelegatedToPool cred poolKh describe "Delegate both stake and vote" $ do it "Delegate and unregister credentials" $ do expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL @@ -531,74 +604,6 @@ spec = do .~ [DelegTxCert cred (DelegStake poolKh')] expectDelegatedToPool cred poolKh' expectDelegatedVote cred (DRepCredential drepCred) - - it "Delegate, retire and re-register pool" $ do - expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL - cred <- KeyHashObj <$> freshKeyHash - poolKh <- freshKeyHash - rewardAccount <- registerRewardAccount - registerPool poolKh - drepCred <- KeyHashObj <$> registerDRep - - submitTx_ $ - mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ [ RegDepositDelegTxCert - cred - (DelegStakeVote poolKh (DRepCredential drepCred)) - expectedDeposit - ] - expectDelegatedToPool cred poolKh - expectDelegatedVote cred (DRepCredential drepCred) - - let poolLifetime = 2 - let poolExpiry = getsNES nesELL <&> \n -> addEpochInterval n $ EpochInterval poolLifetime - - poolExpiry >>= \pe -> - submitTx_ $ - mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe] - - -- when pool is re-registered after its expiration, all delegations are cleared - passNEpochs $ fromIntegral poolLifetime - expectNotDelegatedToPool cred - registerPoolWithRewardAccount poolKh rewardAccount - expectNotDelegatedToPool cred - -- the vote delegation is kept - expectDelegatedVote cred (DRepCredential drepCred) - - -- re-delegate - submitTx_ $ - mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ [ DelegTxCert - cred - (DelegStake poolKh) - ] - expectDelegatedToPool cred poolKh - - -- when pool is re-registered before its expiration, delegations are kept - poolExpiry >>= \pe -> - submitTx_ $ - mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe] - -- re-register the pool before the expiration time - passNEpochs $ fromIntegral poolLifetime - 1 - registerPoolWithRewardAccount poolKh rewardAccount - expectDelegatedToPool cred poolKh - passNEpochs 2 - expectDelegatedToPool cred poolKh - - -- when pool is retired and re-registered in the same transaction, delegations are kept - pps <- poolParams poolKh rewardAccount - poolExpiry >>= \pe -> - submitTx_ $ - mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe, RegPoolTxCert pps] - - expectDelegatedToPool cred poolKh - passNEpochs $ fromIntegral poolLifetime - expectDelegatedToPool cred poolKh where expectRegistered cred = do umap <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . dsUnifiedL diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index d61b5d29606..2d133d5423e 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -18,6 +18,10 @@ * `FromByronTranslationContext` * `GenesisDelegCert`, `MIRTarget`, `MIRCert`, `ShelleyDelegCert` +### `testlib` + +* Add `disableImpInitExpectLedgerRuleConformance`. #4821 + ## 1.15.0.0 * Change param of `PoolRank.desirability` to `Word16` diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index 3f771858e6e..5dc01d04b3c 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -101,6 +101,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( impSetSeed, modifyImpInitProtVer, modifyImpInitExpectLedgerRuleConformance, + disableImpInitExpectLedgerRuleConformance, -- * Logging Doc, @@ -644,6 +645,12 @@ modifyImpInitExpectLedgerRuleConformance f = & iteExpectLedgerRuleConformanceL .~ f } +disableImpInitExpectLedgerRuleConformance :: + SpecWith (ImpInit (LedgerSpec era)) -> + SpecWith (ImpInit (LedgerSpec era)) +disableImpInitExpectLedgerRuleConformance = + modifyImpInitExpectLedgerRuleConformance $ \_ _ _ _ _ -> pure () + impLedgerEnv :: EraGov era => NewEpochState era -> ImpTestM era (LedgerEnv era) impLedgerEnv nes = do slotNo <- gets impLastTick diff --git a/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs b/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs index cece9b628cf..7580619016c 100644 --- a/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs +++ b/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs @@ -153,7 +153,7 @@ spec = describe "Conway Imp conformance" $ do describe "BBODY" Bbody.spec describe "CERTS" Certs.spec - xdescribe "DELEG" Deleg.spec + describe "DELEG" Deleg.spec xdescribe "ENACT" Enact.spec xdescribe "EPOCH" Epoch.spec xdescribe "GOV" Gov.spec