{-# 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 (conwayOnlySpec, spec) where

import Cardano.Ledger.Address
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Rules (
  ConwayLedgerPredFailure (..),
  ConwayUtxoPredFailure (..),
 )
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.DRep (DRep (..))
import Cardano.Ledger.Plutus (SLanguage (SPlutusV3), hashPlutusScript)
import Cardano.Ledger.Val (Val (..))
import qualified Data.Map.NonEmpty as NEM
import qualified Data.Set.NonEmpty as NES
import Data.Typeable (Typeable)
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum)

conwayOnlySpec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
conwayOnlySpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
conwayOnlySpec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CERTS" (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
-> 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 staking address" (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

      stakeKey <- ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      accountAddress <- getAccountAddressFor $ KeyHashObj stakeKey
      let
        tx :: forall l. Typeable l => Tx l era
        tx =
          TxBody l era -> Tx l era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody l era -> Tx l era) -> TxBody l era -> Tx l era
forall a b. (a -> b) -> a -> b
$
            TxBody l era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              TxBody l era -> (TxBody l era -> TxBody l era) -> TxBody l era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody l era -> Identity (TxBody l 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 l era -> Identity (TxBody l era))
-> Withdrawals -> TxBody l era -> TxBody l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> Withdrawals
Withdrawals [(AccountAddress
accountAddress, Integer -> Coin
Coin Integer
20)]
        notInRewardsFailure =
          (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) (Withdrawals -> EraRuleFailure "LEDGER" era)
-> Withdrawals -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
            Map AccountAddress Coin -> Withdrawals
Withdrawals [(AccountAddress
accountAddress, Integer -> Coin
Coin Integer
20)]
       in
        submitBootstrapAware
          (submitAnyTx_ tx)
          (submitFailingSubsetTx tx)
          ( FailBootstrapAndPostBootstrap $
              FailBoth
                { bootstrapFailures = [notInRewardsFailure]
                , postBootstrapFailures =
                    [ notInRewardsFailure
                    , injectFailure (ConwayWdrlNotDelegatedToDRep [stakeKey])
                    ]
                }
          )
      (registeredAccountAddress, reward, stakeKey2) <- setupAccountAddress
      void $ delegateToDRep (KeyHashObj stakeKey2) (Coin 1_000_000) DRepAlwaysNoConfidence
      let
        tx :: forall l. Typeable l => Tx l era
        tx =
          TxBody l era -> Tx l era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody l era -> Tx l era) -> TxBody l era -> Tx l era
forall a b. (a -> b) -> a -> b
$
            TxBody l era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              TxBody l era -> (TxBody l era -> TxBody l era) -> TxBody l era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody l era -> Identity (TxBody l 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 l era -> Identity (TxBody l era))
-> Withdrawals -> TxBody l era -> TxBody l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> Withdrawals
Withdrawals [(AccountAddress
accountAddress, Coin
forall t. Val t => t
zero), (AccountAddress
registeredAccountAddress, Coin
reward)]
        notInRewardsFailure =
          (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) (Withdrawals -> EraRuleFailure "LEDGER" era)
-> Withdrawals -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
            Map AccountAddress Coin -> Withdrawals
Withdrawals [(AccountAddress
accountAddress, Coin
forall t. Val t => t
zero)]
       in
        submitBootstrapAware
          (submitAnyTx_ tx)
          (submitFailingSubsetTx 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 with the wrong network" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      stakeKey <- ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      accountAddress <- registerStakeCredential (KeyHashObj stakeKey)
      let wrongNetworkAccount = AccountAddress
accountAddress AccountAddress
-> (AccountAddress -> AccountAddress) -> AccountAddress
forall a b. a -> (a -> b) -> b
& (Network -> Identity Network)
-> AccountAddress -> Identity AccountAddress
Lens' AccountAddress Network
accountAddressNetworkIdL ((Network -> Identity Network)
 -> AccountAddress -> Identity AccountAddress)
-> Network -> AccountAddress -> AccountAddress
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Network
Mainnet
          withdrawals = Map AccountAddress Coin -> Withdrawals
Withdrawals [(AccountAddress
wrongNetworkAccount, Coin
forall t. Val t => t
zero)]
          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
.~ Withdrawals
withdrawals
          notInRewardsFailure = 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 (Withdrawals -> EraRuleFailure "LEDGER" era)
-> Withdrawals -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Withdrawals
withdrawals
      let wrongNetworkFailure =
            ConwayUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayUtxoPredFailure era -> EraRuleFailure "LEDGER" era)
-> (NonEmptySet AccountAddress -> ConwayUtxoPredFailure era)
-> NonEmptySet AccountAddress
-> EraRuleFailure "LEDGER" era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Network -> NonEmptySet AccountAddress -> ConwayUtxoPredFailure era
WrongNetworkWithdrawal @era Network
Testnet (NonEmptySet AccountAddress -> EraRuleFailure "LEDGER" era)
-> NonEmptySet AccountAddress -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ AccountAddress -> NonEmptySet AccountAddress
forall a. a -> NonEmptySet a
NES.singleton AccountAddress
wrongNetworkAccount
      void $ delegateToDRep (KeyHashObj stakeKey) (Coin 1_000_000) DRepAlwaysAbstain
      -- when the network is wrong, missing account failure is emitted even if the stake credential is registered
      submitFailingTx tx [notInRewardsFailure, wrongNetworkFailure]

spec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CERTS" (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
-> 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 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

      (accountAddress1, reward1, stakeKey1) <- ImpM (LedgerSpec era) (AccountAddress, Coin, KeyHash Staking)
forall era.
ConwayEraImp era =>
ImpM (LedgerSpec era) (AccountAddress, Coin, KeyHash Staking)
setupAccountAddress
      (accountAddress2, reward2, stakeKey2) <- setupAccountAddress
      void $ delegateToDRep (KeyHashObj stakeKey1) (Coin 1_000_000) DRepAlwaysAbstain
      void $ delegateToDRep (KeyHashObj stakeKey2) (Coin 1_000_000) DRepAlwaysAbstain

      -- Force legacy mode by including a PV3 script in our Tx's
      txIn <- produceScript . hashPlutusScript $ alwaysSucceedsNoDatum SPlutusV3

      submitFailingSubsetTx
        ( mkBasicTx $
            mkBasicTxBody
              & inputsTxBodyL
                .~ [txIn]
              & withdrawalsTxBodyL
                .~ Withdrawals
                  [ (accountAddress1, reward1 <+> Coin 1)
                  , (accountAddress2, reward2)
                  ]
        )
        [ injectFailure . ConwayIncompleteWithdrawals @era $
            NEM.singleton accountAddress1 $
              Mismatch (reward1 <+> Coin 1) reward1
        ]

      submitFailingSubsetTx
        ( mkBasicTx $
            mkBasicTxBody
              & inputsTxBodyL
                .~ [txIn]
              & withdrawalsTxBodyL
                .~ Withdrawals
                  [(accountAddress1, zero)]
        )
        [ injectFailure . ConwayIncompleteWithdrawals @era $
            NEM.singleton accountAddress1 $
              Mismatch zero reward1
        ]

setupAccountAddress ::
  forall era.
  ConwayEraImp era =>
  ImpM (LedgerSpec era) (AccountAddress, Coin, KeyHash Staking)
setupAccountAddress :: forall era.
ConwayEraImp era =>
ImpM (LedgerSpec era) (AccountAddress, Coin, KeyHash Staking)
setupAccountAddress = 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)