Skip to content

Commit 3fac44c

Browse files
teodanciuteodanciu
committed
Make some conway DelegSpec tests compatible with earlier eras
1 parent 639d15a commit 3fac44c

File tree

1 file changed

+58
-67
lines changed
  • eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp

1 file changed

+58
-67
lines changed

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

Lines changed: 58 additions & 67 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,8 @@ import Cardano.Ledger.Plutus (
3636
hashPlutusScript,
3737
)
3838
import Cardano.Ledger.Shelley.LedgerState
39+
import qualified Cardano.Ledger.Shelley.Rules as Shelley
40+
import Cardano.Ledger.Shelley.Scripts
3941
import Cardano.Ledger.Val (Val (..))
4042
import qualified Data.Map.Strict as Map
4143
import qualified Data.Sequence.Strict as SSeq
@@ -53,8 +55,6 @@ spec ::
5355
spec = do
5456
describe "Register stake credential" $ do
5557
it "With correct deposit or without any deposit" $ do
56-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
57-
5858
cred <- KeyHashObj <$> freshKeyHash
5959
-- NOTE: This will always generate certs with deposits post-Conway
6060
regTxCert <- genRegTxCert cred
@@ -63,6 +63,8 @@ spec = do
6363
& bodyTxL . certsTxBodyL .~ [regTxCert]
6464
expectRegistered cred
6565

66+
it "With correct deposit" $ do
67+
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
6668
freshKeyHash >>= \kh -> do
6769
submitTx_ $
6870
mkBasicTx mkBasicTxBody
@@ -72,30 +74,27 @@ spec = do
7274

7375
it "Twice the same certificate in the same transaction" $ do
7476
-- This is expected behavior because `certsTxBodyL` removes duplicates
75-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
7677
freshKeyHash >>= \kh -> do
78+
regTxCert <- genRegTxCert (KeyHashObj kh)
7779
submitTx_ $
7880
mkBasicTx mkBasicTxBody
7981
& bodyTxL . certsTxBodyL
80-
.~ [ RegDepositTxCert (KeyHashObj kh) expectedDeposit
81-
, RegDepositTxCert (KeyHashObj kh) expectedDeposit
82-
]
82+
.~ [regTxCert, regTxCert]
8383
expectRegistered (KeyHashObj kh)
8484

