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

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

      (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
      ImpM (LedgerSpec era) (KeyPair 'Payment)
-> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) (KeyPair 'Payment)
 -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (KeyPair 'Payment)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ Credential 'Staking
-> Coin -> DRep -> ImpM (LedgerSpec era) (KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep (KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
stakeKey1) (Integer -> Coin
Coin Integer
1_000_000) DRep
DRepAlwaysAbstain
      ImpM (LedgerSpec era) (KeyPair 'Payment)
-> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) (KeyPair 'Payment)
 -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (KeyPair 'Payment)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ Credential 'Staking
-> Coin -> DRep -> ImpM (LedgerSpec era) (KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep (KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
stakeKey2) (Integer -> Coin
Coin Integer
1_000_000) DRep
DRepAlwaysAbstain
      Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        ( TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
            TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
              TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
                ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
                  [ (RewardAccount
rwdAccount1, Coin
reward1 Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Integer -> Coin
Coin Integer
1)
                  , (RewardAccount
rwdAccount2, Coin
reward2)
                  ]
        )
        [ ( if ProtVer -> Bool
hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule ProtVer
pv
              then ConwayLedgerPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayLedgerPredFailure era
 -> PredicateFailure (EraRule "LEDGER" era))
-> (Withdrawals -> ConwayLedgerPredFailure era)
-> Withdrawals
-> PredicateFailure (EraRule "LEDGER" era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Withdrawals -> ConwayLedgerPredFailure era
ConwayIncompleteWithdrawals @era
              else ConwayCertsPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayCertsPredFailure era
 -> PredicateFailure (EraRule "LEDGER" era))
-> (Withdrawals -> ConwayCertsPredFailure era)
-> Withdrawals
-> PredicateFailure (EraRule "LEDGER" era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Withdrawals -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS @era
          )
            (Withdrawals
 -> Item (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> Withdrawals
-> Item (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
forall a b. (a -> b) -> a -> b
$ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
rwdAccount1, Coin
reward1 Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Integer -> Coin
Coin Integer
1)]
        ]

      Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        ( TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
            TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
              TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
                ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
                  [(RewardAccount
rwdAccount1, Coin
forall t. Val t => t
zero)]
        )
        [ ( if ProtVer -> Bool
hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule ProtVer
pv
              then ConwayLedgerPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayLedgerPredFailure era
 -> PredicateFailure (EraRule "LEDGER" era))
-> (Withdrawals -> ConwayLedgerPredFailure era)
-> Withdrawals
-> PredicateFailure (EraRule "LEDGER" era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Withdrawals -> ConwayLedgerPredFailure era
ConwayIncompleteWithdrawals @era
              else ConwayCertsPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
ConwayCertsPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayCertsPredFailure era
 -> PredicateFailure (EraRule "LEDGER" era))
-> (Withdrawals -> ConwayCertsPredFailure era)
-> Withdrawals
-> PredicateFailure (EraRule "LEDGER" era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Withdrawals -> ConwayCertsPredFailure era
WithdrawalsNotInRewardsCERTS @era
          )
            (Withdrawals
 -> Item (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> Withdrawals
-> Item (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
forall a b. (a -> b) -> a -> b
$ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
rwdAccount1, Coin
forall t. Val t => t
zero)]
        ]
  where
    setupRewardAccount :: ImpM (LedgerSpec era) (RewardAccount, Coin, KeyHash 'Staking)
setupRewardAccount = do
      KeyHash 'Staking
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 :: Credential 'Staking
cred = KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
      RewardAccount
ra <- Credential 'Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
      Credential 'Staking -> ImpM (LedgerSpec era) ()
forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
      Coin
b <- Credential 'Staking -> ImpTestM era Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getBalance Credential 'Staking
cred
      (RewardAccount, Coin, KeyHash 'Staking)
-> ImpM (LedgerSpec era) (RewardAccount, Coin, KeyHash 'Staking)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardAccount
ra, Coin
b, KeyHash 'Staking
kh)