{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.Conway.Imp.UtxoSpec (
  spec,
  conwayOnlySpec,
) where

import Cardano.Ledger.Address
import Cardano.Ledger.Alonzo.Scripts
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.PParams (ppMinFeeRefScriptCostPerByteL)
import qualified Cardano.Ledger.Conway.Rules as Conway
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Credential
import Cardano.Ledger.Plutus.Language (SLanguage (..))
import Cardano.Ledger.Shelley.LedgerState
import qualified Cardano.Ledger.Shelley.Rules as Shelley (ShelleyUtxoPredFailure (..))
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.UTxO (getShelleyMinFeeTxUtxo)
import Cardano.Ledger.State
import Cardano.Ledger.Val
import qualified Data.List.NonEmpty as NE
import qualified Data.Sequence.Strict as SSeq
import Lens.Micro
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Rational ((%!))
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum)

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
"UTXO" (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
"Certificates" (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
"Reg/UnReg collect and refund correct amounts" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      utxoStart <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
      accountDeposit <- getsPParams ppKeyDepositL
      stakePoolDeposit <- getsPParams ppPoolDepositL
      dRepDeposit <- getsPParams ppDRepDepositL
      cred0 <- KeyHashObj <$> freshKeyHash @Staking
      cred1 <- KeyHashObj <$> freshKeyHash @Staking
      cred2 <- KeyHashObj <$> freshKeyHash @Staking
      cred3 <- KeyHashObj <$> freshKeyHash @Staking
      cred4 <- KeyHashObj <$> freshKeyHash @Staking
      poolId <- freshKeyHash
      poolParams <- freshPoolParams poolId (AccountAddress Testnet (AccountId cred0))
      dRepCred <- KeyHashObj <$> freshKeyHash @DRepRole
      let delegatee = KeyHash StakePool -> DRep -> Delegatee
DelegStakeVote KeyHash StakePool
poolId (Credential DRepRole -> DRep
DRepCredential Credential DRepRole
dRepCred)
      anchor <- arbitrary
      txRegister <-
        submitTx $
          mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL
              .~ SSeq.fromList
                [ RegPoolTxCert poolParams
                , RegDRepTxCert dRepCred dRepDeposit anchor
                , RegDepositDelegTxCert cred0 delegatee accountDeposit
                , RegDepositTxCert cred1 accountDeposit
                , RegDepositTxCert cred2 accountDeposit
                , RegDepositTxCert cred3 accountDeposit
                , UnRegDepositTxCert cred1 accountDeposit
                , UnRegDepositTxCert cred2 accountDeposit
                , RegDepositTxCert cred4 accountDeposit
                ]
      utxoAfterRegister <- getUTxO
      -- Overwrite deposit protocol parameters in order to ensure they does not affect refunds
      modifyPParams
        ( \PParams era
pp ->
            PParams era
pp
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
3
        )
      (sumUTxO utxoStart <-> sumUTxO utxoAfterRegister)
        `shouldBe` inject
          ( (txRegister ^. bodyTxL . feeTxBodyL)
              <+> ((3 :: Int) <×> accountDeposit) -- Only three accounts retained that are still registered
              <+> stakePoolDeposit
              <+> dRepDeposit
          )
      curEpochNo <- getsNES nesELL
      txUnRegister <-
        submitTx $
          mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL
              .~ SSeq.fromList
                [ RetirePoolTxCert poolId (succ curEpochNo)
                , UnRegDRepTxCert dRepCred dRepDeposit
                , UnRegDepositTxCert cred3 accountDeposit
                , UnRegDepositTxCert cred4 accountDeposit
                ]
      utxoAfterUnRegister <- getUTxO
      let totalFees = (Tx TopTx era
txRegister Tx TopTx era -> Getting Coin (Tx TopTx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Tx TopTx era -> Const Coin (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const Coin (TxBody TopTx era))
 -> Tx TopTx era -> Const Coin (Tx TopTx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Getting Coin (Tx TopTx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx era -> Const Coin (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> (Tx TopTx era
txUnRegister Tx TopTx era -> Getting Coin (Tx TopTx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Tx TopTx era -> Const Coin (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const Coin (TxBody TopTx era))
 -> Tx TopTx era -> Const Coin (Tx TopTx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Getting Coin (Tx TopTx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx era -> Const Coin (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL)
      fees <- getsNES (nesEsL . esLStateL . lsUTxOStateL . utxosFeesL)
      totalFees `shouldBe` fees
      -- only deposits for stake pool and its account are not refunded at this point
      (sumUTxO utxoStart <-> sumUTxO utxoAfterUnRegister)
        `shouldBe` inject (totalFees <+> stakePoolDeposit <+> accountDeposit)
      passEpoch
      -- Check for successfull pool refund
      getBalance cred0 `shouldReturn` stakePoolDeposit
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DRepNotRegistered" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      dRepCred <- KeyHash DRepRole -> Credential DRepRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash DRepRole -> Credential DRepRole)
-> ImpM (LedgerSpec era) (KeyHash DRepRole)
-> ImpM (LedgerSpec era) (Credential DRepRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash DRepRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      -- Make sure deposit is positive
      dRepDeposit <- (<> Coin 1) <$> arbitrary
      addr1 <- freshKeyAddr_
      let txAmount = Integer -> Coin
Coin Integer
2000000
      txIn <- sendCoinTo addr1 txAmount
      addr2 <- freshKeyAddr_
      (_, rootTxOut) <- getImpRootTxOut
      let
        rootTxOutValue = TxOut era
rootTxOut TxOut era
-> Getting (Value era) (TxOut era) (Value era) -> Value era
forall s a. s -> Getting a s a -> a
^. Getting (Value era) (TxOut era) (Value era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL
        txBody =
          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
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
            TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr2 Value era
MaryValue
forall a. Monoid a => a
mempty]
        addUnRegDRepTxCert :: Tx TopTx era -> Tx TopTx era
        addUnRegDRepTxCert Tx TopTx era
tx =
          Tx TopTx era
tx
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxCert era) -> Tx TopTx era -> Tx TopTx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [Credential DRepRole -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential DRepRole -> Coin -> TxCert era
UnRegDRepTxCert Credential DRepRole
dRepCred Coin
dRepDeposit :: TxCert era]
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> TxWits era -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
forall era. EraTxWits era => TxWits era
mkBasicTxWits
      withPostFixup (updateAddrTxWits . addUnRegDRepTxCert) $
        submitFailingTx
          (mkBasicTx txBody)
          [ injectFailure $
              Shelley.ValueNotConservedUTxO $
                Mismatch
                  (rootTxOutValue <> inject txAmount <> inject dRepDeposit)
                  (rootTxOutValue <> inject txAmount)
          , injectFailure $ Conway.ConwayDRepNotRegistered dRepCred
          ]
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Reference scripts" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    let
      nativeScript :: ImpM (LedgerSpec era) (NativeScript era)
nativeScript = forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature @era (KeyHash Witness -> NativeScript era)
-> ImpM (LedgerSpec era) (KeyHash Witness)
-> ImpM (LedgerSpec era) (NativeScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Witness)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      checkMinFeeUsingRefScripts :: [AlonzoScript era] -> ImpM (LedgerSpec era) ()
checkMinFeeUsingRefScripts [AlonzoScript era]
refScripts = do
        (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((NonNegativeInterval -> Identity NonNegativeInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) NonNegativeInterval
Lens' (PParams era) NonNegativeInterval
ppMinFeeRefScriptCostPerByteL ((NonNegativeInterval -> Identity NonNegativeInterval)
 -> PParams era -> Identity (PParams era))
-> NonNegativeInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
10 Integer -> Integer -> NonNegativeInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1))
        scriptTxIn <- ImpM (LedgerSpec era) (NativeScript era)
nativeScript ImpM (LedgerSpec era) (NativeScript era)
-> (NativeScript era -> ImpM (LedgerSpec era) ScriptHash)
-> ImpM (LedgerSpec era) ScriptHash
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
>>= NativeScript era -> ImpM (LedgerSpec era) ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript ImpM (LedgerSpec era) ScriptHash
-> (ScriptHash -> ImpTestM era TxIn) -> ImpTestM era TxIn
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
>>= ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript
        refIns <- produceRefScripts (NE.fromList refScripts)
        tx <- submitTxWithRefInputs scriptTxIn refIns
        minFeeDiff <- do
          utxo <- getUTxO
          pp <- getsNES $ nesEsL . curPParamsEpochStateL
          pure $ getMinFeeTxUtxo pp tx utxo <-> getShelleyMinFeeTxUtxo pp tx
        refScriptFee <- getsPParams ppMinFeeRefScriptCostPerByteL
        -- we check that the difference between conway and shelleyMinFee computation is exactly
        -- the size of the sizes of the reference scripts
        minFeeDiff
          `shouldBe` Coin
            ( floor $
                fromIntegral @Int @Rational (sum $ originalBytesSize <$> refScripts)
                  * unboundRational refScriptFee
            )
      distinctScripts :: ImpM (LedgerSpec era) [AlonzoScript era]
distinctScripts = do
        nativeScripts <- Int
-> ImpM (LedgerSpec era) (AlonzoScript era)
-> ImpM (LedgerSpec era) [AlonzoScript era]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 (NativeScript era -> Script era
NativeScript era -> AlonzoScript era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript (NativeScript era -> AlonzoScript era)
-> ImpM (LedgerSpec era) (NativeScript era)
-> ImpM (LedgerSpec era) (AlonzoScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (NativeScript era)
nativeScript)
        Just plutusScriptV2 <- pure $ mkPlutusScript @era $ alwaysSucceedsNoDatum SPlutusV2
        Just plutusScriptV3 <- pure $ mkPlutusScript @era $ alwaysSucceedsNoDatum SPlutusV3
        pure $ nativeScripts ++ [fromPlutusScript plutusScriptV2, fromPlutusScript plutusScriptV3]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"required reference script counts towards the minFee calculation" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      spendingScript <- ImpM (LedgerSpec era) (NativeScript era)
nativeScript
      checkMinFeeUsingRefScripts [fromNativeScript spendingScript]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reference scripts not required for spending the input count towards the minFee calculation" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      spendingScript <- ImpM (LedgerSpec era) (NativeScript era)
nativeScript
      extraScripts <- distinctScripts
      checkMinFeeUsingRefScripts $ fromNativeScript spendingScript : extraScripts

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a scripts referenced several times counts for each reference towards the minFee calculation" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      spendingScript <- ImpM (LedgerSpec era) (NativeScript era)
nativeScript
      extraScripts <- distinctScripts
      checkMinFeeUsingRefScripts $
        [fromNativeScript spendingScript, fromNativeScript spendingScript]
          ++ extraScripts
          ++ extraScripts

conwayOnlySpec ::
  forall era.
  ( ConwayEraImp era
  , ShelleyEraTxCert era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
conwayOnlySpec :: forall era.
(ConwayEraImp era, ShelleyEraTxCert 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
"UTXO" (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
"Certificates" (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
"Reg/UnReg collect and refund correct amounts" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      utxoStart <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
      accountDeposit <- getsPParams ppKeyDepositL
      stakePoolDeposit <- getsPParams ppPoolDepositL
      dRepDeposit <- getsPParams ppDRepDepositL
      cred0 <- KeyHashObj <$> freshKeyHash @Staking
      cred1 <- KeyHashObj <$> freshKeyHash @Staking
      cred2 <- KeyHashObj <$> freshKeyHash @Staking
      cred3 <- KeyHashObj <$> freshKeyHash @Staking
      cred4 <- KeyHashObj <$> freshKeyHash @Staking
      poolId <- freshKeyHash
      poolParams <- freshPoolParams poolId (AccountAddress Testnet (AccountId cred0))
      dRepCred <- KeyHashObj <$> freshKeyHash @DRepRole
      let delegatee = KeyHash StakePool -> DRep -> Delegatee
DelegStakeVote KeyHash StakePool
poolId (Credential DRepRole -> DRep
DRepCredential Credential DRepRole
dRepCred)
      anchor <- arbitrary
      txRegister <-
        submitTx $
          mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL
              .~ SSeq.fromList
                [ RegPoolTxCert poolParams
                , RegDRepTxCert dRepCred dRepDeposit anchor
                , RegDepositDelegTxCert cred0 delegatee accountDeposit
                , RegTxCert cred1
                , RegDepositTxCert cred2 accountDeposit
                , RegDepositTxCert cred3 accountDeposit
                , UnRegTxCert cred2
                , UnRegDepositTxCert cred1 accountDeposit
                , RegDepositTxCert cred4 accountDeposit
                ]
      utxoAfterRegister <- getUTxO
      -- Overwrite deposit protocol parameters in order to ensure they does not affect refunds
      modifyPParams
        ( \PParams era
pp ->
            PParams era
pp
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
3
        )
      (sumUTxO utxoStart <-> sumUTxO utxoAfterRegister)
        `shouldBe` inject
          ( (txRegister ^. bodyTxL . feeTxBodyL)
              <+> ((3 :: Int) <×> accountDeposit) -- Only three accounts retained that are still registered
              <+> stakePoolDeposit
              <+> dRepDeposit
          )
      curEpochNo <- getsNES nesELL
      txUnRegister <-
        submitTx $
          mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL
              .~ SSeq.fromList
                [ RetirePoolTxCert poolId (succ curEpochNo)
                , UnRegDRepTxCert dRepCred dRepDeposit
                , UnRegTxCert cred3
                , UnRegDepositTxCert cred4 accountDeposit
                ]
      utxoAfterUnRegister <- getUTxO
      let totalFees = (Tx TopTx era
txRegister Tx TopTx era -> Getting Coin (Tx TopTx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Tx TopTx era -> Const Coin (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const Coin (TxBody TopTx era))
 -> Tx TopTx era -> Const Coin (Tx TopTx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Getting Coin (Tx TopTx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx era -> Const Coin (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> (Tx TopTx era
txUnRegister Tx TopTx era -> Getting Coin (Tx TopTx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Tx TopTx era -> Const Coin (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const Coin (TxBody TopTx era))
 -> Tx TopTx era -> Const Coin (Tx TopTx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Getting Coin (Tx TopTx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx era -> Const Coin (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL)
      fees <- getsNES (nesEsL . esLStateL . lsUTxOStateL . utxosFeesL)
      totalFees `shouldBe` fees
      -- only deposits for stake pool and its account are not refunded at this point
      (sumUTxO utxoStart <-> sumUTxO utxoAfterUnRegister)
        `shouldBe` inject (totalFees <+> stakePoolDeposit <+> accountDeposit)
      passEpoch
      -- Check for successfull pool refund
      getBalance cred0 `shouldReturn` stakePoolDeposit