{-# 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 (..)) import Cardano.Ledger.Credential (Credential (..)) 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 ) => SpecWith (ImpTestState era) spec :: forall era. (ConwayEraImp era, InjectRuleFailure "LEDGER" ConwayCertsPredFailure era) => SpecWith (ImpTestState era) spec = do forall a. HasCallStack => String -> SpecWith a -> SpecWith a describe String "Withdrawals" forall a b. (a -> b) -> a -> b $ do forall a. (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it String "Withdrawing from an unregistered reward account" forall a b. (a -> b) -> a -> b $ do forall era. ShelleyEraImp era => (PParams era -> PParams era) -> ImpTestM era () modifyPParams forall a b. (a -> b) -> a -> b $ forall era. ConwayEraPParams era => Lens' (PParams era) EpochInterval ppGovActionLifetimeL forall s t a b. ASetter s t a b -> b -> s -> t .~ Word32 -> EpochInterval EpochInterval Word32 2 RewardAcnt (EraCrypto era) rwdAccount <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall s c (m :: * -> *) (r :: KeyRole). (HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) => m (KeyHash r c) freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall era. Credential 'Staking (EraCrypto era) -> ImpTestM era (RewardAccount (EraCrypto era)) getRewardAccountFor forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx ( forall era. EraTx era => TxBody era -> Tx era mkBasicTx forall a b. (a -> b) -> a -> b $ forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. EraTxBody era => Lens' (TxBody era) (Withdrawals (EraCrypto era)) withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall c. Map (RewardAcnt c) Coin -> Withdrawals c Withdrawals [(RewardAcnt (EraCrypto era) rwdAccount, Integer -> Coin Coin Integer 20)] ) [forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure forall a b. (a -> b) -> a -> b $ forall era. Map (RewardAccount (EraCrypto era)) Coin -> ConwayCertsPredFailure era WithdrawalsNotInRewardsCERTS [(RewardAcnt (EraCrypto era) rwdAccount, Integer -> Coin Coin Integer 20)]] (RewardAcnt (EraCrypto era) registeredRwdAccount, Coin reward) <- ImpTestM era (RewardAcnt (EraCrypto era), Coin) setupRewardAccount forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx ( forall era. EraTx era => TxBody era -> Tx era mkBasicTx forall a b. (a -> b) -> a -> b $ forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. EraTxBody era => Lens' (TxBody era) (Withdrawals (EraCrypto era)) withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall c. Map (RewardAcnt c) Coin -> Withdrawals c Withdrawals [(RewardAcnt (EraCrypto era) rwdAccount, forall t. Val t => t zero), (RewardAcnt (EraCrypto era) registeredRwdAccount, Coin reward)] ) [forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure forall a b. (a -> b) -> a -> b $ forall era. Map (RewardAccount (EraCrypto era)) Coin -> ConwayCertsPredFailure era WithdrawalsNotInRewardsCERTS [(RewardAcnt (EraCrypto era) rwdAccount, forall t. Val t => t zero)]] forall a. (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it String "Withdrawing the wrong amount" forall a b. (a -> b) -> a -> b $ do forall era. ShelleyEraImp era => (PParams era -> PParams era) -> ImpTestM era () modifyPParams forall a b. (a -> b) -> a -> b $ forall era. ConwayEraPParams era => Lens' (PParams era) EpochInterval ppGovActionLifetimeL forall s t a b. ASetter s t a b -> b -> s -> t .~ Word32 -> EpochInterval EpochInterval Word32 2 (RewardAcnt (EraCrypto era) rwdAccount1, Coin reward1) <- ImpTestM era (RewardAcnt (EraCrypto era), Coin) setupRewardAccount (RewardAcnt (EraCrypto era) rwdAccount2, Coin reward2) <- ImpTestM era (RewardAcnt (EraCrypto era), Coin) setupRewardAccount forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx ( forall era. EraTx era => TxBody era -> Tx era mkBasicTx forall a b. (a -> b) -> a -> b $ forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. EraTxBody era => Lens' (TxBody era) (Withdrawals (EraCrypto era)) withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall c. Map (RewardAcnt c) Coin -> Withdrawals c Withdrawals [ (RewardAcnt (EraCrypto era) rwdAccount1, Coin reward1 forall t. Val t => t -> t -> t <+> Integer -> Coin Coin Integer 1) , (RewardAcnt (EraCrypto era) rwdAccount2, Coin reward2) ] ) [forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure forall a b. (a -> b) -> a -> b $ forall era. Map (RewardAccount (EraCrypto era)) Coin -> ConwayCertsPredFailure era WithdrawalsNotInRewardsCERTS [(RewardAcnt (EraCrypto era) rwdAccount1, Coin reward1 forall t. Val t => t -> t -> t <+> Integer -> Coin Coin Integer 1)]] forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx ( forall era. EraTx era => TxBody era -> Tx era mkBasicTx forall a b. (a -> b) -> a -> b $ forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. EraTxBody era => Lens' (TxBody era) (Withdrawals (EraCrypto era)) withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall c. Map (RewardAcnt c) Coin -> Withdrawals c Withdrawals [(RewardAcnt (EraCrypto era) rwdAccount1, forall t. Val t => t zero)] ) [forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure forall a b. (a -> b) -> a -> b $ forall era. Map (RewardAccount (EraCrypto era)) Coin -> ConwayCertsPredFailure era WithdrawalsNotInRewardsCERTS [(RewardAcnt (EraCrypto era) rwdAccount1, forall t. Val t => t zero)]] where setupRewardAccount :: ImpTestM era (RewardAcnt (EraCrypto era), Coin) setupRewardAccount = do Credential 'Staking (EraCrypto era) cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall s c (m :: * -> *) (r :: KeyRole). (HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) => m (KeyHash r c) freshKeyHash RewardAcnt (EraCrypto era) ra <- forall era. (HasCallStack, ShelleyEraImp era) => Credential 'Staking (EraCrypto era) -> ImpTestM era (RewardAccount (EraCrypto era)) registerStakeCredential Credential 'Staking (EraCrypto era) cred forall era. ConwayEraImp era => Credential 'Staking (EraCrypto era) -> ImpTestM era () submitAndExpireProposalToMakeReward Credential 'Staking (EraCrypto era) cred Coin rw <- forall era. HasCallStack => Credential 'Staking (EraCrypto era) -> ImpTestM era Coin lookupReward Credential 'Staking (EraCrypto era) cred forall (f :: * -> *) a. Applicative f => a -> f a pure (RewardAcnt (EraCrypto era) ra, Coin rw)