{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Test.Cardano.Ledger.Conway.Imp.CertsSpec (spec) where import Cardano.Ledger.BaseTypes (EpochInterval (..)) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Rules (ConwayCertsPredFailure (..), ConwayLedgerPredFailure (..)) import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.DRep (DRep (..)) import Cardano.Ledger.Val (Val (..)) import Lens.Micro ((&), (.~)) import Test.Cardano.Ledger.Conway.Arbitrary () import Test.Cardano.Ledger.Conway.ImpTest import Test.Cardano.Ledger.Imp.Common spec :: forall era. ( ConwayEraImp era , InjectRuleFailure "LEDGER" ConwayCertsPredFailure era , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era ) => SpecWith (ImpInit (LedgerSpec era)) spec :: forall era. (ConwayEraImp era, InjectRuleFailure "LEDGER" ConwayCertsPredFailure era, InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era) => SpecWith (ImpInit (LedgerSpec era)) spec = do String -> SpecWith (ImpInit (LedgerSpec era)) -> SpecWith (ImpInit (LedgerSpec era)) forall a. HasCallStack => String -> SpecWith a -> SpecWith a describe String "Withdrawals" (SpecWith (ImpInit (LedgerSpec era)) -> SpecWith (ImpInit (LedgerSpec era))) -> SpecWith (ImpInit (LedgerSpec era)) -> SpecWith (ImpInit (LedgerSpec era)) forall a b. (a -> b) -> a -> b $ do String -> ImpM (LedgerSpec era) () -> SpecWith (Arg (ImpM (LedgerSpec era) ())) forall a. (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it String "Withdrawing from an unregistered reward account" (ImpM (LedgerSpec era) () -> SpecWith (Arg (ImpM (LedgerSpec era) ()))) -> ImpM (LedgerSpec era) () -> SpecWith (Arg (ImpM (LedgerSpec era) ())) forall a b. (a -> b) -> a -> b $ do (PParams era -> PParams era) -> ImpM (LedgerSpec era) () forall era. ShelleyEraImp era => (PParams era -> PParams era) -> ImpTestM era () modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ()) -> (PParams era -> PParams era) -> ImpM (LedgerSpec era) () forall a b. (a -> b) -> a -> b $ (EpochInterval -> Identity EpochInterval) -> PParams era -> Identity (PParams era) forall era. ConwayEraPParams era => Lens' (PParams era) EpochInterval Lens' (PParams era) EpochInterval ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval) -> PParams era -> Identity (PParams era)) -> EpochInterval -> PParams era -> PParams era forall s t a b. ASetter s t a b -> b -> s -> t .~ Word32 -> EpochInterval EpochInterval Word32 2 KeyHash 'Staking stakeKey <- ImpM (LedgerSpec era) (KeyHash 'Staking) forall (r :: KeyRole) s g (m :: * -> *). (HasKeyPairs s, MonadState s m, HasStatefulGen g m) => m (KeyHash r) freshKeyHash RewardAccount rwdAccount <- Credential 'Staking -> ImpTestM era RewardAccount forall era. Credential 'Staking -> ImpTestM era RewardAccount getRewardAccountFor (Credential 'Staking -> ImpTestM era RewardAccount) -> Credential 'Staking -> ImpTestM era RewardAccount forall a b. (a -> b) -> a -> b $ KeyHash 'Staking -> Credential 'Staking forall (kr :: KeyRole). KeyHash kr -> Credential kr KeyHashObj KeyHash 'Staking stakeKey let tx :: Tx era tx = TxBody era -> Tx era forall era. EraTx era => TxBody era -> Tx era mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era forall a b. (a -> b) -> a -> b $ TxBody era forall era. EraTxBody era => TxBody era mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era forall a b. a -> (a -> b) -> b & (Withdrawals -> Identity Withdrawals) -> TxBody era -> Identity (TxBody era) forall era. EraTxBody era => Lens' (TxBody era) Withdrawals Lens' (TxBody era) Withdrawals withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals) -> TxBody era -> Identity (TxBody era)) -> Withdrawals -> TxBody era -> TxBody era forall s t a b. ASetter s t a b -> b -> s -> t .~ Map RewardAccount Coin -> Withdrawals Withdrawals [(RewardAccount rwdAccount, Integer -> Coin Coin Integer 20)] notInRewardsFailure :: EraRuleFailure "LEDGER" era notInRewardsFailure = ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure (ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era) -> ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era forall a b. (a -> b) -> a -> b $ Map RewardAccount Coin -> ConwayCertsPredFailure era forall era. Map RewardAccount Coin -> ConwayCertsPredFailure era WithdrawalsNotInRewardsCERTS [(RewardAccount rwdAccount, Integer -> Coin Coin Integer 20)] in ImpM (LedgerSpec era) () -> (NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpM (LedgerSpec era) ()) -> SubmitFailureExpectation era -> ImpM (LedgerSpec era) () forall era a. EraGov era => ImpTestM era a -> (NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era a) -> SubmitFailureExpectation era -> ImpTestM era a submitBootstrapAware (Tx era -> ImpM (LedgerSpec era) () forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era () submitTx_ Tx era tx) (Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpM (LedgerSpec era) () forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx Tx era tx) ( FailBoth era -> SubmitFailureExpectation era forall era. FailBoth era -> SubmitFailureExpectation era FailBootstrapAndPostBootstrap (FailBoth era -> SubmitFailureExpectation era) -> FailBoth era -> SubmitFailureExpectation era forall a b. (a -> b) -> a -> b $ FailBoth { bootstrapFailures :: NonEmpty (PredicateFailure (EraRule "LEDGER" era)) bootstrapFailures = [Item (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) EraRuleFailure "LEDGER" era notInRewardsFailure] , postBootstrapFailures :: NonEmpty (PredicateFailure (EraRule "LEDGER" era)) postBootstrapFailures = [ Item (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) EraRuleFailure "LEDGER" era notInRewardsFailure , ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure (NonEmpty (KeyHash 'Staking) -> ConwayLedgerPredFailure era forall era. NonEmpty (KeyHash 'Staking) -> ConwayLedgerPredFailure era ConwayWdrlNotDelegatedToDRep [Item (NonEmpty (KeyHash 'Staking)) KeyHash 'Staking stakeKey]) ] } ) (RewardAccount registeredRwdAccount, Coin reward, KeyHash 'Staking stakeKey2) <- ImpM (LedgerSpec era) (RewardAccount, Coin, KeyHash 'Staking) setupRewardAccount ImpM (LedgerSpec era) (KeyPair 'Payment) -> ImpM (LedgerSpec era) () forall (f :: * -> *) a. Functor f => f a -> f () void (ImpM (LedgerSpec era) (KeyPair 'Payment) -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) (KeyPair 'Payment) -> ImpM (LedgerSpec era) () forall a b. (a -> b) -> a -> b $ Credential 'Staking -> Coin -> DRep -> ImpM (LedgerSpec era) (KeyPair 'Payment) forall era. ConwayEraImp era => Credential 'Staking -> Coin -> DRep -> ImpTestM era (KeyPair 'Payment) delegateToDRep (KeyHash 'Staking -> Credential 'Staking forall (kr :: KeyRole). KeyHash kr -> Credential kr KeyHashObj KeyHash 'Staking stakeKey2) (Integer -> Coin Coin Integer 1_000_000) DRep DRepAlwaysNoConfidence let tx :: Tx era tx = TxBody era -> Tx era forall era. EraTx era => TxBody era -> Tx era mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era forall a b. (a -> b) -> a -> b $ TxBody era forall era. EraTxBody era => TxBody era mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era forall a b. a -> (a -> b) -> b & (Withdrawals -> Identity Withdrawals) -> TxBody era -> Identity (TxBody era) forall era. EraTxBody era => Lens' (TxBody era) Withdrawals Lens' (TxBody era) Withdrawals withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals) -> TxBody era -> Identity (TxBody era)) -> Withdrawals -> TxBody era -> TxBody era forall s t a b. ASetter s t a b -> b -> s -> t .~ Map RewardAccount Coin -> Withdrawals Withdrawals [(RewardAccount rwdAccount, Coin forall t. Val t => t zero), (RewardAccount registeredRwdAccount, Coin reward)] notInRewardsFailure :: EraRuleFailure "LEDGER" era notInRewardsFailure = ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure (ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era) -> ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era forall a b. (a -> b) -> a -> b $ Map RewardAccount Coin -> ConwayCertsPredFailure era forall era. Map RewardAccount Coin -> ConwayCertsPredFailure era WithdrawalsNotInRewardsCERTS [(RewardAccount rwdAccount, Coin forall t. Val t => t zero)] in ImpM (LedgerSpec era) () -> (NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpM (LedgerSpec era) ()) -> SubmitFailureExpectation era -> ImpM (LedgerSpec era) () forall era a. EraGov era => ImpTestM era a -> (NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era a) -> SubmitFailureExpectation era -> ImpTestM era a submitBootstrapAware (Tx era -> ImpM (LedgerSpec era) () forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era () submitTx_ Tx era tx) (Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpM (LedgerSpec era) () forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx Tx era tx) ( FailBoth era -> SubmitFailureExpectation era forall era. FailBoth era -> SubmitFailureExpectation era FailBootstrapAndPostBootstrap (FailBoth era -> SubmitFailureExpectation era) -> FailBoth era -> SubmitFailureExpectation era forall a b. (a -> b) -> a -> b $ FailBoth { bootstrapFailures :: NonEmpty (PredicateFailure (EraRule "LEDGER" era)) bootstrapFailures = [Item (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) EraRuleFailure "LEDGER" era notInRewardsFailure] , postBootstrapFailures :: NonEmpty (PredicateFailure (EraRule "LEDGER" era)) postBootstrapFailures = [ Item (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) EraRuleFailure "LEDGER" era notInRewardsFailure , ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure (NonEmpty (KeyHash 'Staking) -> ConwayLedgerPredFailure era forall era. NonEmpty (KeyHash 'Staking) -> ConwayLedgerPredFailure era ConwayWdrlNotDelegatedToDRep [Item (NonEmpty (KeyHash 'Staking)) KeyHash 'Staking stakeKey]) ] } ) String -> ImpM (LedgerSpec era) () -> SpecWith (Arg (ImpM (LedgerSpec era) ())) forall a. (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it String "Withdrawing the wrong amount" (ImpM (LedgerSpec era) () -> SpecWith (Arg (ImpM (LedgerSpec era) ()))) -> ImpM (LedgerSpec era) () -> SpecWith (Arg (ImpM (LedgerSpec era) ())) forall a b. (a -> b) -> a -> b $ do (PParams era -> PParams era) -> ImpM (LedgerSpec era) () forall era. ShelleyEraImp era => (PParams era -> PParams era) -> ImpTestM era () modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ()) -> (PParams era -> PParams era) -> ImpM (LedgerSpec era) () forall a b. (a -> b) -> a -> b $ (EpochInterval -> Identity EpochInterval) -> PParams era -> Identity (PParams era) forall era. ConwayEraPParams era => Lens' (PParams era) EpochInterval Lens' (PParams era) EpochInterval ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval) -> PParams era -> Identity (PParams era)) -> EpochInterval -> PParams era -> PParams era forall s t a b. ASetter s t a b -> b -> s -> t .~ Word32 -> EpochInterval EpochInterval Word32 2 (RewardAccount rwdAccount1, Coin reward1, KeyHash 'Staking stakeKey1) <- ImpM (LedgerSpec era) (RewardAccount, Coin, KeyHash 'Staking) setupRewardAccount (RewardAccount rwdAccount2, Coin reward2, KeyHash 'Staking stakeKey2) <- ImpM (LedgerSpec era) (RewardAccount, Coin, KeyHash 'Staking) setupRewardAccount ImpM (LedgerSpec era) (KeyPair 'Payment) -> ImpM (LedgerSpec era) () forall (f :: * -> *) a. Functor f => f a -> f () void (ImpM (LedgerSpec era) (KeyPair 'Payment) -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) (KeyPair 'Payment) -> ImpM (LedgerSpec era) () forall a b. (a -> b) -> a -> b $ Credential 'Staking -> Coin -> DRep -> ImpM (LedgerSpec era) (KeyPair 'Payment) forall era. ConwayEraImp era => Credential 'Staking -> Coin -> DRep -> ImpTestM era (KeyPair 'Payment) delegateToDRep (KeyHash 'Staking -> Credential 'Staking forall (kr :: KeyRole). KeyHash kr -> Credential kr KeyHashObj KeyHash 'Staking stakeKey1) (Integer -> Coin Coin Integer 1_000_000) DRep DRepAlwaysAbstain ImpM (LedgerSpec era) (KeyPair 'Payment) -> ImpM (LedgerSpec era) () forall (f :: * -> *) a. Functor f => f a -> f () void (ImpM (LedgerSpec era) (KeyPair 'Payment) -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) (KeyPair 'Payment) -> ImpM (LedgerSpec era) () forall a b. (a -> b) -> a -> b $ Credential 'Staking -> Coin -> DRep -> ImpM (LedgerSpec era) (KeyPair 'Payment) forall era. ConwayEraImp era => Credential 'Staking -> Coin -> DRep -> ImpTestM era (KeyPair 'Payment) delegateToDRep (KeyHash 'Staking -> Credential 'Staking forall (kr :: KeyRole). KeyHash kr -> Credential kr KeyHashObj KeyHash 'Staking stakeKey2) (Integer -> Coin Coin Integer 1_000_000) DRep DRepAlwaysAbstain Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpM (LedgerSpec era) () forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx ( TxBody era -> Tx era forall era. EraTx era => TxBody era -> Tx era mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era forall a b. (a -> b) -> a -> b $ TxBody era forall era. EraTxBody era => TxBody era mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era forall a b. a -> (a -> b) -> b & (Withdrawals -> Identity Withdrawals) -> TxBody era -> Identity (TxBody era) forall era. EraTxBody era => Lens' (TxBody era) Withdrawals Lens' (TxBody era) Withdrawals withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals) -> TxBody era -> Identity (TxBody era)) -> Withdrawals -> TxBody era -> TxBody era forall s t a b. ASetter s t a b -> b -> s -> t .~ Map RewardAccount Coin -> Withdrawals Withdrawals [ (RewardAccount rwdAccount1, Coin reward1 Coin -> Coin -> Coin forall t. Val t => t -> t -> t <+> Integer -> Coin Coin Integer 1) , (RewardAccount rwdAccount2, Coin reward2) ] ) [ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure (ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era) -> ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era forall a b. (a -> b) -> a -> b $ Map RewardAccount Coin -> ConwayCertsPredFailure era forall era. Map RewardAccount Coin -> ConwayCertsPredFailure era WithdrawalsNotInRewardsCERTS [(RewardAccount rwdAccount1, Coin reward1 Coin -> Coin -> Coin forall t. Val t => t -> t -> t <+> Integer -> Coin Coin Integer 1)]] Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpM (LedgerSpec era) () forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx ( TxBody era -> Tx era forall era. EraTx era => TxBody era -> Tx era mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era forall a b. (a -> b) -> a -> b $ TxBody era forall era. EraTxBody era => TxBody era mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era forall a b. a -> (a -> b) -> b & (Withdrawals -> Identity Withdrawals) -> TxBody era -> Identity (TxBody era) forall era. EraTxBody era => Lens' (TxBody era) Withdrawals Lens' (TxBody era) Withdrawals withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals) -> TxBody era -> Identity (TxBody era)) -> Withdrawals -> TxBody era -> TxBody era forall s t a b. ASetter s t a b -> b -> s -> t .~ Map RewardAccount Coin -> Withdrawals Withdrawals [(RewardAccount rwdAccount1, Coin forall t. Val t => t zero)] ) [ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure (ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era) -> ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era forall a b. (a -> b) -> a -> b $ Map RewardAccount Coin -> ConwayCertsPredFailure era forall era. Map RewardAccount Coin -> ConwayCertsPredFailure era WithdrawalsNotInRewardsCERTS [(RewardAccount rwdAccount1, Coin forall t. Val t => t zero)]] where setupRewardAccount :: ImpM (LedgerSpec era) (RewardAccount, Coin, KeyHash 'Staking) setupRewardAccount = do KeyHash 'Staking kh <- ImpM (LedgerSpec era) (KeyHash 'Staking) forall (r :: KeyRole) s g (m :: * -> *). (HasKeyPairs s, MonadState s m, HasStatefulGen g m) => m (KeyHash r) freshKeyHash let cred :: Credential 'Staking cred = KeyHash 'Staking -> Credential 'Staking forall (kr :: KeyRole). KeyHash kr -> Credential kr KeyHashObj KeyHash 'Staking kh RewardAccount ra <- Credential 'Staking -> ImpTestM era RewardAccount forall era. (HasCallStack, ShelleyEraImp era) => Credential 'Staking -> ImpTestM era RewardAccount registerStakeCredential Credential 'Staking cred Credential 'Staking -> ImpM (LedgerSpec era) () forall era. ConwayEraImp era => Credential 'Staking -> ImpTestM era () submitAndExpireProposalToMakeReward Credential 'Staking cred Coin rw <- Credential 'Staking -> ImpTestM era Coin forall era. (HasCallStack, EraCertState era) => Credential 'Staking -> ImpTestM era Coin getReward Credential 'Staking cred (RewardAccount, Coin, KeyHash 'Staking) -> ImpM (LedgerSpec era) (RewardAccount, Coin, KeyHash 'Staking) forall a. a -> ImpM (LedgerSpec era) a forall (f :: * -> *) a. Applicative f => a -> f a pure (RewardAccount ra, Coin rw, KeyHash 'Staking kh)