{-# 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.TxIn (TxIn (..))
import Cardano.Ledger.UTxO (getMinFeeTxUtxo)
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.KeyPair (mkScriptAddr)
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 =
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Reference scripts" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"required reference script counts towards the minFee calculation" forall a b. (a -> b) -> a -> b
$ do
      Timelock era
spendingScript <- ImpTestM era (NativeScript era)
nativeScript
      HasCallStack =>
NativeScript era -> [Script era] -> ImpM (LedgerSpec era) ()
checkMinFee Timelock era
spendingScript [forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
spendingScript]

    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" forall a b. (a -> b) -> a -> b
$ do
      Timelock era
spendingScript <- ImpTestM era (NativeScript era)
nativeScript
      [AlonzoScript era]
extraScripts <- HasCallStack => ImpTestM era [Script era]
distinctScripts
      HasCallStack =>
NativeScript era -> [Script era] -> ImpM (LedgerSpec era) ()
checkMinFee Timelock era
spendingScript forall a b. (a -> b) -> a -> b
$
        forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
spendingScript forall a. a -> [a] -> [a]
: [AlonzoScript era]
extraScripts

    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" forall a b. (a -> b) -> a -> b
$ do
      Timelock era
spendingScript <- ImpTestM era (NativeScript era)
nativeScript
      [AlonzoScript era]
extraScripts <- HasCallStack => ImpTestM era [Script era]
distinctScripts
      HasCallStack =>
NativeScript era -> [Script era] -> ImpM (LedgerSpec era) ()
checkMinFee Timelock era
spendingScript forall a b. (a -> b) -> a -> b
$
        [forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
spendingScript, forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
spendingScript]
          forall a. [a] -> [a] -> [a]
++ [AlonzoScript era]
extraScripts
          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
      forall t. HasCallStack => String -> ImpM t ()
logString String
"lock an input with a script"
      TxIn
scriptSpendIn <- HasCallStack => NativeScript era -> ImpTestM era TxIn
createScriptUtxo NativeScript era
scriptToSpend
      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))
createRefScriptsUtxos [Script era]
refScripts
      forall t. HasCallStack => String -> ImpM t ()
logString String
"spend the initial input by passing the reference scripts"
      Tx era
tx <- HasCallStack => TxIn -> Set TxIn -> ImpTestM era (Tx era)
spendScriptUsingRefScripts TxIn
scriptSpendIn forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet Map TxIn (AlonzoScript era)
refScriptInToScripts
      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
      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
        forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Integer -> Coin
Coin
          ( forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$
              forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Rational (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ Script era -> Int
scriptSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (AlonzoScript era)
refScriptInToScripts)
                forall a. Num a => a -> a -> a
* 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 ImpTestM era (NativeScript era)
nativeScript
      let
        psh1 :: ScriptHash
psh1 = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV2
SPlutusV2
      PlutusScript era
ps1 <- forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Expecting Plutus script" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust forall a b. (a -> b) -> a -> b
$ forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScriptMaybe ScriptHash
psh1
      let
        psh2 :: ScriptHash
psh2 = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3
      PlutusScript era
ps2 <- forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Expecting Plutus script" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust forall a b. (a -> b) -> a -> b
$ forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScriptMaybe ScriptHash
psh2
      let plutusScripts :: [AlonzoScript era]
plutusScripts = [forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
ps1, forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
ps2]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [AlonzoScript era]
nativeScripts 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 <- forall era. ImpTestM era (UTxO era)
getUTxO
      PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
pp Tx era
tx UTxO era
utxo forall t. Val t => t -> t -> t
<-> 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 <- HasCallStack => NativeScript era -> ImpTestM era Addr
addScriptAddr NativeScript era
script
      Tx era
tx <-
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
          forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL @era
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList [forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut @era Addr
scriptAddr forall a. Monoid a => a
mempty]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 <- forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. ImpTestM era (TxIn, TxOut era)
lookupImpRootTxOut
      let outs :: [TxOut era]
outs =
            [Script era]
scripts
              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 forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) Addr
addrTxOutL) forall a. Monoid a => a
mempty
                        forall a b. a -> (a -> b) -> b
& forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL @era forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust AlonzoScript era
s
                  )
      Tx era
tx <-
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
          forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL @era
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList [TxOut era]
outs
      let refIns :: [TxIn]
refIns = (forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
`txInAt` Tx era
tx) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [Script era]
scripts forall a. Num a => a -> a -> a
- Int
1]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ [TxIn]
refIns forall a b. [a] -> [b] -> [(a, b)]
`zip` [Script era]
scripts

    spendScriptUsingRefScripts ::
      HasCallStack => TxIn -> Set.Set TxIn -> ImpTestM era (Tx era)
    spendScriptUsingRefScripts :: HasCallStack => TxIn -> Set TxIn -> ImpTestM era (Tx era)
spendScriptUsingRefScripts TxIn
scriptIn Set TxIn
refIns =
      forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"spendScriptUsingRefScripts" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
        forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL @era forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn
scriptIn
          forall a b. a -> (a -> b) -> b
& forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL @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 <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      let script :: NativeScript era
script = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (forall a. a -> StrictSeq a
SSeq.singleton (forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature @era KeyHash 'Witness
requiredKeyHash))
      ScriptHash
_ <- forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript NativeScript era
script
      forall (f :: * -> *) a. Applicative f => a -> f a
pure NativeScript era
script

    addScriptAddr :: HasCallStack => NativeScript era -> ImpTestM era Addr
    addScriptAddr :: HasCallStack => NativeScript era -> ImpTestM era Addr
addScriptAddr NativeScript era
script = do
      KeyPair 'Staking
kpStaking1 <- forall s (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s, MonadState s m) =>
KeyHash r -> m (KeyPair r)
lookupKeyPair forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      ScriptHash
scriptHash <- forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript NativeScript era
script
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ScriptHash -> KeyPair 'Staking -> Addr
mkScriptAddr ScriptHash
scriptHash KeyPair 'Staking
kpStaking1

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

    setRefScriptFee :: ImpTestM era NonNegativeInterval
    setRefScriptFee :: ImpTestM era NonNegativeInterval
setRefScriptFee = do
      let refScriptFee :: NonNegativeInterval
refScriptFee = Integer
10 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
      forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) NonNegativeInterval
ppMinFeeRefScriptCostPerByteL forall s t a b. ASetter s t a b -> b -> s -> t
.~ NonNegativeInterval
refScriptFee
      forall (f :: * -> *) a. Applicative f => a -> f a
pure NonNegativeInterval
refScriptFee