{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# 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.Scripts
import Cardano.Ledger.Babbage.TxBody (referenceInputsTxBodyL)
import Cardano.Ledger.Babbage.TxOut (referenceScriptTxOutL)
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.PParams (ppMinFeeRefScriptCostPerByteL)
import Cardano.Ledger.MemoBytes (getMemoRawBytes)
import Cardano.Ledger.Plutus.Language (SLanguage (..), hashPlutusScript, plutusBinary)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.UTxO (getShelleyMinFeeTxUtxo)
import Cardano.Ledger.State (getMinFeeTxUtxo)
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)

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
"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
  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
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