9
9
module Test.Cardano.Ledger.Shelley.RulesTests (
10
10
chainExamples ,
11
11
multisigExamples ,
12
- testTickF ,
13
12
) where
14
13
15
- import Cardano.Ledger.BaseTypes (Network (.. ), StrictMaybe ( .. ) )
14
+ import Cardano.Ledger.BaseTypes (Network (.. ))
16
15
import Cardano.Ledger.Coin (Coin (.. ))
17
16
import Cardano.Ledger.Core (hashScript )
18
17
import Cardano.Ledger.Credential (pattern ScriptHashObj )
19
18
import Cardano.Ledger.Keys (asWitness , hashKey )
20
19
import Cardano.Ledger.Shelley (ShelleyEra )
21
- import Cardano.Ledger.Shelley.API (ShelleyTICK , ShelleyTICKF )
22
- import Cardano.Ledger.Shelley.LedgerState (
23
- EpochState (.. ),
24
- LedgerState (.. ),
25
- NewEpochState (.. ),
26
- UTxOState (.. ),
27
- totalObligation ,
28
- utxosGovStateL ,
29
- )
30
- import Cardano.Ledger.Shelley.RewardUpdate (PulsingRewUpdate (.. ), RewardUpdate (.. ))
31
20
import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (.. ))
32
21
import Cardano.Ledger.Shelley.TxBody (RewardAccount (.. ), Withdrawals (.. ))
33
- import Cardano.Ledger.Slot (EpochNo (.. ))
34
- import Cardano.Protocol.TPraos.API (GetLedgerView (.. ))
35
- import Control.State.Transition.Extended (TRC (.. ))
36
22
import Data.Either (isRight )
37
23
import qualified Data.Map.Strict as Map
38
- import Data.Maybe (fromMaybe )
39
24
import qualified Data.Set as Set
40
- import Lens.Micro ((^.) )
41
25
import Test.Cardano.Ledger.Core.KeyPair (vKey )
42
26
import Test.Cardano.Ledger.Shelley.Examples (testCHAINExample )
43
27
import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast
@@ -62,10 +46,8 @@ import Test.Cardano.Ledger.Shelley.MultiSigExamples (
62
46
)
63
47
import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
64
48
import Test.Cardano.Ledger.Shelley.Serialisation.Generators ()
65
- import Test.Cardano.Ledger.Shelley.Utils
66
49
import Test.Tasty (TestTree , testGroup )
67
50
import Test.Tasty.HUnit (Assertion , assertBool , testCase , (@?=) )
68
- import Test.Tasty.QuickCheck (Property , discard , testProperty , (===) )
69
51
70
52
chainExamples :: TestTree
71
53
chainExamples =
@@ -488,54 +470,3 @@ testRwdAliceSignsAlone''' =
488
470
(Coin 0 )
489
471
[asWitness Cast. alicePay, asWitness Cast. bobPay]
490
472
wits = Set. singleton $ hashScript @ ShelleyEra bobOnly
491
-
492
- -- | The reward aggregation bug described in the Shelley ledger spec in
493
- -- section 17.4 (in the Errata) resulted in needing to use 'aggregatedRewards' to change
494
- -- the behavior of how rewards are collected starting at protocol version 3.
495
- -- Instead of collecting a `Coin` for each stake credential, we collect 'Set Reward'.
496
- -- In major protocol version 2, it is impossible for this set to be empty, but sadly this
497
- -- property is not enforced in the types. For this reason, the property test
498
- -- 'propTickfPerservesLedgerView' removes these empty sets from an otherwise arbitrary
499
- -- 'NewEpochState'.
500
- filterEmptyRewards :: NewEpochState ShelleyEra -> NewEpochState ShelleyEra
501
- filterEmptyRewards (NewEpochState el bprev bcur es ru pd stash) =
502
- NewEpochState el bprev bcur es ru' pd stash
503
- where
504
- removeEmptyRewards = Map. filter $ not . Set. null
505
- ru' = case ru of
506
- SNothing -> SNothing
507
- SJust (Pulsing _ _) -> SNothing
508
- SJust (Complete rewardUpdate) ->
509
- SJust . Complete $ rewardUpdate {rs = removeEmptyRewards (rs rewardUpdate)}
510
-
511
- setDepositsToObligation :: NewEpochState ShelleyEra -> NewEpochState ShelleyEra
512
- setDepositsToObligation nes = nes {nesEs = es {esLState = ls {lsUTxOState = utxoState}}}
513
- where
514
- es = nesEs nes
515
- ls = esLState es
516
- utxoState =
517
- (lsUTxOState ls)
518
- { utxosDeposited =
519
- totalObligation
520
- (lsCertState ls)
521
- (utxoState ^. utxosGovStateL)
522
- }
523
-
524
- -- | This property test checks the correctness of the TICKF transation.
525
- -- TICKF is used by the consensus layer to get a ledger view in a computationally
526
- -- cheaper way than using the TICK rule.
527
- -- Therefore TICKF and TICK need to compute the same ledger view.
528
- propTickfPerservesLedgerView :: NewEpochState ShelleyEra -> Property
529
- propTickfPerservesLedgerView nes =
530
- let (EpochNo e) = nesEL nes
531
- slot = slotFromEpoch (EpochNo $ e + 1 )
532
- nes' = setDepositsToObligation (filterEmptyRewards nes)
533
- tickNes = runShelleyBase $ applySTSTest @ (ShelleyTICK ShelleyEra ) (TRC (() , nes', slot))
534
- tickFNes = runShelleyBase $ applySTSTest @ (ShelleyTICKF ShelleyEra ) (TRC (() , nes', slot))
535
- in fromMaybe discard $ do
536
- Right tickNes' <- pure tickNes
537
- Right tickFNes' <- pure tickFNes
538
- pure $ currentLedgerView tickNes' === currentLedgerView tickFNes'
539
-
540
- testTickF :: TestTree
541
- testTickF = testProperty " TICKF properties" propTickfPerservesLedgerView
0 commit comments