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

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

import Cardano.Base.Typeable (Typeable)
import Cardano.Ledger.Address
import Cardano.Ledger.BaseTypes
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 (..),
  SubEntitiesPredFailure (..),
 )
import Cardano.Ledger.Plutus
import Cardano.Ledger.Val (Val (..))
import qualified Data.Map.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import qualified Data.Set.NonEmpty as NES
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
"ENTITIES" (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
"Withdrawals 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

    account1 <- ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM (LedgerSpec era) (KeyHash Staking)
-> (KeyHash Staking -> ImpM (LedgerSpec era) AccountAddress)
-> ImpM (LedgerSpec era) AccountAddress
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Credential Staking -> ImpM (LedgerSpec era) AccountAddress
forall era. Credential Staking -> ImpTestM era AccountAddress
getAccountAddressFor (Credential Staking -> ImpM (LedgerSpec era) AccountAddress)
-> (KeyHash Staking -> Credential Staking)
-> KeyHash Staking
-> ImpM (LedgerSpec era) AccountAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj
    account2 <- freshKeyHash >>= getAccountAddressFor . KeyHashObj
    amountX <- Coin . getPositive <$> arbitrary
    let
      txBody :: forall l. Typeable l => TxBody l era
      txBody =
        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
account1, Coin
amountX), (AccountAddress
account2, Coin
forall t. Val t => t
zero)]
    submitFailingTx
      (mkBasicTx txBody)
      [ injectFailure $
          WithdrawalsExceedAccountBalance @era $
            NE.singleton account1 $
              Mismatch amountX mempty
      , injectFailure . MissingAccountsInWithdrawals @era $
          Withdrawals [(account1, amountX), (account2, zero)]
      ]

    account3 <- freshKeyHash >>= getAccountAddressFor . KeyHashObj
    amountY <- Coin . getPositive <$> arbitrary
    let subTxOnlyWithdrawal =
          TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
            TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody SubTx era -> Identity (TxBody SubTx 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 SubTx era -> Identity (TxBody SubTx era))
-> Withdrawals -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> Withdrawals
Withdrawals [(AccountAddress
account3, Coin
amountY)]
    submitFailingTx
      (mkBasicTx $ txBody & subTransactionsTxBodyL .~ [mkBasicTx txBody, subTxOnlyWithdrawal])
      [ injectFailure $
          WithdrawalsExceedAccountBalance @era $
            fromJust $
              NE.fromMap $
                Map.fromList
                  [ (account1, Mismatch (amountX <> amountX) mempty)
                  , (account3, Mismatch amountY mempty)
                  ]
      , injectFailure . MissingAccountsInWithdrawals @era $
          Withdrawals [(account1, amountX), (account2, zero)]
      , injectFailure . SubMissingOriginalAccountsInWithdrawals @era $
          Withdrawals [(account1, amountX), (account2, zero)]
      , injectFailure . SubMissingAccountsInWithdrawals @era $
          Withdrawals [(account1, amountX), (account2, zero)]
      , injectFailure . SubMissingOriginalAccountsInWithdrawals @era $
          Withdrawals [(account3, amountY)]
      , injectFailure . SubMissingAccountsInWithdrawals @era $
          Withdrawals [(account3, amountY)]
      ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Direct deposits to an unregistered 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
    account <- ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM (LedgerSpec era) (KeyHash Staking)
-> (KeyHash Staking -> ImpM (LedgerSpec era) AccountAddress)
-> ImpM (LedgerSpec era) AccountAddress
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Credential Staking -> ImpM (LedgerSpec era) AccountAddress
forall era. Credential Staking -> ImpTestM era AccountAddress
getAccountAddressFor (Credential Staking -> ImpM (LedgerSpec era) AccountAddress)
-> (KeyHash Staking -> Credential Staking)
-> KeyHash Staking
-> ImpM (LedgerSpec era) AccountAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj
    amountX <- Coin . getPositive <$> arbitrary
    let
    let
      txBody :: forall l. Typeable l => TxBody l era
      txBody = 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
& (DirectDeposits -> Identity DirectDeposits)
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) DirectDeposits
forall (l :: TxLevel). Lens' (TxBody l era) DirectDeposits
directDepositsTxBodyL ((DirectDeposits -> Identity DirectDeposits)
 -> TxBody l era -> Identity (TxBody l era))
