{-# 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)