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

      KeyHash 'Staking (EraCrypto era)
stakeKey <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      RewardAccount (EraCrypto era)
rwdAccount <- forall era.
Credential 'Staking (EraCrypto era)
-> ImpTestM era (RewardAccount (EraCrypto era))
getRewardAccountFor forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
stakeKey
      let
        tx :: Tx era
tx =
          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 (RewardAccount c) Coin -> Withdrawals c
Withdrawals [(RewardAccount (EraCrypto era)
rwdAccount, Integer -> Coin
Coin Integer
20)]
        notInRewardsFailure :: EraRuleFailure "LEDGER" era
notInRewardsFailure = 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 [(RewardAccount (EraCrypto era)
rwdAccount, Integer -> Coin
Coin Integer
20)]
       in
        forall era a.
EraGov era =>
ImpTestM era a
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpTestM era a)
-> SubmitFailureExpectation era
-> ImpTestM era a
submitBootstrapAware
          (forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx)
          (forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx)
          ( forall era. FailBoth era -> SubmitFailureExpectation era
FailBootstrapAndPostBootstrap forall a b. (a -> b) -> a -> b
$
              FailBoth
                { bootstrapFailures :: NonEmpty (PredicateFailure (EraRule "LEDGER" era))
bootstrapFailures = [EraRuleFailure "LEDGER" era
notInRewardsFailure]
                , postBootstrapFailures :: NonEmpty (PredicateFailure (EraRule "LEDGER" era))
postBootstrapFailures =
                    [ EraRuleFailure "LEDGER" era
notInRewardsFailure
                    , forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (forall era.
NonEmpty (KeyHash 'Staking (EraCrypto era))
-> ConwayLedgerPredFailure era
ConwayWdrlNotDelegatedToDRep [KeyHash 'Staking (EraCrypto era)
stakeKey])
                    ]
                }
          )
      (RewardAccount (EraCrypto era)
registeredRwdAccount, Coin
reward, KeyHash 'Staking (EraCrypto era)
stakeKey2) <- ImpM
  (LedgerSpec era)
  (RewardAccount (EraCrypto era), Coin,
   KeyHash 'Staking (EraCrypto era))
setupRewardAccount
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraImp era =>
Credential 'Staking (EraCrypto era)
-> Coin
-> DRep (EraCrypto era)
-> ImpTestM era (KeyPair 'Payment (EraCrypto era))
delegateToDRep (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
stakeKey2) (Integer -> Coin
Coin Integer
1_000_000) forall c. DRep c
DRepAlwaysNoConfidence
      let
        tx :: Tx era
tx =
          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 (RewardAccount c) Coin -> Withdrawals c
Withdrawals [(RewardAccount (EraCrypto era)
rwdAccount, forall t. Val t => t
zero), (RewardAccount (EraCrypto era)
registeredRwdAccount, Coin
reward)]
        notInRewardsFailure :: EraRuleFailure "LEDGER" era
notInRewardsFailure = 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 [(RewardAccount (EraCrypto era)
rwdAccount, forall t. Val t => t
zero)]
       in
        forall era a.
EraGov era =>
ImpTestM era a
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpTestM era a)
-> SubmitFailureExpectation era
-> ImpTestM era a
submitBootstrapAware
          (forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx)
          (forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx)
          ( forall era. FailBoth era -> SubmitFailureExpectation era
FailBootstrapAndPostBootstrap forall a b. (a -> b) -> a -> b
$
              FailBoth
                { bootstrapFailures :: NonEmpty (PredicateFailure (EraRule "LEDGER" era))
bootstrapFailures = [EraRuleFailure "LEDGER" era
notInRewardsFailure]
                , postBootstrapFailures :: NonEmpty (PredicateFailure (EraRule "LEDGER" era))
postBootstrapFailures =
                    [ EraRuleFailure "LEDGER" era
notInRewardsFailure
                    , forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (forall era.
NonEmpty (KeyHash 'Staking (EraCrypto era))
-> ConwayLedgerPredFailure era
ConwayWdrlNotDelegatedToDRep [KeyHash 'Staking (EraCrypto era)
stakeKey])
                    ]
                }
          )

    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

      (RewardAccount (EraCrypto era)
rwdAccount1, Coin
reward1, KeyHash 'Staking (EraCrypto era)
stakeKey1) <- ImpM
  (LedgerSpec era)
  (RewardAccount (EraCrypto era), Coin,
   KeyHash 'Staking (EraCrypto era))
setupRewardAccount
      (RewardAccount (EraCrypto era)
rwdAccount2, Coin
reward2, KeyHash 'Staking (EraCrypto era)
stakeKey2) <- ImpM
  (LedgerSpec era)
  (RewardAccount (EraCrypto era), Coin,
   KeyHash 'Staking (EraCrypto era))
setupRewardAccount
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraImp era =>
Credential 'Staking (EraCrypto era)
-> Coin
-> DRep (EraCrypto era)
-> ImpTestM era (KeyPair 'Payment (EraCrypto era))
delegateToDRep (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
stakeKey1) (Integer -> Coin
Coin Integer
1_000_000) forall c. DRep c
DRepAlwaysAbstain
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraImp era =>
Credential 'Staking (EraCrypto era)
-> Coin
-> DRep (EraCrypto era)
-> ImpTestM era (KeyPair 'Payment (EraCrypto era))
delegateToDRep (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
stakeKey2) (Integer -> Coin
Coin Integer
1_000_000) forall c. DRep c
DRepAlwaysAbstain
      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 (RewardAccount c) Coin -> Withdrawals c
Withdrawals
                  [ (RewardAccount (EraCrypto era)
rwdAccount1, Coin
reward1 forall t. Val t => t -> t -> t
<+> Integer -> Coin
Coin Integer
1)
                  , (RewardAccount (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 [(RewardAccount (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 (RewardAccount c) Coin -> Withdrawals c
Withdrawals
                  [(RewardAccount (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 [(RewardAccount (EraCrypto era)
rwdAccount1, forall t. Val t => t
zero)]]
  where
    setupRewardAccount :: ImpM
  (LedgerSpec era)
  (RewardAccount (EraCrypto era), Coin,
   KeyHash 'Staking (EraCrypto era))
setupRewardAccount = do
      KeyHash 'Staking (EraCrypto era)
kh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      let cred :: Credential 'Staking (EraCrypto era)
cred = forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh
      RewardAccount (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 (RewardAccount (EraCrypto era)
ra, Coin
rw, KeyHash 'Staking (EraCrypto era)
kh)