99module Test.Cardano.Ledger.Shelley.RulesTests (
1010 chainExamples ,
1111 multisigExamples ,
12- testTickF ,
1312) where
1413
15- import Cardano.Ledger.BaseTypes (Network (.. ), StrictMaybe ( .. ) )
14+ import Cardano.Ledger.BaseTypes (Network (.. ))
1615import Cardano.Ledger.Coin (Coin (.. ))
1716import Cardano.Ledger.Core (hashScript )
1817import Cardano.Ledger.Credential (pattern ScriptHashObj )
1918import Cardano.Ledger.Keys (asWitness , hashKey )
2019import 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 (.. ))
3120import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (.. ))
3221import 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 (.. ))
3622import Data.Either (isRight )
3723import qualified Data.Map.Strict as Map
38- import Data.Maybe (fromMaybe )
3924import qualified Data.Set as Set
40- import Lens.Micro ((^.) )
4125import Test.Cardano.Ledger.Core.KeyPair (vKey )
4226import Test.Cardano.Ledger.Shelley.Examples (testCHAINExample )
4327import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast
@@ -62,10 +46,8 @@ import Test.Cardano.Ledger.Shelley.MultiSigExamples (
6246 )
6347import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
6448import Test.Cardano.Ledger.Shelley.Serialisation.Generators ()
65- import Test.Cardano.Ledger.Shelley.Utils
6649import Test.Tasty (TestTree , testGroup )
6750import Test.Tasty.HUnit (Assertion , assertBool , testCase , (@?=) )
68- import Test.Tasty.QuickCheck (Property , discard , testProperty , (===) )
6951
7052chainExamples :: TestTree
7153chainExamples =
@@ -488,54 +470,3 @@ testRwdAliceSignsAlone''' =
488470 (Coin 0 )
489471 [asWitness Cast. alicePay, asWitness Cast. bobPay]
490472 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