{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Dijkstra.Imp.CertsSpec (spec) where

import Cardano.Ledger.BaseTypes (EpochInterval (..), Mismatch (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.DRep (DRep (..))
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules (
  DijkstraUtxoPredFailure (..),
  EntitiesPredFailure (..),
 )
import Cardano.Ledger.Plutus
import Cardano.Ledger.Val (Val (..))
import qualified Data.Map.NonEmpty as NE
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsWithDatum)

spec :: forall era. DijkstraEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp 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 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 =
          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 AccountAddress Coin -> Withdrawals
Withdrawals [(AccountAddress
accountAddress, Integer -> Coin
Coin Integer
20)]
      submitFailingTx
        tx
        [ injectFailure $
            WithdrawalsExceedAccountBalance @era $
              NE.singleton accountAddress $
                Mismatch (Coin 20) mempty
        , injectFailure (WdrlNotDelegatedToDRep [stakeKey])
        , injectFailure . WithdrawalsMissingAccounts @era $
            Withdrawals [(accountAddress, Coin 20)]
        ]
      (registeredAccountAddress, reward, stakeKey2) <- setupAccountAddress
      void $ delegateToDRep (KeyHashObj stakeKey2) (Coin 1_000_000) DRepAlwaysNoConfidence
      let
        tx2 =
          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 AccountAddress Coin -> Withdrawals
Withdrawals [(AccountAddress
accountAddress, Coin
forall t. Val t => t
zero), (AccountAddress
registeredAccountAddress, Coin
reward)]
      submitFailingTx
        tx2
        [ injectFailure (WdrlNotDelegatedToDRep [stakeKey])
        , injectFailure . WithdrawalsMissingAccounts @era $
            Withdrawals [(accountAddress, zero)]
        ]

    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) <- ImpTestM 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
      submitFailingTx
        ( mkBasicTx $
            mkBasicTxBody
              & withdrawalsTxBodyL
                .~ Withdrawals
                  [ (accountAddress1, reward1 <+> Coin 1)
                  , (accountAddress2, reward2)
                  ]
        )
        [ injectFailure $
            WithdrawalsExceedAccountBalance @era $
              NE.singleton accountAddress1 $
                Mismatch (reward1 <+> Coin 1) reward1
        , injectFailure $
            WithdrawalAmountsExceedAccountBalances @era $
              NE.singleton accountAddress1 $
                Mismatch (reward1 <+> Coin 1) reward1
        ]

      -- in legacy mode, we produce `IncompleteWithdrawals` failure
      txIn <- produceScript . hashPlutusScript $ alwaysSucceedsWithDatum SPlutusV2
      submitFailingTx
        ( mkBasicTx $
            mkBasicTxBody
              & withdrawalsTxBodyL
                .~ Withdrawals
                  [(accountAddress1, zero)]
              & inputsTxBodyL .~ [txIn]
        )
        [ injectFailure . IncompleteWithdrawals @era $
            NE.singleton accountAddress1 $
              Mismatch zero reward1
        ]

      submitTx_ $
        mkBasicTx $
          mkBasicTxBody
            & withdrawalsTxBodyL
              .~ Withdrawals
                [(accountAddress1, zero)]
  where
    setupAccountAddress :: ImpTestM era (AccountAddress, Coin, KeyHash Staking)
    setupAccountAddress :: ImpTestM 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)