{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

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

import Cardano.Ledger.BHeaderView (BHeaderView (..))
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.BaseTypes (BlocksMade (..), Mismatch (..), ProtVer (..), natVersion)
import Cardano.Ledger.Block
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..))
import Cardano.Ledger.Conway.Rules (
  ConwayBbodyPredFailure (..),
  totalRefScriptSizeInBlock,
 )
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (
  BbodyEnv (..),
  ShelleyBbodyState (..),
 )
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireSignature,
 )
import Cardano.Ledger.TxIn
import Control.Monad (forM)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Sequence.Strict as SSeq
import Data.Word (Word32)
import Lens.Micro ((&), (.~), (^.))
import Lens.Micro.Mtl (use)
import Test.Cardano.Ledger.Babbage.ImpTest
import Test.Cardano.Ledger.Conway.ImpTest (ConwayEraImp)
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysFailsNoDatum, purposeIsWellformedNoDatum)

spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec = do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"BodyRefScriptsSizeTooBig" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    plutusScript <- forall era (l :: Language) (m :: * -> *).
(AlonzoEraScript era, PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
mkPlutusScript @era (Plutus 'PlutusV2 -> ImpM (LedgerSpec era) (PlutusScript era))
-> Plutus 'PlutusV2 -> ImpM (LedgerSpec era) (PlutusScript era)
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedNoDatum SLanguage 'PlutusV2
SPlutusV2
    let scriptSize = PlutusScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize PlutusScript era
plutusScript
    pp <- getsPParams id

    -- Determine a number of transactions and a number of times the reference script
    -- needs to be included as an input in each transaction,
    -- in order for the total to exceed the maximum allowed refScript size per block,
    -- while the refScript size per individual transaction doesn't exceed maxRefScriptSizePerTx
    let
      maxRefScriptSizePerTx = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Int (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era.
ConwayEraPParams era =>
SimpleGetter (PParams era) Word32
SimpleGetter (PParams era) Word32
ppMaxRefScriptSizePerTxG
      maxRefScriptSizePerBlock = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Int (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era.
ConwayEraPParams era =>
SimpleGetter (PParams era) Word32
SimpleGetter (PParams era) Word32
ppMaxRefScriptSizePerBlockG
    txScriptCounts <-
      genNumAdditionsExceeding
        scriptSize
        maxRefScriptSizePerTx
        maxRefScriptSizePerBlock

    let mkTxWithNScripts Int
n = do
          -- Instead of using the rootTxIn, we are creating an input for each transaction
          -- that we subsequently need to submit,
          -- so that we can submit them independently of each other.
          txIn <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_ ImpM (LedgerSpec era) Addr
-> (Addr -> ImpM (LedgerSpec era) TxIn)
-> ImpM (LedgerSpec era) TxIn
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Addr
addr -> Addr -> Coin -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr (Integer -> Coin
Coin Integer
8_000_000)
          refIns <- replicateM n $ produceRefScript (fromPlutusScript plutusScript)
          pure $ mkTxWithRefInputs txIn (NE.fromList refIns)

    txs <- do
      forM txScriptCounts $ \Int
n -> do
        Int -> ImpM (LedgerSpec era) (Tx TopTx era)
forall {era}.
(Event (EraRule "TICK" era) ~ EraRuleEvent "TICK" era,
 Event (EraRule "LEDGER" era) ~ EraRuleEvent "LEDGER" era,
 PredicateFailure (EraRule "BBODY" era)
 ~ EraRuleFailure "BBODY" era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ EraRuleFailure "LEDGER" era,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, BabbageEraTxBody era,
 ToExpr (EraRuleFailure "LEDGER" era),
 EncCBOR (EraRuleFailure "LEDGER" era),
 DecCBOR (EraRuleFailure "LEDGER" era),
 Eq (EraRuleFailure "BBODY" era), Eq (EraRuleFailure "LEDGER" era),
 Show (EraRuleFailure "BBODY" era),
 Show (EraRuleFailure "LEDGER" era),
 NFData (EraRuleFailure "LEDGER" era)) =>
Int -> ImpM (LedgerSpec era) (Tx TopTx era)
mkTxWithNScripts Int
n
          ImpM (LedgerSpec era) (Tx TopTx era)
-> (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupFees
          ImpM (LedgerSpec era) (Tx TopTx era)
-> (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
updateAddrTxWits

    let expectedTotalRefScriptSize = Int
scriptSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
txScriptCounts
    predFailures <- expectLeftExpr =<< tryRunBBODY txs
    predFailures
      `shouldBe` NE.fromList
        [ injectFailure
            ( BodyRefScriptsSizeTooBig $
                Mismatch
                  { mismatchSupplied = expectedTotalRefScriptSize
                  , mismatchExpected = maxRefScriptSizePerBlock
                  }
            )
        ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"BodyRefScriptsSizeTooBig with reference scripts in the same block" (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 :: Nat) era.
(EraGov era, KnownNat v, 0 <= 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
      Just plutusScript <- Maybe (PlutusScript era)
-> ImpM (LedgerSpec era) (Maybe (PlutusScript era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PlutusScript era)
 -> ImpM (LedgerSpec era) (Maybe (PlutusScript era)))
-> Maybe (PlutusScript era)
-> ImpM (LedgerSpec era) (Maybe (PlutusScript era))
forall a b. (a -> b) -> a -> b
$ forall era (l :: Language) (m :: * -> *).
(AlonzoEraScript era, PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
mkPlutusScript @era (Plutus 'PlutusV2 -> Maybe (PlutusScript era))
-> Plutus 'PlutusV2 -> Maybe (PlutusScript era)
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedNoDatum SLanguage 'PlutusV2
SPlutusV2
      let scriptSize = PlutusScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize PlutusScript era
plutusScript

      pp <- getsPParams id
      let
        maxRefScriptSizePerTx = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Int (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era.
ConwayEraPParams era =>
SimpleGetter (PParams era) Word32
SimpleGetter (PParams era) Word32
ppMaxRefScriptSizePerTxG
        maxRefScriptSizePerBlock = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Int (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era.
ConwayEraPParams era =>
SimpleGetter (PParams era) Word32
SimpleGetter (PParams era) Word32
ppMaxRefScriptSizePerBlockG
      txScriptCounts <-
        genNumAdditionsExceeding
          scriptSize
          maxRefScriptSizePerTx
          maxRefScriptSizePerBlock

      let expectedTotalRefScriptSize = Int
scriptSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
txScriptCounts

      -- We are creating reference scripts and transaction that depend on them in a "simulation",
      -- so the result will be correctly constructed that are not applied to the ledger state
      txs :: [Tx TopTx era] <- simulateThenRestore $ do
        concat
          <$> forM
            txScriptCounts
            ( \Int
n -> do
                -- produce reference scripts
                refScriptTxs <-
                  Int
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) [Tx TopTx era]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (NonEmpty (Script era) -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
NonEmpty (Script era) -> ImpTestM era (Tx TopTx era)
produceRefScriptsTx (PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
plutusScript AlonzoScript era
-> [AlonzoScript era] -> NonEmpty (AlonzoScript era)
forall a. a -> [a] -> NonEmpty a
:| []))

                -- spend using the reference scripts
                let txIns = (HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
`mkTxInPartial` Integer
0) (TxId -> TxIn) -> (Tx TopTx era -> TxId) -> Tx TopTx era -> TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx TopTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx (Tx TopTx era -> TxIn) -> [Tx TopTx era] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx TopTx era]
refScriptTxs
                rootIn <- fst <$> getImpRootTxOut
                spendTx <- submitTxWithRefInputs rootIn (NE.fromList txIns)
                pure $ refScriptTxs ++ [spendTx]
            )

      predFailures <- expectLeftExpr =<< tryRunBBODY txs
      predFailures
        `shouldBe` NE.fromList
          [ injectFailure
              ( BodyRefScriptsSizeTooBig $
                  Mismatch
                    { mismatchSupplied = expectedTotalRefScriptSize
                    , mismatchExpected = maxRefScriptSizePerBlock
                    }
              )
          ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"totalRefScriptSizeInBlock" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    script <- forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature @era (KeyHash Witness -> NativeScript era)
-> ImpM (LedgerSpec era) (KeyHash Witness)
-> ImpM (LedgerSpec era) (NativeScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Witness)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let scriptSize = NativeScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize NativeScript era
script
    scriptSpendIn <- impAddNativeScript script >>= produceScript
    scriptSpendIn2 <- impAddNativeScript script >>= produceScript
    protVer <- getsPParams ppProtocolVersionL

    -- We want to verify that the total size of reference scripts in a list of transactions
    -- remains unchanged before and after applying them to the ledger state.
    -- To do this, we generate the expected transactions, simulate submitting them to obtain
    -- their individual reference script sizes, and then restore the original state -
    -- meaning the transactions are not actually applied.
    -- Finally, we check that the accumulated sizes from both before and after match.
    txsWithRefScriptSizes :: ([(Tx TopTx era, Int)], Int) <- simulateThenRestore $ do
      let mkTxWithExpectedSize Int
expectedSize ImpM (LedgerSpec era) (Tx TopTx era)
txAction = do
            tx <- ImpM (LedgerSpec era) (Tx TopTx era)
txAction
            totalRefScriptSizeInBlock protVer [tx] <$> getUTxO `shouldReturn` expectedSize
            pure (tx, expectedSize)

      -- submit reference scripts
      refScriptTx1 <-
        mkTxWithExpectedSize 0 $
          produceRefScriptsTx (fromNativeScript script :| [])
      let refScriptTx1In = Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt Int
0 ((Tx TopTx era, Int) -> Tx TopTx era
forall a b. (a, b) -> a
fst (Tx TopTx era, Int)
refScriptTx1)
      refScriptTx2 <-
        mkTxWithExpectedSize 0 $
          produceRefScriptsTx (fromNativeScript script :| [])
      -- spend script using the reference script
      spendScriptWithRefScriptTx <-
        mkTxWithExpectedSize scriptSize $
          submitTxWithRefInputs scriptSpendIn [refScriptTx1In]
      -- spend using two ref inputs
      spendScriptWithTwoRefScriptsTx <-
        mkTxWithExpectedSize (2 * scriptSize) $
          submitTxWithRefInputs scriptSpendIn2 [refScriptTx1In, txInAt 0 (fst refScriptTx2)]
      -- spend the root utxo
      rootIn <- fst <$> getImpRootTxOut
      spendRootUtxoTx <-
        mkTxWithExpectedSize scriptSize $
          submitTxWithRefInputs rootIn [refScriptTx1In]
      -- spend the reference script itself
      -- We must check the size without submitting the transaction,
      -- since applying it removes the reference script from the UTxO
      spendRefScriptTx <-
        mkTxWithExpectedSize scriptSize $
          fixupTx $
            mkTxWithRefInputs refScriptTx1In (NE.fromList [refScriptTx1In])

      let txsWithRefScriptSizes =
            [ (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
refScriptTx1
            , (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
refScriptTx2
            , (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
spendScriptWithRefScriptTx
            , (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
spendScriptWithTwoRefScriptsTx
            , (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
spendRootUtxoTx
            , (Tx TopTx era, Int)
Item [(Tx TopTx era, Int)]
spendRefScriptTx
            ]

      -- check and return the accumulated reference script size of all transactions,
      -- so we can check that the same sum for the unapplied transactions matches
      let expectedTotalRefScriptSize = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
scriptSize
      totalRefScriptSizeInBlock protVer (SSeq.fromList (fst <$> txsWithRefScriptSizes))
        <$> getUTxO `shouldReturn` expectedTotalRefScriptSize
      pure (txsWithRefScriptSizes, expectedTotalRefScriptSize)

    let (txWithSizes, expectedTotalSize) = txsWithRefScriptSizes

    -- for each prefix of the list, the accumulated sum should match the sum of the applied transactions
    forM_ ([1 .. length txWithSizes] :: [Int]) $ \Int
ix -> do
      let slice :: [(Tx TopTx era, Int)]
slice = Int -> [(Tx TopTx era, Int)] -> [(Tx TopTx era, Int)]
forall a. Int -> [a] -> [a]
take Int
ix [(Tx TopTx era, Int)]
txWithSizes

      ProtVer -> StrictSeq (Tx TopTx era) -> UTxO era -> Int
forall era.
(AlonzoEraTx era, BabbageEraTxBody era) =>
ProtVer -> StrictSeq (Tx TopTx era) -> UTxO era -> Int
totalRefScriptSizeInBlock ProtVer
protVer ([Tx TopTx era] -> StrictSeq (Tx TopTx era)
forall a. [a] -> StrictSeq a
SSeq.fromList ((Tx TopTx era, Int) -> Tx TopTx era
forall a b. (a, b) -> a
fst ((Tx TopTx era, Int) -> Tx TopTx era)
-> [(Tx TopTx era, Int)] -> [Tx TopTx era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Tx TopTx era, Int)]
slice))
        (UTxO era -> Int)
-> ImpM (LedgerSpec era) (UTxO era) -> ImpM (LedgerSpec era) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
          ImpM (LedgerSpec era) Int -> Int -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` (if ProtVer -> Bool
isPostV10 ProtVer
protVer then [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Tx TopTx era, Int) -> Int
forall a b. (a, b) -> b
snd ((Tx TopTx era, Int) -> Int) -> [(Tx TopTx era, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Tx TopTx era, Int)]
slice) else Int
0)

    totalRefScriptSizeInBlock protVer (SSeq.fromList (fst <$> txWithSizes))
      <$> getUTxO
        `shouldReturn` (if isPostV10 protVer then expectedTotalSize else 0)

  -- disabled in conformance because submiting phase2-invalid transactions are not supported atm
  -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/910
  -- TODO: Re-enable after issue is resolved, by removing this override
  String
-> ImpM (LedgerSpec era) () -> SpecM (ImpInit (LedgerSpec era)) ()
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Use a reference script in a collateral output" (ImpM (LedgerSpec era) () -> SpecM (ImpInit (LedgerSpec era)) ())
-> ImpM (LedgerSpec era) () -> SpecM (ImpInit (LedgerSpec era)) ()
forall a b. (a -> b) -> a -> b
$ do
    protVer <- Lens' (PParams era) ProtVer -> ImpTestM era ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL

    -- produce an utxo with a failing script
    failingPlutusTxIn <- do
      let plutus = SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage 'PlutusV3
SPlutusV3
      produceScript $ hashPlutusScript plutus

    -- produce a utxo with a succeeding script
    script <- RequireSignature @era <$> freshKeyHash
    scriptTxIn <- impAddNativeScript script >>= produceScript
    let scriptSize = NativeScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize NativeScript era
script

    -- prepare a txout with the succeeding script as reference script
    collRefScriptTxOut <- do
      addr <- freshKeyAddr_
      pure $ mkBasicTxOut addr mempty & referenceScriptTxOutL .~ pure (fromNativeScript script)

    (txs :: [Tx TopTx era]) <- simulateThenRestore $ do
      -- submit an invalid transaction which attempts to consume the failing script
      -- and specifies as collateral return the txout with reference script
      createCollateralTx <-
        submitPhase2Invalid $
          mkBasicTx
            ( mkBasicTxBody
                & inputsTxBodyL .~ [failingPlutusTxIn]
                & collateralReturnTxBodyL .~ pure collRefScriptTxOut
            )
      totalRefScriptSizeInBlock protVer [createCollateralTx] <$> getUTxO `shouldReturn` 0

      -- consume the script, passing the output from the previous collateral as reference input
      let refScriptTxIn = Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt Int
1 Tx TopTx era
createCollateralTx
      useCollateralTx <- submitTxWithRefInputs scriptTxIn [refScriptTxIn]
      totalRefScriptSizeInBlock protVer [createCollateralTx, useCollateralTx]
        <$> getUTxO `shouldReturn` scriptSize
      pure [createCollateralTx, useCollateralTx]

    totalRefScriptSizeInBlock protVer (SSeq.fromList txs)
      <$> getUTxO
        `shouldReturn` (if isPostV10 protVer then scriptSize else 0)
  where
    tryRunBBODY :: [Tx TopTx era]
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
        (State (EraRule "BBODY" era), [Event (EraRule "BBODY" era)]))
tryRunBBODY [Tx TopTx era]
txs = do
      let blockBody :: BlockBody era
blockBody = forall era. EraBlockBody era => BlockBody era
mkBasicBlockBody @era BlockBody era -> (BlockBody era -> BlockBody era) -> BlockBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (Tx TopTx era) -> Identity (StrictSeq (Tx TopTx era)))
-> BlockBody era -> Identity (BlockBody era)
forall era.
EraBlockBody era =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
txSeqBlockBodyL ((StrictSeq (Tx TopTx era) -> Identity (StrictSeq (Tx TopTx era)))
 -> BlockBody era -> Identity (BlockBody era))
-> StrictSeq (Tx TopTx era) -> BlockBody era -> BlockBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Tx TopTx era] -> StrictSeq (Tx TopTx era)
forall a. [a] -> StrictSeq a
SSeq.fromList [Tx TopTx era]
txs
      nes <- Getting (NewEpochState era) (ImpTestState era) (NewEpochState era)
-> ImpM (LedgerSpec era) (NewEpochState era)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (NewEpochState era) (ImpTestState era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ImpTestState era -> f (ImpTestState era)
impNESL
      let ls = NewEpochState era
nes NewEpochState era
-> Getting (LedgerState era) (NewEpochState era) (LedgerState era)
-> LedgerState era
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (LedgerState era) (EpochState era))
-> NewEpochState era -> Const (LedgerState era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (LedgerState era) (EpochState era))
 -> NewEpochState era
 -> Const (LedgerState era) (NewEpochState era))
-> ((LedgerState era -> Const (LedgerState era) (LedgerState era))
    -> EpochState era -> Const (LedgerState era) (EpochState era))
-> Getting (LedgerState era) (NewEpochState era) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const (LedgerState era) (LedgerState era))
-> EpochState era -> Const (LedgerState era) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL
          pp = NewEpochState era
nes NewEpochState era
-> Getting (PParams era) (NewEpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (PParams era) (EpochState era))
-> NewEpochState era -> Const (PParams era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (PParams era) (EpochState era))
 -> NewEpochState era -> Const (PParams era) (NewEpochState era))
-> ((PParams era -> Const (PParams era) (PParams era))
    -> EpochState era -> Const (PParams era) (EpochState era))
-> Getting (PParams era) (NewEpochState era) (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL @era
      kh <- freshKeyHash
      slotNo <- use impLastTickG
      let bhView =
            BHeaderView
              { bhviewID :: KeyHash BlockIssuer
bhviewID = KeyHash BlockIssuer
kh
              , bhviewBSize :: Word32
bhviewBSize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ProtVer -> BlockBody era -> Int
forall era. EraBlockBody era => ProtVer -> BlockBody era -> Int
bBodySize (Version -> Nat -> ProtVer
ProtVer (forall era. Era era => Version
eraProtVerLow @era) Nat
0) BlockBody era
blockBody
              , bhviewHSize :: Int
bhviewHSize = Int
0
              , bhviewBHash :: Hash HASH EraIndependentBlockBody
bhviewBHash = BlockBody era -> Hash HASH EraIndependentBlockBody
forall era.
EraBlockBody era =>
BlockBody era -> Hash HASH EraIndependentBlockBody
hashBlockBody BlockBody era
blockBody
              , bhviewSlot :: SlotNo
bhviewSlot = SlotNo
slotNo
              }
      tryRunImpRule @"BBODY"
        (BbodyEnv pp (nes ^. chainAccountStateL))
        (BbodyState ls (BlocksMade Map.empty))
        (Block {blockHeader = bhView, blockBody})
    isPostV10 :: ProtVer -> Bool
isPostV10 ProtVer
protVer = ProtVer -> Version
pvMajor ProtVer
protVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= forall (v :: Nat). (KnownNat v, 0 <= v, v <= MaxVersion) => Version
natVersion @11

-- Generate a list of integers such that the sum of their multiples by scale is greater than toExceed
-- and each individual value multiplied by the scale is smaller than maxSingle
genNumAdditionsExceeding :: Int -> Int -> Int -> ImpTestM era [Int]
genNumAdditionsExceeding :: forall era. Int -> Int -> Int -> ImpTestM era [Int]
genNumAdditionsExceeding Int
sc Int
maxSingle Int
toExceed = Int -> [Int] -> ImpM (LedgerSpec era) [Int]
forall {m :: * -> *}. MonadGen m => Int -> [Int] -> m [Int]
go Int
0 []
  where
    go :: Int -> [Int] -> m [Int]
go Int
tot ![Int]
acc
      | Int
tot Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
toExceed = [Int] -> m [Int]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> m [Int]) -> [Int] -> m [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
acc
      | Bool
otherwise = do
          x <- (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
toExceed Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
sc) (Int
maxSingle Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
sc))
          let !newTot = Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sc
          go newTot (x : acc)