-> DirectDeposits -> TxBody l era -> TxBody l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> DirectDeposits
DirectDeposits [(AccountAddress
account, Coin
amountX)]
    submitFailingTx
      (mkBasicTx txBody)
      [ injectFailure . MissingAccountsInDirectDeposits @era $
          DirectDeposits [(account, amountX)]
      ]

    account2 <- freshKeyHash >>= getAccountAddressFor . KeyHashObj
    amountY <- Coin . getPositive <$> arbitrary
    amountZ <- Coin . getPositive <$> arbitrary
    let
    let subTxOnlyDirectDeposit =
          TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
            TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (DirectDeposits -> Identity DirectDeposits)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) DirectDeposits
forall (l :: TxLevel). Lens' (TxBody l era) DirectDeposits
directDepositsTxBodyL ((DirectDeposits -> Identity DirectDeposits)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> DirectDeposits -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> DirectDeposits
DirectDeposits [(AccountAddress
account, Coin
amountY), (AccountAddress
account2, Coin
amountZ)]
    submitFailingTx
      (mkBasicTx $ txBody & subTransactionsTxBodyL .~ [mkBasicTx txBody, subTxOnlyDirectDeposit])
      [ injectFailure . MissingAccountsInDirectDeposits @era $
          DirectDeposits [(account, amountX)]
      , injectFailure . SubMissingAccountsInDirectDeposits @era $
          DirectDeposits [(account, amountX)]
      , injectFailure . SubMissingAccountsInDirectDeposits @era $
          DirectDeposits [(account, amountY), (account2, amountZ)]
      ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals of 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 $
          ExceededBalancesInWithdrawals @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)]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals and direct deposits with wrong network id" (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
    let txBody :: forall l. Typeable l => TxBody l era
        txBody =
          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
wrongNetworkAccount, Coin
forall a. Monoid a => a
mempty)]
            TxBody l era -> (TxBody l era -> TxBody l era) -> TxBody l era
forall a b. a -> (a -> b) -> b
& (DirectDeposits -> Identity DirectDeposits)
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) DirectDeposits
forall (l :: TxLevel). Lens' (TxBody l era) DirectDeposits
directDepositsTxBodyL
              ((DirectDeposits -> Identity DirectDeposits)
 -> TxBody l era -> Identity (TxBody l era))
-> DirectDeposits -> TxBody l era -> TxBody l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> DirectDeposits
DirectDeposits [(AccountAddress
wrongNetworkAccount, Integer -> Coin
Coin Integer
50)]

    submitFailingTx
      (mkBasicTx txBody)
      [ injectFailure . WrongNetworkInWithdrawals @era Testnet $ NES.singleton wrongNetworkAccount
      , injectFailure . WrongNetworkInDirectDeposits @era Testnet $ NES.singleton wrongNetworkAccount
      , injectFailure . MissingAccountsInWithdrawals @era $ Withdrawals [(wrongNetworkAccount, mempty)]
      ]

    submitFailingTx
      (mkBasicTx $ txBody & subTransactionsTxBodyL .~ [mkBasicTx txBody])
      [ injectFailure . WrongNetworkInWithdrawals @era Testnet $ NES.singleton wrongNetworkAccount
      , injectFailure . WrongNetworkInDirectDeposits @era Testnet $ NES.singleton wrongNetworkAccount
      , injectFailure . MissingAccountsInWithdrawals @era $ Withdrawals [(wrongNetworkAccount, mempty)]
      , injectFailure . SubWrongNetworkInWithdrawals @era Testnet $ NES.singleton wrongNetworkAccount
      , injectFailure . SubWrongNetworkInDirectDeposits @era Testnet $ NES.singleton wrongNetworkAccount
      ]
  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)