8585
it "When already already registered" $ do
86-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
87-
let sh = hashPlutusScript $ evenRedeemerNoDatum SPlutusV3
86+
cred <- ScriptHashObj <$> impAddNativeScript (RequireAllOf [])
87+
regTxCert <- genRegTxCert cred
8888
let tx =
8989
mkBasicTx mkBasicTxBody
9090
& bodyTxL . certsTxBodyL
91-
.~ [RegDepositTxCert (ScriptHashObj sh) expectedDeposit]
91+
.~ [regTxCert]
9292
submitTx_ tx
93-
9493
submitFailingTx
9594
tx
96-
[ injectFailure $ StakeKeyRegisteredDELEG (ScriptHashObj sh)
95+
[ injectFailure $ Shelley.StakeKeyAlreadyRegisteredDELEG cred
9796
]
98-
expectRegistered (ScriptHashObj sh)
97+
expectRegistered cred
9998

10099
it "With incorrect deposit" $ do
101100
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
@@ -124,35 +123,35 @@ spec = do
124123

125124
describe "Unregister stake credentials" $ do
126125
it "When registered" $ do
127-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
128-
let sh = ScriptHashObj $ hashPlutusScript (evenRedeemerNoDatum SPlutusV3)
126+
cred <- ScriptHashObj <$> impAddNativeScript (RequireAllOf [])
127+
regTxCert <- genRegTxCert cred
129128
submitTx_ $
130129
mkBasicTx mkBasicTxBody
131-
& bodyTxL . certsTxBodyL
132-
.~ [RegDepositTxCert sh expectedDeposit]
130+
& bodyTxL . certsTxBodyL .~ [regTxCert]
131+
expectRegistered cred
133132

133+
unRegTxCert <- genUnRegTxCert cred
134134
submitTx_ $
135135
mkBasicTx mkBasicTxBody
136136
& bodyTxL . certsTxBodyL
137-
.~ [UnRegDepositTxCert sh expectedDeposit]
138-
expectNotRegistered sh
137+
.~ [unRegTxCert]
138+
expectNotRegistered cred
139139

140140
it "When not registered" $ do
141-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
142-
freshKeyHash >>= \kh ->
141+
freshKeyHash >>= \kh -> do
142+
unRegTxCert <- genUnRegTxCert (KeyHashObj kh)
143143
submitFailingTx
144144
( mkBasicTx mkBasicTxBody
145145
& bodyTxL . certsTxBodyL
146-
.~ [UnRegDepositTxCert (KeyHashObj kh) expectedDeposit]
146+
.~ [unRegTxCert]
147147
)
148-
[ injectFailure $ StakeKeyNotRegisteredDELEG (KeyHashObj kh)
149-
]
148+
[injectFailure $ StakeKeyNotRegisteredDELEG (KeyHashObj kh)]
150149

151150
it "With incorrect refund" $ do
152151
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
153152
pv <- getsNES $ nesEsL . curPParamsEpochStateL . ppProtocolVersionL
154153

155-
cred <- KeyHashObj <$> freshKeyHash
154+
let cred = ScriptHashObj $ hashPlutusScript $ evenRedeemerNoDatum SPlutusV3
156155

157156
submitTx_ $
158157
mkBasicTx mkBasicTxBody
@@ -179,35 +178,35 @@ spec = do
179178

180179
expectRegistered cred
181180

182-
it "With non-zero reward balance" $ do
183-
modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
184-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
185-
181+
-- https://github.com/IntersectMBO/formal-ledger-specifications/issues/917
182+
-- impacts `registerAndRetirePoolToMakeReward`
183+
-- TODO: Re-enable after issue is resolved, by removing this override
184+
disableInConformanceIt "With non-zero reward balance" $ do
186185
cred <- KeyHashObj <$> freshKeyHash
186+
regTxCert <- genRegTxCert cred
187187

188188
submitTx_ $
189189
mkBasicTx mkBasicTxBody
190-
& bodyTxL . certsTxBodyL .~ [RegDepositTxCert cred expectedDeposit]
190+
& bodyTxL . certsTxBodyL .~ [regTxCert]
191191

192-
submitAndExpireProposalToMakeReward cred
192+
registerAndRetirePoolToMakeReward cred
193193

194194
balance <- getBalance cred
195+
unRegTxCert <- genUnRegTxCert cred
195196
submitFailingTx
196197
( mkBasicTx mkBasicTxBody
197-
& bodyTxL . certsTxBodyL .~ [UnRegDepositTxCert cred expectedDeposit]
198+
& bodyTxL . certsTxBodyL .~ [unRegTxCert]
198199
)
199-
[injectFailure $ StakeKeyHasNonZeroRewardAccountBalanceDELEG balance]
200+
[injectFailure $ Shelley.StakeKeyNonZeroAccountBalanceDELEG balance]
200201
expectRegistered cred
201202

202203
it "Register and unregister in the same transaction" $ do
203-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
204204
freshKeyHash >>= \kh -> do
205+
regTxCert <- genRegTxCert (KeyHashObj kh)
206+
unRegTxCert <- genUnRegTxCert (KeyHashObj kh)
205207
submitTx_ $
206208
mkBasicTx mkBasicTxBody
207-
& bodyTxL . certsTxBodyL
208-
.~ [ RegDepositTxCert (KeyHashObj kh) expectedDeposit
209-
, UnRegDepositTxCert (KeyHashObj kh) expectedDeposit
210-
]
209+
& bodyTxL . certsTxBodyL .~ [regTxCert, unRegTxCert]
211210
expectNotRegistered (KeyHashObj kh)
212211

213212
it "deregistering returns the deposit" $ do
@@ -252,47 +251,46 @@ spec = do
252251

253252
describe "Delegate stake" $ do
254253
it "Delegate registered stake credentials to registered pool" $ do
255-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
256-
257254
cred <- KeyHashObj <$> freshKeyHash
255+
regTxCert <- genRegTxCert cred
258256
submitTx_ $
259257
mkBasicTx mkBasicTxBody
260-
& bodyTxL . certsTxBodyL
261-
.~ [RegDepositTxCert cred expectedDeposit]
258+
& bodyTxL . certsTxBodyL .~ [regTxCert]
262259

263260
poolKh <- freshKeyHash
264261
registerPool poolKh
265262

266263
submitTx_ $
267264
mkBasicTx mkBasicTxBody
268-
& bodyTxL . certsTxBodyL
269-
.~ [DelegTxCert cred (DelegStake poolKh)]
270-
265+
& bodyTxL . certsTxBodyL .~ [delegStakeTxCert cred poolKh]
271266
expectDelegatedToPool cred poolKh
272267

273268
it "Register and delegate in the same transaction" $ do
274-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
275-
276269
poolKh <- freshKeyHash
277270
registerPool poolKh
278271
freshKeyHash >>= \kh -> do
272+
regTxCert <- genRegTxCert (KeyHashObj kh)
279273
submitTx_ $
280274
mkBasicTx mkBasicTxBody
281275
& bodyTxL . certsTxBodyL
282-
.~ [RegDepositDelegTxCert (KeyHashObj kh) (DelegStake poolKh) expectedDeposit]
276+
.~ [regTxCert, delegStakeTxCert (KeyHashObj kh) poolKh]
283277
expectDelegatedToPool (KeyHashObj kh) poolKh
284278

285279
it "Delegate unregistered stake credentials" $ do
286280
cred <- KeyHashObj <$> freshKeyHash
287281
poolKh <- freshKeyHash
288282
registerPool poolKh
283+
pv <- getProtVer
289284
submitFailingTx
290285
( mkBasicTx mkBasicTxBody
291286
& bodyTxL . certsTxBodyL
292-
.~ [DelegTxCert cred (DelegStake poolKh)]
287+
.~ [delegStakeTxCert cred poolKh]
293288
)
294-
[injectFailure $ StakeKeyNotRegisteredDELEG cred]
295-
289+
[ injectFailure $
290+
if pvMajor pv < natVersion @9
291+
then Shelley.StakeDelegationImpossibleDELEG cred
292+
else Shelley.StakeKeyNotRegisteredDELEG cred
293+
]
296294
expectNotRegistered cred
297295

298296
it "Delegate to unregistered pool" $ do
@@ -311,34 +309,29 @@ spec = do
311309
.~ [DelegTxCert cred (DelegStake poolKh)]
312310
)
313311
[injectFailure $ DelegateeStakePoolNotRegisteredDELEG poolKh]
314-
315312
expectNotDelegatedToPool cred
316313

