Skip to content

Commit d71d792

Browse files
SoupstrawSoupstraw
committed
Added a test
1 parent 3665be1 commit d71d792

File tree

2 files changed

+146
-58
lines changed

2 files changed

+146
-58
lines changed

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs‎

Lines changed: 85 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,14 +5,21 @@
55
{-# LANGUAGE OverloadedStrings #-}
66
{-# LANGUAGE RankNTypes #-}
77
{-# LANGUAGE ScopedTypeVariables #-}
8+
{-# LANGUAGE TypeApplications #-}
89
{-# LANGUAGE TypeFamilies #-}
910

1011
module Test.Cardano.Ledger.Conway.Imp.DelegSpec (
1112
spec,
1213
) where
1314

1415
import Cardano.Ledger.Address (RewardAccount (..))
15-
import Cardano.Ledger.BaseTypes (EpochInterval (..), StrictMaybe (..), addEpochInterval)
16+
import Cardano.Ledger.BaseTypes (
17+
EpochInterval (..),
18+
ProtVer (..),
19+
StrictMaybe (..),
20+
addEpochInterval,
21+
natVersion,
22+
)
1623
import Cardano.Ledger.Coin (Coin (..))
1724
import Cardano.Ledger.Conway.Core
1825
import Cardano.Ledger.Conway.Governance
@@ -477,6 +484,83 @@ spec = do
477484
.~ [UnRegDepositTxCert cred expectedDeposit]
478485
expectNotRegistered cred
479486
expectNotDelegatedVote cred
487+
disableImpInitExpectLedgerRuleConformance $
488+
it "Delegate vote and unregister after hardfork" $ do
489+
let
490+
bootstrapVer = ProtVer (natVersion @9) 0
491+
setProtVer pv = modifyNES $ nesEsL . curPParamsEpochStateL . ppProtocolVersionL .~ pv
492+
initialProtVer <- getProtVer
493+
(_, ccCred, _) <- impAnn "Set up a committee" $ do
494+
-- Temporarily set protver to 10 to elect a committee
495+
setProtVer $ ProtVer (natVersion @10) 0
496+
res <- electBasicCommittee
497+
setProtVer initialProtVer
498+
pure res
499+
(khSPO, _, _) <- setupPoolWithStake $ Coin 10_000_000
500+
-- Using an irrefutable pattern here to prevent evaluation of tuple
501+
-- unless we actually need a value from it
502+
~(drepCred, _, _) <-
503+
if initialProtVer > bootstrapVer
504+
then setupSingleDRep 100_000_000
505+
else pure $ error "drepCred should not be accessed before protver 10"
506+
passNEpochs 3
507+
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
508+
cred <- KeyHashObj <$> freshKeyHash
509+
submitTx_ $
510+
mkBasicTx mkBasicTxBody
511+
& bodyTxL . certsTxBodyL
512+
.~ [RegDepositDelegTxCert cred (DelegVote DRepAlwaysAbstain) expectedDeposit]
513+
registerAndRetirePoolToMakeReward cred
514+
expectRegistered cred
515+
expectDelegatedVote cred DRepAlwaysAbstain
516+
impAnn "Version should be unchanged" $
517+
getProtVer `shouldReturn` initialProtVer
518+
let nextVer = majorFollow initialProtVer
519+
hfGaid <- submitGovAction $ HardForkInitiation SNothing nextVer
520+
submitVote_ VoteYes (StakePoolVoter khSPO) hfGaid
521+
submitVote_ VoteYes (CommitteeVoter ccCred) hfGaid
522+
when (initialProtVer > bootstrapVer) $
523+
submitVote_ VoteYes (DRepVoter drepCred) hfGaid
524+
passNEpochs 3
525+
logRatificationChecks hfGaid
526+
impAnn "Version should be bumped" $
527+
getProtVer `shouldReturn` nextVer
528+
withdrawalAmount <- getsPParams ppPoolDepositL
529+
rewardAccount <- getRewardAccountFor cred
530+
submitTx_ $
531+
mkBasicTx mkBasicTxBody
532+
& bodyTxL . certsTxBodyL .~ [UnRegTxCert cred]
533+
& bodyTxL . withdrawalsTxBodyL
534+
.~ Withdrawals (Map.singleton rewardAccount withdrawalAmount)
535+
expectNotRegistered cred
536+
expectNotDelegatedVote cred
537+
it "Delegate vote and undelegate after delegating to some stake pools" $ do
538+
(khSPO, _, _) <- setupPoolWithStake $ Coin 1_000_000
539+
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
540+
cred <- KeyHashObj <$> freshKeyHash
541+
submitTx_ $
542+
mkBasicTx mkBasicTxBody
543+
& bodyTxL . certsTxBodyL
544+
.~ [RegDepositDelegTxCert cred (DelegVote DRepAlwaysAbstain) expectedDeposit]
545+
registerAndRetirePoolToMakeReward cred
546+
expectRegistered cred
547+
expectDelegatedVote cred DRepAlwaysAbstain
548+
forM_ @[] [1 .. 3 :: Int] $ \_ -> do
549+
submitTx_ $
550+
mkBasicTx mkBasicTxBody
551+
& bodyTxL . certsTxBodyL
552+
.~ [DelegTxCert cred (DelegStake khSPO)]
553+
passNEpochs 3
554+
withdrawalAmount <- getsPParams ppPoolDepositL
555+
rewardAccount <- getRewardAccountFor cred
556+
submitTx_ $
557+
mkBasicTx mkBasicTxBody
558+
& bodyTxL . certsTxBodyL
559+
.~ [UnRegTxCert cred]
560+
& bodyTxL . withdrawalsTxBodyL
561+
.~ Withdrawals (Map.singleton rewardAccount withdrawalAmount)
562+
expectNotRegistered cred
563+
expectNotDelegatedVote cred
480564

481565
describe "Delegate both stake and vote - separated out for conformance mismatch" $
482566
-- https://github.com/IntersectMBO/formal-ledger-specifications/issues/640

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs‎

Lines changed: 61 additions & 57 deletions
Original file line numberDiff line numberDiff line change
@@ -213,6 +213,7 @@ import Data.Maybe (fromJust, fromMaybe, isJust)
213213
import Data.Sequence.Strict (StrictSeq (..))
214214
import qualified Data.Sequence.Strict as SSeq
215215
import qualified Data.Set as Set
216+
import qualified Data.Text as T
216217
import Data.Tree
217218
import qualified GHC.Exts as GHC (fromList)
218219
import Lens.Micro
@@ -1151,63 +1152,66 @@ logRatificationChecks ::
11511152
GovActionId ->
11521153
ImpTestM era ()
11531154
logRatificationChecks gaId = do
1154-
gas@GovActionState {gasCommitteeVotes, gasDRepVotes} <- getGovActionState gaId
1155-
let govAction = gasAction gas
1156-
ens@EnactState {..} <- getEnactState
1157-
committee <- getsNES $ nesEsL . epochStateGovStateL . committeeGovStateL
1158-
ratEnv@RatifyEnv {reCurrentEpoch} <- getRatifyEnv
1159-
let ratSt = RatifyState ens mempty mempty False
1160-
curTreasury <- getsNES treasuryL
1161-
currentEpoch <- getsNES nesELL
1162-
pv <- getProtVer
1163-
let
1164-
members = foldMap' committeeMembers committee
1165-
committeeState = reCommitteeState ratEnv
1166-
curPParams <- getsNES $ nesEsL . epochStateGovStateL . curPParamsGovStateL
1167-
logDoc $
1168-
tableDoc
1169-
(Just "RATIFICATION CHECKS")
1170-
[ ("prevActionAsExpected:", viaShow $ prevActionAsExpected gas ensPrevGovActionIds)
1171-
, ("validCommitteeTerm:", viaShow $ validCommitteeTerm govAction curPParams currentEpoch)
1172-
, ("notDelayed:", "??")
1173-
, ("withdrawalCanWithdraw:", viaShow $ withdrawalCanWithdraw govAction curTreasury)
1174-
,
1175-
( "committeeAccepted:"
1176-
, hsep
1177-
[ viaShow $ committeeAccepted ratEnv ratSt gas
1178-
, "["
1179-
, "To Pass:"
1180-
, viaShow $ committeeAcceptedRatio members gasCommitteeVotes committeeState currentEpoch
1181-
, ">="
1182-
, viaShow $ votingCommitteeThreshold reCurrentEpoch ratSt committeeState (gasAction gas)
1183-
, "]"
1184-
]
1185-
)
1186-
,
1187-
( "spoAccepted:"
1188-
, hsep
1189-
[ viaShow $ spoAccepted ratEnv ratSt gas
1190-
, "["
1191-
, "To Pass:"
1192-
, viaShow $ spoAcceptedRatio ratEnv gas pv
1193-
, ">="
1194-
, viaShow $ votingStakePoolThreshold ratSt (gasAction gas)
1195-
, "]"
1196-
]
1197-
)
1198-
,
1199-
( "dRepAccepted:"
1200-
, hsep
1201-
[ viaShow $ dRepAccepted ratEnv ratSt gas
1202-
, "["
1203-
, "To Pass:"
1204-
, viaShow $ dRepAcceptedRatio ratEnv gasDRepVotes (gasAction gas)
1205-
, ">="
1206-
, viaShow $ votingDRepThreshold ratSt (gasAction gas)
1207-
, "]"
1208-
]
1209-
)
1210-
]
1155+
mbyGas <- lookupGovActionState gaId
1156+
case mbyGas of
1157+
Nothing -> logText $ "Goveranance action not found: " <> T.pack (show gaId)
1158+
Just gas@GovActionState {gasCommitteeVotes, gasDRepVotes} -> do
1159+
let govAction = gasAction gas
1160+
ens@EnactState {..} <- getEnactState
1161+
committee <- getsNES $ nesEsL . epochStateGovStateL . committeeGovStateL
1162+
ratEnv@RatifyEnv {reCurrentEpoch} <- getRatifyEnv
1163+
let ratSt = RatifyState ens mempty mempty False
1164+
curTreasury <- getsNES treasuryL
1165+
currentEpoch <- getsNES nesELL
1166+
pv <- getProtVer
1167+
let
1168+
members = foldMap' committeeMembers committee
1169+
committeeState = reCommitteeState ratEnv
1170+
curPParams <- getsNES $ nesEsL . epochStateGovStateL . curPParamsGovStateL
1171+
logDoc $
1172+
tableDoc
1173+
(Just "RATIFICATION CHECKS")
1174+
[ ("prevActionAsExpected:", viaShow $ prevActionAsExpected gas ensPrevGovActionIds)
1175+
, ("validCommitteeTerm:", viaShow $ validCommitteeTerm govAction curPParams currentEpoch)
1176+
, ("notDelayed:", "??")
1177+
, ("withdrawalCanWithdraw:", viaShow $ withdrawalCanWithdraw govAction curTreasury)
1178+
,
1179+
( "committeeAccepted:"
1180+
, hsep
1181+
[ viaShow $ committeeAccepted ratEnv ratSt gas
1182+
, "["
1183+
, "To Pass:"
1184+
, viaShow $ committeeAcceptedRatio members gasCommitteeVotes committeeState currentEpoch
1185+
, ">="
1186+
, viaShow $ votingCommitteeThreshold reCurrentEpoch ratSt committeeState (gasAction gas)
1187+
, "]"
1188+
]
1189+
)
1190+
,
1191+
( "spoAccepted:"
1192+
, hsep
1193+
[ viaShow $ spoAccepted ratEnv ratSt gas
1194+
, "["
1195+
, "To Pass:"
1196+
, viaShow $ spoAcceptedRatio ratEnv gas pv
1197+
, ">="
1198+
, viaShow $ votingStakePoolThreshold ratSt (gasAction gas)
1199+
, "]"
1200+
]
1201+
)
1202+
,
1203+
( "dRepAccepted:"
1204+
, hsep
1205+
[ viaShow $ dRepAccepted ratEnv ratSt gas
1206+
, "["
1207+
, "To Pass:"
1208+
, viaShow $ dRepAcceptedRatio ratEnv gasDRepVotes (gasAction gas)
1209+
, ">="
1210+
, viaShow $ votingDRepThreshold ratSt (gasAction gas)
1211+
, "]"
1212+
]
1213+
)
1214+
]
12111215

12121216
-- | Submits a transaction that registers a hot key for the given cold key.
12131217
-- Returns the hot key hash.

0 commit comments

Comments
 (0)