{-# 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) where

import Cardano.Ledger.Address
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..))
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..))
import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure (..))
import Cardano.Ledger.Alonzo.Scripts
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.PParams (ppMinFeeRefScriptCostPerByteL)
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Conway.TxInfo (ConwayContextError (..))
import Cardano.Ledger.Credential
import Cardano.Ledger.MemoBytes (getMemoRawBytes)
import Cardano.Ledger.Plutus.Language (
  Plutus (..),
  SLanguage (..),
  hashPlutusScript,
 )
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.UTxO (getShelleyMinFeeTxUtxo)
import Cardano.Ledger.State hiding (balance)
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.Val
import qualified Data.ByteString.Short as SBS (length)
import Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro ((&), (.~), (^.))
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Rational ((%!))
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum, inputsOverlapsWithRefInputs)

spec ::
  forall era.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , Inject (ConwayContextError era) (ContextError era)
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 Inject (ConwayContextError era) (ContextError 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
"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
      UTxO era
utxoStart <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
      Coin
accountDeposit <- Lens' (PParams era) Coin -> ImpTestM era Coin
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (Coin -> f Coin) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
      Coin
stakePoolDeposit <- Lens' (PParams era) Coin -> ImpTestM era Coin
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (Coin -> f Coin) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL
      Coin
dRepDeposit <- Lens' (PParams era) Coin -> ImpTestM era Coin
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (Coin -> f Coin) -> PParams era -> f (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL
      Credential 'Staking
cred0 <- KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Staking -> Credential 'Staking)
-> ImpM (LedgerSpec era) (KeyHash 'Staking)
-> ImpM (LedgerSpec era) (Credential 'Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Staking
      Credential 'Staking
cred1 <- KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Staking -> Credential 'Staking)
-> ImpM (LedgerSpec era) (KeyHash 'Staking)
-> ImpM (LedgerSpec era) (Credential 'Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Staking
      Credential 'Staking
cred2 <- KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Staking -> Credential 'Staking)
-> ImpM (LedgerSpec era) (KeyHash 'Staking)
-> ImpM (LedgerSpec era) (Credential 'Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Staking
      Credential 'Staking
cred3 <- KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Staking -> Credential 'Staking)
-> ImpM (LedgerSpec era) (KeyHash 'Staking)
-> ImpM (LedgerSpec era) (Credential 'Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Staking
      Credential 'Staking
cred4 <- KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Staking -> Credential 'Staking)
-> ImpM (LedgerSpec era) (KeyHash 'Staking)
-> ImpM (LedgerSpec era) (Credential 'Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Staking
      KeyHash 'StakePool
poolId <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      PoolParams
poolParams <- KeyHash 'StakePool -> RewardAccount -> ImpTestM era PoolParams
forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> RewardAccount -> ImpTestM era PoolParams
freshPoolParams KeyHash 'StakePool
poolId (Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet Credential 'Staking
cred0)
      Credential 'DRepRole
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
<$> forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'DRepRole
      let delegatee :: Delegatee
delegatee = KeyHash 'StakePool -> DRep -> Delegatee
DelegStakeVote KeyHash 'StakePool
poolId (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
dRepCred)
      StrictMaybe Anchor
anchor <- ImpM (LedgerSpec era) (StrictMaybe Anchor)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      Tx era
txRegister <-
        Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
              ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxCert era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era] -> StrictSeq (TxCert era)
forall a. [a] -> StrictSeq a
SSeq.fromList
                [ PoolParams -> TxCert era
forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert PoolParams
poolParams
                , Credential 'DRepRole -> Coin -> StrictMaybe Anchor -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> StrictMaybe Anchor -> TxCert era
RegDRepTxCert Credential 'DRepRole
dRepCred Coin
dRepDeposit StrictMaybe Anchor
anchor
                , Credential 'Staking -> Delegatee -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> Coin -> TxCert era
RegDepositDelegTxCert Credential 'Staking
cred0 Delegatee
delegatee Coin
accountDeposit
                , Credential 'Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert Credential 'Staking
cred1
                , Credential 'Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking
cred2 Coin
accountDeposit
                , Credential 'Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking
cred3 Coin
accountDeposit
                , Credential 'Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
UnRegTxCert Credential 'Staking
cred2
                , Credential 'Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking
cred1 Coin
accountDeposit
                , Credential 'Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking
cred4 Coin
accountDeposit
                ]
      UTxO era
utxoAfterRegister <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
      -- Overwrite deposit protocol parameters in order to ensure they does not affect refunds
      (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
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 => 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 => 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
        )
      (UTxO era -> Value era
forall era. EraTxOut era => UTxO era -> Value era
sumUTxO UTxO era
utxoStart MaryValue -> MaryValue -> MaryValue
forall t. Val t => t -> t -> t
<-> UTxO era -> Value era
forall era. EraTxOut era => UTxO era -> Value era
sumUTxO UTxO era
utxoAfterRegister)
        MaryValue -> MaryValue -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin -> MaryValue
forall t s. Inject t s => t -> s
inject
          ( (Tx era
txRegister Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Coin (TxBody era))
-> Tx era -> Const Coin (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Coin (TxBody era))
 -> Tx era -> Const Coin (Tx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody era -> Const Coin (TxBody era))
-> Getting Coin (Tx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin) -> TxBody era -> Const Coin (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL)
              Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> ((Int
3 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
accountDeposit) -- Only three accounts retained that are still registered
              Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
stakePoolDeposit
              Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
dRepDeposit
          )
      EpochNo
curEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
      Tx era
txUnRegister <-
        Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
              ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxCert era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era] -> StrictSeq (TxCert era)
forall a. [a] -> StrictSeq a
SSeq.fromList
                [ KeyHash 'StakePool -> EpochNo -> TxCert era
forall era.
EraTxCert era =>
KeyHash 'StakePool -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash 'StakePool
poolId (EpochNo -> EpochNo
forall a. Enum a => a -> a
succ EpochNo
curEpochNo)
                , Credential 'DRepRole -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> TxCert era
UnRegDRepTxCert Credential 'DRepRole
dRepCred Coin
dRepDeposit
                , Credential 'Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
UnRegTxCert Credential 'Staking
cred3
                , Credential 'Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking
cred4 Coin
accountDeposit
                ]
      UTxO era
utxoAfterUnRegister <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
      let totalFees :: Coin
totalFees = (Tx era
txRegister Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Coin (TxBody era))
-> Tx era -> Const Coin (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Coin (TxBody era))
 -> Tx era -> Const Coin (Tx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody era -> Const Coin (TxBody era))
-> Getting Coin (Tx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin) -> TxBody era -> Const Coin (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> (Tx era
txUnRegister Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Coin (TxBody era))
-> Tx era -> Const Coin (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Coin (TxBody era))
 -> Tx era -> Const Coin (Tx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody era -> Const Coin (TxBody era))
-> Getting Coin (Tx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin) -> TxBody era -> Const Coin (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL)
      Coin
fees <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin)
    -> LedgerState era -> Const r (LedgerState era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState era -> Const r (UTxOState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Const r (UTxOState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Coin -> Const r Coin)
    -> UTxOState era -> Const r (UTxOState era))
-> (Coin -> Const r Coin)
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> UTxOState era -> Const r (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosFeesL)
      Coin
totalFees Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
fees
      -- only deposits for stake pool and its account are not refunded at this point
      (UTxO era -> Value era
forall era. EraTxOut era => UTxO era -> Value era
sumUTxO UTxO era
utxoStart MaryValue -> MaryValue -> MaryValue
forall t. Val t => t -> t -> t
<-> UTxO era -> Value era
forall era. EraTxOut era => UTxO era -> Value era
sumUTxO UTxO era
utxoAfterUnRegister)
        MaryValue -> MaryValue -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin -> MaryValue
forall t s. Inject t s => t -> s
inject (Coin
totalFees Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
stakePoolDeposit Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
accountDeposit)
      ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
      -- Check for successfull pool refund
      Credential 'Staking -> ImpTestM era Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred0 ImpTestM era Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
stakePoolDeposit
  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
    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
      Timelock era
spendingScript <- ImpM (LedgerSpec era) (Timelock era)
ImpTestM era (NativeScript era)
nativeScript
      HasCallStack =>
NativeScript era -> [Script era] -> ImpM (LedgerSpec era) ()
NativeScript era -> [Script era] -> ImpM (LedgerSpec era) ()
checkMinFee Timelock era
NativeScript era
spendingScript [NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
NativeScript era
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
      Timelock era
spendingScript <- ImpM (LedgerSpec era) (Timelock era)
ImpTestM era (NativeScript era)
nativeScript
      [AlonzoScript era]
extraScripts <- ImpTestM era [Script era]
ImpM (LedgerSpec era) [AlonzoScript era]
HasCallStack => ImpTestM era [Script era]
distinctScripts
      HasCallStack =>
NativeScript era -> [Script era] -> ImpM (LedgerSpec era) ()
NativeScript era -> [Script era] -> ImpM (LedgerSpec era) ()
checkMinFee Timelock era
NativeScript era
spendingScript ([Script era] -> ImpM (LedgerSpec era) ())
-> [Script era] -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
        NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
NativeScript era
spendingScript AlonzoScript era -> [AlonzoScript era] -> [AlonzoScript era]
forall a. a -> [a] -> [a]
: [AlonzoScript era]
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
      Timelock era
spendingScript <- ImpM (LedgerSpec era) (Timelock era)
ImpTestM era (NativeScript era)
nativeScript
      [AlonzoScript era]
extraScripts <- ImpTestM era [Script era]
ImpM (LedgerSpec era) [AlonzoScript era]
HasCallStack => ImpTestM era [Script era]
distinctScripts
      HasCallStack =>
NativeScript era -> [Script era] -> ImpM (LedgerSpec era) ()
NativeScript era -> [Script era] -> ImpM (LedgerSpec era) ()
checkMinFee Timelock era
NativeScript era
spendingScript ([Script era] -> ImpM (LedgerSpec era) ())
-> [Script era] -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
        [NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
NativeScript era
spendingScript, NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
NativeScript era
spendingScript]
          [AlonzoScript era] -> [AlonzoScript era] -> [AlonzoScript era]
forall a. [a] -> [a] -> [a]
++ [AlonzoScript era]
extraScripts
          [AlonzoScript era] -> [AlonzoScript era] -> [AlonzoScript era]
forall a. [a] -> [a] -> [a]
++ [AlonzoScript era]
extraScripts
    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"disjoint inputs and reference inputs" (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
        scriptHash :: SLanguage l -> ScriptHash
scriptHash SLanguage l
lang = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
inputsOverlapsWithRefInputs SLanguage l
lang
        mkTestTx :: TxIn -> Tx era
        mkTestTx :: TxIn -> Tx era
mkTestTx TxIn
txIn =
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn

      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Cannot run scripts that expect inputs and refInputs to overlap (PV 9/10)" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtMost @10 (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpTestM era TxIn)
-> ScriptHash -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> ScriptHash
forall {l :: Language}.
PlutusLanguage l =>
SLanguage l -> ScriptHash
scriptHash SLanguage 'PlutusV3
SPlutusV3
          forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx @era
            (TxIn -> Tx era
mkTestTx TxIn
txIn)
            [ BabbageUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (BabbageUtxoPredFailure era -> EraRuleFailure "LEDGER" era)
-> BabbageUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ NonEmpty TxIn -> BabbageUtxoPredFailure era
forall era. NonEmpty TxIn -> BabbageUtxoPredFailure era
BabbageNonDisjointRefInputs [Item (NonEmpty TxIn)
TxIn
txIn]
            ]
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Same script cannot appear in regular and reference inputs in PlutusV3 (PV 11)" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtLeast @11 (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpTestM era TxIn)
-> ScriptHash -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> ScriptHash
forall {l :: Language}.
PlutusLanguage l =>
SLanguage l -> ScriptHash
scriptHash SLanguage 'PlutusV3
SPlutusV3
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx @era
          (TxIn -> Tx era
mkTestTx TxIn
txIn)
          [ AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
              [CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [ContextError era -> Item [CollectError era]
ContextError era -> CollectError era
forall era. ContextError era -> CollectError era
BadTranslation (ContextError era -> Item [CollectError era])
-> (ConwayContextError era -> ContextError era)
-> ConwayContextError era
-> Item [CollectError era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject (ConwayContextError era -> Item [CollectError era])
-> ConwayContextError era -> Item [CollectError era]
forall a b. (a -> b) -> a -> b
$ forall era. NonEmpty TxIn -> ConwayContextError era
ReferenceInputsNotDisjointFromInputs @era [Item (NonEmpty TxIn)
TxIn
txIn]]
          ]
  where
    checkMinFee :: HasCallStack => NativeScript era -> [Script era] -> ImpTestM era ()
    checkMinFee :: HasCallStack =>
NativeScript era -> [Script era] -> ImpM (LedgerSpec era) ()
checkMinFee NativeScript era
scriptToSpend [Script era]
refScripts = do
      NonNegativeInterval
refScriptFee <- ImpTestM era NonNegativeInterval
setRefScriptFee
      String -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => String -> ImpM t ()
logString String
"lock an input with a script"
      TxIn
scriptSpendIn <- HasCallStack => NativeScript era -> ImpTestM era TxIn
NativeScript era -> ImpTestM era TxIn
createScriptUtxo NativeScript era
scriptToSpend
      String -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => String -> ImpM t ()
logString
        String
"create outputs with reference scripts and the return them mapped to their corresponding inputs"
      Map TxIn (AlonzoScript era)
refScriptInToScripts <- HasCallStack =>
[Script era] -> ImpTestM era (Map TxIn (Script era))
[Script era] -> ImpTestM era (Map TxIn (Script era))
createRefScriptsUtxos [Script era]
refScripts
      String -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => String -> ImpM t ()
logString String
"spend the initial input by passing the reference scripts"
      Tx era
tx <- HasCallStack => TxIn -> Set TxIn -> ImpM (LedgerSpec era) (Tx era)
TxIn -> Set TxIn -> ImpM (LedgerSpec era) (Tx era)
spendScriptUsingRefScripts TxIn
scriptSpendIn (Set TxIn -> ImpM (LedgerSpec era) (Tx era))
-> Set TxIn -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ Map TxIn (AlonzoScript era) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (AlonzoScript era)
refScriptInToScripts
      String -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => String -> ImpM t ()
logString
        String
"compute the difference between the current-era minFee and that computed in pre-Conway eras"
      Coin
minFeeDiff <- Tx era -> ImpTestM era Coin
conwayDiffMinFee Tx era
tx
      String -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => String -> ImpM t ()
logString String
"check that the difference is the sum of the sizes of the passed reference scripts"
      Coin
minFeeDiff
        Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Integer -> Coin
Coin
          ( Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Integer) -> Rational -> Integer
forall a b. (a -> b) -> a -> b
$
              forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Rational (Map TxIn Int -> Int
forall a. Num a => Map TxIn a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Map TxIn Int -> Int) -> Map TxIn Int -> Int
forall a b. (a -> b) -> a -> b
$ Script era -> Int
AlonzoScript era -> Int
scriptSize (AlonzoScript era -> Int)
-> Map TxIn (AlonzoScript era) -> Map TxIn Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (AlonzoScript era)
refScriptInToScripts)
                Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
refScriptFee
          )

    distinctScripts :: HasCallStack => ImpTestM era [Script era]
    distinctScripts :: HasCallStack => ImpTestM era [Script era]
distinctScripts = do
      [AlonzoScript era]
nativeScripts <-
        (forall era. EraScript era => NativeScript era -> Script era
fromNativeScript @era (Timelock era -> AlonzoScript era)
-> [Timelock era] -> [AlonzoScript era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          ([Timelock era] -> [AlonzoScript era])
-> ImpM (LedgerSpec era) [Timelock era]
-> ImpM (LedgerSpec era) [AlonzoScript era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ImpM (LedgerSpec era) (Timelock era)
-> ImpM (LedgerSpec era) [Timelock era]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 ImpM (LedgerSpec era) (Timelock era)
ImpTestM era (NativeScript era)
nativeScript
      let
        psh1 :: ScriptHash
psh1 = Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV2 -> ScriptHash) -> Plutus 'PlutusV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV2
SPlutusV2
      PlutusScript era
ps1 <- String
-> ImpM (LedgerSpec era) (PlutusScript era)
-> ImpM (LedgerSpec era) (PlutusScript era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Expecting Plutus script" (ImpM (LedgerSpec era) (PlutusScript era)
 -> ImpM (LedgerSpec era) (PlutusScript era))
-> (Maybe (PlutusScript era)
    -> ImpM (LedgerSpec era) (PlutusScript era))
-> Maybe (PlutusScript era)
-> ImpM (LedgerSpec era) (PlutusScript era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (PlutusScript era)
-> ImpM (LedgerSpec era) (PlutusScript era)
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust (Maybe (PlutusScript era)
 -> ImpM (LedgerSpec era) (PlutusScript era))
-> Maybe (PlutusScript era)
-> ImpM (LedgerSpec era) (PlutusScript era)
forall a b. (a -> b) -> a -> b
$ ScriptHash -> Maybe (PlutusScript era)
forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScript ScriptHash
psh1
      let
        psh2 :: ScriptHash
psh2 = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV3 -> ScriptHash) -> Plutus 'PlutusV3 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3
      PlutusScript era
ps2 <- String
-> ImpM (LedgerSpec era) (PlutusScript era)
-> ImpM (LedgerSpec era) (PlutusScript era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Expecting Plutus script" (ImpM (LedgerSpec era) (PlutusScript era)
 -> ImpM (LedgerSpec era) (PlutusScript era))
-> (Maybe (PlutusScript era)
    -> ImpM (LedgerSpec era) (PlutusScript era))
-> Maybe (PlutusScript era)
-> ImpM (LedgerSpec era) (PlutusScript era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (PlutusScript era)
-> ImpM (LedgerSpec era) (PlutusScript era)
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust (Maybe (PlutusScript era)
 -> ImpM (LedgerSpec era) (PlutusScript era))
-> Maybe (PlutusScript era)
-> ImpM (LedgerSpec era) (PlutusScript era)
forall a b. (a -> b) -> a -> b
$ ScriptHash -> Maybe (PlutusScript era)
forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScript ScriptHash
psh2
      let plutusScripts :: [AlonzoScript era]
plutusScripts = [PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
ps1, PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
ps2]
      [AlonzoScript era] -> ImpM (LedgerSpec era) [AlonzoScript era]
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([AlonzoScript era] -> ImpM (LedgerSpec era) [AlonzoScript era])
-> [AlonzoScript era] -> ImpM (LedgerSpec era) [AlonzoScript era]
forall a b. (a -> b) -> a -> b
$ [AlonzoScript era]
nativeScripts [AlonzoScript era] -> [AlonzoScript era] -> [AlonzoScript era]
forall a. [a] -> [a] -> [a]
++ [AlonzoScript era]
plutusScripts

    conwayDiffMinFee :: Tx era -> ImpTestM era Coin
    conwayDiffMinFee :: Tx era -> ImpTestM era Coin
conwayDiffMinFee Tx era
tx = do
      UTxO era
utxo <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
      PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
      Coin -> ImpTestM era Coin
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Coin -> ImpTestM era Coin) -> Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ PParams era -> Tx era -> UTxO era -> Coin
forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
pp Tx era
tx UTxO era
utxo Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> PParams era -> Tx era -> Coin
forall era. EraTx era => PParams era -> Tx era -> Coin
getShelleyMinFeeTxUtxo PParams era
pp Tx era
tx

    createScriptUtxo :: HasCallStack => NativeScript era -> ImpTestM era TxIn
    createScriptUtxo :: HasCallStack => NativeScript era -> ImpTestM era TxIn
createScriptUtxo NativeScript era
script = do
      Addr
scriptAddr <- NativeScript era -> ImpTestM era Addr
addScriptAddr NativeScript era
script
      Tx era
tx <-
        Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (TxBody era -> Tx era)
-> TxBody era
-> ImpM (LedgerSpec era) (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> ImpM (LedgerSpec era) (Tx era))
-> TxBody era -> ImpM (LedgerSpec 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
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL @era
              ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
SSeq.fromList [forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut @era Addr
scriptAddr Value era
MaryValue
forall a. Monoid a => a
mempty]
      TxIn -> ImpTestM era TxIn
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn -> ImpTestM era TxIn) -> TxIn -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ Int -> Tx era -> TxIn
forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Int
0 :: Int) Tx era
tx

    createRefScriptsUtxos ::
      HasCallStack => [Script era] -> ImpTestM era (Map.Map TxIn (Script era))
    createRefScriptsUtxos :: HasCallStack =>
[Script era] -> ImpTestM era (Map TxIn (Script era))
createRefScriptsUtxos [Script era]
scripts = do
      TxOut era
rootOut <- (TxIn, TxOut era) -> TxOut era
forall a b. (a, b) -> b
snd ((TxIn, TxOut era) -> TxOut era)
-> ImpM (LedgerSpec era) (TxIn, TxOut era)
-> ImpM (LedgerSpec era) (TxOut era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (TxIn, TxOut era)
forall era. ImpTestM era (TxIn, TxOut era)
getImpRootTxOut
      let outs :: [TxOut era]
outs =
            [Script era]
[AlonzoScript era]
scripts
              [AlonzoScript era]
-> (AlonzoScript era -> TxOut era) -> [TxOut era]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ( \AlonzoScript era
s ->
                      forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut @era (TxOut era
rootOut TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL) Value era
MaryValue
forall a. Monoid a => a
mempty
                        TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL @era ((StrictMaybe (AlonzoScript era)
  -> Identity (StrictMaybe (AlonzoScript era)))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe (AlonzoScript era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AlonzoScript era -> StrictMaybe (AlonzoScript era)
forall a. a -> StrictMaybe a
SJust AlonzoScript era
s
                  )
      Tx era
tx <-
        Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (TxBody era -> Tx era)
-> TxBody era
-> ImpM (LedgerSpec era) (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> ImpM (LedgerSpec era) (Tx era))
-> TxBody era -> ImpM (LedgerSpec 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
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL @era
              ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
SSeq.fromList [TxOut era]
outs
      let refIns :: [TxIn]
refIns = (Int -> Tx era -> TxIn
forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
`txInAt` Tx era
tx) (Int -> TxIn) -> [Int] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
Item [Int]
0 .. [AlonzoScript era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Script era]
[AlonzoScript era]
scripts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      Map TxIn (AlonzoScript era)
-> ImpM (LedgerSpec era) (Map TxIn (AlonzoScript era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (AlonzoScript era)
 -> ImpM (LedgerSpec era) (Map TxIn (AlonzoScript era)))
-> Map TxIn (AlonzoScript era)
-> ImpM (LedgerSpec era) (Map TxIn (AlonzoScript era))
forall a b. (a -> b) -> a -> b
$ [(TxIn, AlonzoScript era)] -> Map TxIn (AlonzoScript era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, AlonzoScript era)] -> Map TxIn (AlonzoScript era))
-> [(TxIn, AlonzoScript era)] -> Map TxIn (AlonzoScript era)
forall a b. (a -> b) -> a -> b
$ [TxIn]
refIns [TxIn] -> [AlonzoScript era] -> [(TxIn, AlonzoScript era)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Script era]
[AlonzoScript era]
scripts

    spendScriptUsingRefScripts ::
      HasCallStack => TxIn -> Set.Set TxIn -> ImpTestM era (Tx era)
    spendScriptUsingRefScripts :: HasCallStack => TxIn -> Set TxIn -> ImpM (LedgerSpec era) (Tx era)
spendScriptUsingRefScripts TxIn
scriptIn Set TxIn
refIns =
      String -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"spendScriptUsingRefScripts" (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (TxBody era -> Tx era)
-> TxBody era
-> ImpM (LedgerSpec era) (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> ImpM (LedgerSpec era) (Tx era))
-> TxBody era -> ImpM (LedgerSpec 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
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL @era ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
scriptIn
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL @era ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set TxIn
refIns

    nativeScript :: ImpTestM era (NativeScript era)
    nativeScript :: ImpTestM era (NativeScript era)
nativeScript = do
      KeyHash 'Witness
requiredKeyHash <- ImpM (LedgerSpec era) (KeyHash 'Witness)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      let script :: NativeScript era
script = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (NativeScript era -> StrictSeq (NativeScript era)
forall a. a -> StrictSeq a
SSeq.singleton (forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature @era KeyHash 'Witness
requiredKeyHash))
      ScriptHash
_ <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript NativeScript era
script
      Timelock era -> ImpM (LedgerSpec era) (Timelock era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Timelock era
NativeScript era
script

    addScriptAddr :: NativeScript era -> ImpTestM era Addr
    addScriptAddr :: NativeScript era -> ImpTestM era Addr
addScriptAddr NativeScript era
script = do
      ScriptHash
scriptHash <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript NativeScript era
script
      KeyHash 'Staking
stakingKeyHash <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Staking
      Addr -> ImpTestM era Addr
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Addr -> ImpTestM era Addr) -> Addr -> ImpTestM era Addr
forall a b. (a -> b) -> a -> b
$ ScriptHash -> KeyHash 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
scriptHash KeyHash 'Staking
stakingKeyHash

    scriptSize :: Script era -> Int
    scriptSize :: Script era -> Int
scriptSize = \case
      TimelockScript Timelock era
tl -> ShortByteString -> Int
SBS.length (ShortByteString -> Int) -> ShortByteString -> Int
forall a b. (a -> b) -> a -> b
$ Timelock era -> ShortByteString
forall t. Memoized t => t -> ShortByteString
getMemoRawBytes Timelock era
tl
      PlutusScript PlutusScript era
ps -> PlutusScript era
-> (forall (l :: Language). PlutusLanguage l => Plutus l -> Int)
-> Int
forall era a.
AlonzoEraScript era =>
PlutusScript era
-> (forall (l :: Language). PlutusLanguage l => Plutus l -> a) -> a
forall a.
PlutusScript era
-> (forall (l :: Language). PlutusLanguage l => Plutus l -> a) -> a
withPlutusScript PlutusScript era
ps (ShortByteString -> Int
SBS.length (ShortByteString -> Int)
-> (Plutus l -> ShortByteString) -> Plutus l -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlutusBinary -> ShortByteString
unPlutusBinary (PlutusBinary -> ShortByteString)
-> (Plutus l -> PlutusBinary) -> Plutus l -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plutus l -> PlutusBinary
forall (l :: Language). Plutus l -> PlutusBinary
plutusBinary)

    setRefScriptFee :: ImpTestM era NonNegativeInterval
    setRefScriptFee :: ImpTestM era NonNegativeInterval
setRefScriptFee = do
      let refScriptFee :: NonNegativeInterval
refScriptFee = Integer
10 Integer -> Integer -> NonNegativeInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
      (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
$ (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
.~ NonNegativeInterval
refScriptFee
      NonNegativeInterval -> ImpTestM era NonNegativeInterval
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonNegativeInterval
refScriptFee