317314
it "Delegate already delegated credentials" $ do
318-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
319-
320315
cred <- KeyHashObj <$> freshKeyHash
321316
poolKh <- freshKeyHash
322317
registerPool poolKh
318+
regTxCert <- genRegTxCert cred
319+
let delegTxCert = delegStakeTxCert cred poolKh
323320
submitTx_ $
324321
mkBasicTx mkBasicTxBody
325-
& bodyTxL . certsTxBodyL
326-
.~ [ RegDepositTxCert cred expectedDeposit
327-
, DelegTxCert cred (DelegStake poolKh)
328-
]
322+
& bodyTxL . certsTxBodyL .~ [regTxCert, delegTxCert]
329323
expectDelegatedToPool cred poolKh
330324
submitTx_ $
331325
mkBasicTx mkBasicTxBody
332-
& bodyTxL . certsTxBodyL
333-
.~ [DelegTxCert cred (DelegStake poolKh)]
326+
& bodyTxL . certsTxBodyL .~ [delegTxCert]
334327
expectDelegatedToPool cred poolKh
335328

336329
poolKh1 <- freshKeyHash
337330
registerPool poolKh1
338331
submitTx_ $
339332
mkBasicTx mkBasicTxBody
340333
& bodyTxL . certsTxBodyL
341-
.~ [DelegTxCert cred (DelegStake poolKh1)]
334+
.~ [delegStakeTxCert cred poolKh1]
342335
expectDelegatedToPool cred poolKh1
343336

344337
poolKh2 <- freshKeyHash
@@ -349,24 +342,22 @@ spec = do
349342
submitTx_ $
350343
mkBasicTx mkBasicTxBody
351344
& bodyTxL . certsTxBodyL
352-
.~ [ DelegTxCert cred (DelegStake poolKh2)
353-
, DelegTxCert cred (DelegStake poolKh3)
345+
.~ [ delegStakeTxCert cred poolKh2
346+
, delegStakeTxCert cred poolKh3
354347
]
355348

356349
expectDelegatedToPool cred poolKh3
357350

358351
it "Delegate and unregister" $ do
359-
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
360-
361352
cred <- KeyHashObj <$> freshKeyHash
362353
poolKh <- freshKeyHash
363354
registerPool poolKh
355+
regTxCert <- genRegTxCert cred
356+
unRegTxCert <- genUnRegTxCert cred
364357
submitTx_ $
365358
mkBasicTx mkBasicTxBody
366359
& bodyTxL . certsTxBodyL
367-
.~ [ RegDepositDelegTxCert cred (DelegStake poolKh) expectedDeposit
368-
, UnRegDepositTxCert cred expectedDeposit
369-
]
360+
.~ [regTxCert, delegStakeTxCert cred poolKh, unRegTxCert]
370361
expectNotRegistered cred
371362

372363
describe "Delegate vote" $ do

0 commit comments

Comments
 (0)