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

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

import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.BaseTypes (Mismatch (..), ProtVer (..), natVersion)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..))
import Cardano.Ledger.Conway.Rules (
  ConwayBbodyPredFailure (..),
  totalRefScriptSizeInBlock,
 )
import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireSignature,
 )
import Data.Foldable (for_)
import Data.List (inits)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Traversable (for)
import Data.Word (Word32)
import Lens.Micro ((&), (.~), (^.))
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

    txs <- for txScriptCounts $ \Int
n -> do
      -- Instead of using the rootTxIn, we're creating an input for each transaction
      -- so that transactions that will be submitted in a block
      -- can be submitted independently from the ones that prepared the
      -- reference inputs
      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
100_000_000)
      refIns <- replicateM n $ produceRefScript (fromPlutusScript plutusScript)
      pure $ mkTxWithRefInputs txIn (NE.fromList refIns)

    submitFailingBlock
      txs
      [ injectFailure
          ( BodyRefScriptsSizeTooBig $
              Mismatch
                { mismatchSupplied = scriptSize * sum txScriptCounts
                , 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 :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtLeast @11 (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
      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
        -- These txs will be grouped into a block
        buildTxs = [Int]
-> (Int -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int]
txScriptCounts ((Int -> ImpM (LedgerSpec era) (Tx TopTx era))
 -> ImpM (LedgerSpec era) ())
-> (Int -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
          refIns <- Int -> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn])
-> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn]
forall a b. (a -> b) -> a -> b
$ Script era -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
Script era -> ImpTestM era TxIn
produceRefScript (PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
plutusScript)
          submitTx $
            mkBasicTx mkBasicTxBody
              & bodyTxL . referenceInputsTxBodyL .~ Set.fromList refIns

      withTxsInFailingBlock
        buildTxs
        [ injectFailure
            ( BodyRefScriptsSizeTooBig $
                Mismatch
                  { mismatchSupplied = scriptSize * sum txScriptCounts
                  , 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.
    txsWithSizes <- 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 (txs, sizes) = unzip txsWithRefScriptSizes
      totalRefScriptSizeInBlock protVer (SSeq.fromList txs) <$> getUTxO `shouldReturn` sum sizes

      pure txsWithRefScriptSizes

    -- for each prefix of the list, the accumulated sum should match the sum of the applied transactions
    for_ (drop 1 $ inits txsWithSizes) $ \[(Tx TopTx era, Int)]
prefix -> do
      let ([Tx TopTx era]
txs, [Int]
sizes) = [(Tx TopTx era, Int)] -> ([Tx TopTx era], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Tx TopTx era, Int)]
prefix
          expectedSize :: Int
expectedSize = 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 [Int]
sizes else Int
0
      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]
txs) (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` Int
expectedSize

  -- 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
    ProtVer pv _ <- getProtVer
    collRefScriptTxOut <- do
      addr <-
        if pv < natVersion @12
          then freshKeyAddr_
          else freshKeyAddrNoPtr_
      pure $ mkBasicTxOut addr mempty & referenceScriptTxOutL .~ pure (fromNativeScript script)

    txs <- 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
    isPostV10 :: ProtVer -> Bool
isPostV10 ProtVer
protVer = ProtVer -> Version
pvMajor ProtVer
protVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= forall (v :: Natural).
(KnownNat v, MinVersion <= 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)