{-# 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
stakeKey <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      RewardAccount
rwdAccount <- forall era. Credential 'Staking -> ImpTestM era RewardAccount
getRewardAccountFor forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
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
withdrawalsTxBodyL
                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 = 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 Coin -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS [(RewardAccount
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) -> ConwayLedgerPredFailure era
ConwayWdrlNotDelegatedToDRep [KeyHash 'Staking
stakeKey])
                    ]
                }
          )
      (RewardAccount
registeredRwdAccount, Coin
reward, KeyHash 'Staking
stakeKey2) <- ImpM (LedgerSpec era) (RewardAccount, Coin, KeyHash 'Staking)
setupRewardAccount
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep (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 =
          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
withdrawalsTxBodyL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
rwdAccount, forall t. Val t => t
zero), (RewardAccount
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 Coin -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS [(RewardAccount
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) -> ConwayLedgerPredFailure era
ConwayWdrlNotDelegatedToDRep [KeyHash 'Staking
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
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
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
stakeKey1) (Integer -> Coin
Coin Integer
1_000_000) DRep
DRepAlwaysAbstain
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
stakeKey2) (Integer -> Coin
Coin Integer
1_000_000) DRep
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
withdrawalsTxBodyL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
                  [ (RewardAccount
rwdAccount1, Coin
reward1 forall t. Val t => t -> t -> t
<+> Integer -> Coin
Coin Integer
1)
                  , (RewardAccount
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 Coin -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS [(RewardAccount
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
withdrawalsTxBodyL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
                  [(RewardAccount
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 Coin -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS [(RewardAccount
rwdAccount1, forall t. Val t => t
zero)]]
  where
    setupRewardAccount :: ImpM (LedgerSpec era) (RewardAccount, Coin, KeyHash 'Staking)
setupRewardAccount = do
      KeyHash 'Staking
kh <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      let cred :: Credential 'Staking
cred = forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
      RewardAccount
ra <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
      forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
      Coin
rw <- forall era.
HasCallStack =>
Credential 'Staking -> ImpTestM era Coin
lookupReward Credential 'Staking
cred
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardAccount
ra, Coin
rw, KeyHash 'Staking
kh)