{-# 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 (hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule)
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 =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp 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
      pv <- forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams @era (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL

      stakeKey <- freshKeyHash
      rwdAccount <- getRewardAccountFor $ KeyHashObj stakeKey
      let
        tx =
          TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
            TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l era) Withdrawals
withdrawalsTxBodyL
                ((Withdrawals -> Identity Withdrawals)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Withdrawals -> TxBody TopTx era -> TxBody TopTx 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 =
          ( if ProtVer -> Bool
hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule ProtVer
pv
              then ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era)
-> (Withdrawals -> ConwayLedgerPredFailure era)
-> Withdrawals
-> EraRuleFailure "LEDGER" era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Withdrawals -> ConwayLedgerPredFailure era
ConwayWithdrawalsMissingAccounts @era
              else 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)
-> (Withdrawals -> ConwayCertsPredFailure era)
-> Withdrawals
-> EraRuleFailure "LEDGER" era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Withdrawals -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS @era
          )
            (Withdrawals -> EraRuleFailure "LEDGER" era)
-> Withdrawals -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
rwdAccount, Integer -> Coin
Coin Integer
20)]
       in
        submitBootstrapAware
          (submitTx_ tx)
          (submitFailingTx tx)
          ( FailBootstrapAndPostBootstrap $
              FailBoth
                { bootstrapFailures = [notInRewardsFailure]
                , postBootstrapFailures =
                    [ notInRewardsFailure
                    , injectFailure (ConwayWdrlNotDelegatedToDRep [stakeKey])
                    ]
                }
          )
      (registeredRwdAccount, reward, stakeKey2) <- setupRewardAccount
      void $ delegateToDRep (KeyHashObj stakeKey2) (Coin 1_000_000) DRepAlwaysNoConfidence
      let
        tx =
          TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
            TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l era) Withdrawals
withdrawalsTxBodyL
                ((Withdrawals -> Identity Withdrawals)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Withdrawals -> TxBody TopTx era -> TxBody TopTx 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 =
          ( if ProtVer -> Bool
hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule ProtVer
pv
              then ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era)
-> (Withdrawals -> ConwayLedgerPredFailure era)
-> Withdrawals
-> EraRuleFailure "LEDGER" era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Withdrawals -> ConwayLedgerPredFailure era
ConwayWithdrawalsMissingAccounts @era
              else 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)
-> (Withdrawals -> ConwayCertsPredFailure era)
-> Withdrawals
-> EraRuleFailure "LEDGER" era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Withdrawals -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS @era
          )
            (Withdrawals -> EraRuleFailure "LEDGER" era)
-> Withdrawals -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
rwdAccount, Coin
forall t. Val t => t
zero)]
       in
        submitBootstrapAware
          (submitTx_ tx)
          (submitFailingTx tx)
          ( FailBootstrapAndPostBootstrap $
              FailBoth
                { bootstrapFailures = [notInRewardsFailure]
                , postBootstrapFailures =
                    [ notInRewardsFailure
                    , injectFailure (ConwayWdrlNotDelegatedToDRep [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
      pv <- forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams @era (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL

      (rwdAccount1, reward1, stakeKey1) <- setupRewardAccount
      (rwdAccount2, reward2, stakeKey2) <- setupRewardAccount
      void $ delegateToDRep (KeyHashObj stakeKey1) (Coin 1_000_000) DRepAlwaysAbstain
      void $ delegateToDRep (KeyHashObj stakeKey2) (Coin 1_000_000) DRepAlwaysAbstain
      submitFailingTx
        ( mkBasicTx $
            mkBasicTxBody
              & withdrawalsTxBodyL
                .~ Withdrawals
                  [ (rwdAccount1, reward1 <+> Coin 1)
                  , (rwdAccount2, reward2)
                  ]
        )
        [ ( if hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule pv
              then injectFailure . ConwayIncompleteWithdrawals @era
              else injectFailure . WithdrawalsNotInRewardsCERTS @era
          )
            $ Withdrawals [(rwdAccount1, reward1 <+> Coin 1)]
        ]

      submitFailingTx
        ( mkBasicTx $
            mkBasicTxBody
              & withdrawalsTxBodyL
                .~ Withdrawals
                  [(rwdAccount1, zero)]
        )
        [ ( if hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule pv
              then injectFailure . ConwayIncompleteWithdrawals @era
              else injectFailure . WithdrawalsNotInRewardsCERTS @era
          )
            $ Withdrawals [(rwdAccount1, zero)]
        ]
  where
    setupRewardAccount :: ImpM (LedgerSpec era) (RewardAccount, Coin, KeyHash 'Staking)
setupRewardAccount = do
      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 = KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
      ra <- registerStakeCredential cred
      submitAndExpireProposalToMakeReward cred
      b <- getBalance cred
      pure (ra, b, kh)