{-# 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 (EraCrypto era)
scriptSpendIn <- HasCallStack =>
NativeScript era -> ImpTestM era (TxIn (EraCrypto era))
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 (EraCrypto era)) (AlonzoScript era)
refScriptInToScripts <- HasCallStack =>
[Script era]
-> ImpTestM era (Map (TxIn (EraCrypto era)) (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 (EraCrypto era)
-> Set (TxIn (EraCrypto era)) -> ImpTestM era (Tx era)
spendScriptUsingRefScripts TxIn (EraCrypto era)
scriptSpendIn forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet Map (TxIn (EraCrypto era)) (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 (EraCrypto era)) (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 (EraCrypto era)
psh1 = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era) -> Maybe (PlutusScript era)
impLookupPlutusScriptMaybe ScriptHash (EraCrypto era)
psh1
      let
        psh2 :: ScriptHash (EraCrypto era)
psh2 = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era) -> Maybe (PlutusScript era)
impLookupPlutusScriptMaybe ScriptHash (EraCrypto era)
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 (EraCrypto era))
    createScriptUtxo :: HasCallStack =>
NativeScript era -> ImpTestM era (TxIn (EraCrypto era))
createScriptUtxo NativeScript era
script = do
      Addr (EraCrypto era)
scriptAddr <- HasCallStack =>
NativeScript era -> ImpTestM era (Addr (EraCrypto era))
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 (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut @era Addr (EraCrypto era)
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 (EraCrypto era)
txInAt (Int
0 :: Int) Tx era
tx

    createRefScriptsUtxos ::
      HasCallStack => [Script era] -> ImpTestM era (Map.Map (TxIn (EraCrypto era)) (Script era))
    createRefScriptsUtxos :: HasCallStack =>
[Script era]
-> ImpTestM era (Map (TxIn (EraCrypto era)) (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 (EraCrypto era), 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 (EraCrypto era) -> 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 (EraCrypto era))
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 (EraCrypto era)]
refIns = (forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn (EraCrypto era)
`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 (EraCrypto era)]
refIns forall a b. [a] -> [b] -> [(a, b)]
`zip` [Script era]
scripts

    spendScriptUsingRefScripts ::
      HasCallStack => TxIn (EraCrypto era) -> Set.Set (TxIn (EraCrypto era)) -> ImpTestM era (Tx era)
    spendScriptUsingRefScripts :: HasCallStack =>
TxIn (EraCrypto era)
-> Set (TxIn (EraCrypto era)) -> ImpTestM era (Tx era)
spendScriptUsingRefScripts TxIn (EraCrypto era)
scriptIn Set (TxIn (EraCrypto era))
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 (EraCrypto era)))
inputsTxBodyL @era forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn (EraCrypto era)
scriptIn
          forall a b. a -> (a -> b) -> b
& forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
referenceInputsTxBodyL @era forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (TxIn (EraCrypto era))
refIns

    nativeScript :: ImpTestM era (NativeScript era)
    nativeScript :: ImpTestM era (NativeScript era)
nativeScript = do
      KeyHash 'Witness (EraCrypto era)
requiredKeyHash <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
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 (EraCrypto era) -> NativeScript era
RequireSignature @era KeyHash 'Witness (EraCrypto era)
requiredKeyHash))
      ScriptHash (EraCrypto era)
_ <- forall era.
EraScript era =>
NativeScript era -> ImpTestM era (ScriptHash (EraCrypto era))
impAddNativeScript NativeScript era
script
      forall (f :: * -> *) a. Applicative f => a -> f a
pure NativeScript era
script

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