{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# 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 (..))
import Cardano.Ledger.Block
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Rules (
  ConwayBbodyPredFailure (..),
  maxRefScriptSizePerBlock,
  maxRefScriptSizePerTx,
 )
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Plutus (SLanguage (..))
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (
  BbodyEnv (..),
  ShelleyBbodyState (..),
 )
import Cardano.Ledger.TxIn
import Control.Monad (forM)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro ((&), (.~), (^.))
import Lens.Micro.Mtl (use)
import Test.Cardano.Ledger.Babbage.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (purposeIsWellformedNoDatum)

spec ::
  forall era.
  ( AlonzoEraImp era
  , BabbageEraTxBody era
  , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era, BabbageEraTxBody era,
 InjectRuleFailure "BBODY" ConwayBbodyPredFailure 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
"BBODY" (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
"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
    Just (Script era
script :: Script era) <- Maybe (AlonzoScript era)
-> ImpM (LedgerSpec era) (Maybe (AlonzoScript era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Script era)
Maybe (AlonzoScript era)
largeScript
    let scriptSize :: Int
scriptSize = Script era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize Script era
script

    -- 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
    [Int]
txScriptCounts <-
      Int -> Int -> Int -> ImpTestM era [Int]
forall era. Int -> Int -> Int -> ImpTestM era [Int]
genNumAdditionsExceeding
        Int
scriptSize
        Int
maxRefScriptSizePerTx
        Int
maxRefScriptSizePerBlock

    let expectedTotalRefScriptSize :: Int
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
    [Tx era]
txs <- 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.
      [Int]
-> (Int -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) [Tx era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
txScriptCounts ((Int -> ImpM (LedgerSpec era) (Tx era))
 -> ImpM (LedgerSpec era) [Tx era])
-> (Int -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) [Tx era]
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
        TxIn
txIn <- ImpTestM era TxIn
mkTxIn
        TxIn -> Script era -> Int -> ImpM (LedgerSpec era) (Tx era)
mkTxWithNScripts TxIn
txIn Script era
script Int
n
          ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx 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 era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupFees
          ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx 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 era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits

    let txSeq :: TxSeq era
txSeq = forall era. EraSegWits era => StrictSeq (Tx era) -> TxSeq era
toTxSeq @era (StrictSeq (Tx era) -> TxSeq era)
-> StrictSeq (Tx era) -> TxSeq era
forall a b. (a -> b) -> a -> b
$ [Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
SSeq.fromList [Tx era]
txs
    NewEpochState era
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 :: LedgerState era
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 :: PParams era
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
. (PParams era -> Const (PParams era) (PParams era))
-> EpochState era -> Const (PParams era) (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
    KeyHash 'BlockIssuer
kh <- ImpM (LedgerSpec era) (KeyHash 'BlockIssuer)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    SlotNo
slotNo <- Getting SlotNo (ImpTestState era) SlotNo
-> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting SlotNo (ImpTestState era) SlotNo
forall era r. Getting r (ImpTestState era) SlotNo
impLastTickG
    let bhView :: BHeaderView
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 -> TxSeq era -> Int
forall era. EraSegWits era => ProtVer -> TxSeq era -> Int
bBodySize (Version -> Nat -> ProtVer
ProtVer (forall era. Era era => Version
eraProtVerLow @era) Nat
0) TxSeq era
txSeq
            , bhviewHSize :: Int
bhviewHSize = Int
0
            , bhviewBHash :: Hash HASH EraIndependentBlockBody
bhviewBHash = TxSeq era -> Hash HASH EraIndependentBlockBody
forall era.
EraSegWits era =>
TxSeq era -> Hash HASH EraIndependentBlockBody
hashTxSeq TxSeq era
txSeq
            , bhviewSlot :: SlotNo
bhviewSlot = SlotNo
slotNo
            }
    Left NonEmpty (PredicateFailure (EraRule "BBODY" era))
predFailures <-
      forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule @"BBODY"
        (PParams era -> ChainAccountState -> BbodyEnv era
forall era. PParams era -> ChainAccountState -> BbodyEnv era
BbodyEnv PParams era
pp (NewEpochState era
nes NewEpochState era
-> Getting ChainAccountState (NewEpochState era) ChainAccountState
-> ChainAccountState
forall s a. s -> Getting a s a -> a
^. Getting ChainAccountState (NewEpochState era) ChainAccountState
forall era. Lens' (NewEpochState era) ChainAccountState
forall (t :: * -> *) era.
CanSetChainAccountState t =>
Lens' (t era) ChainAccountState
chainAccountStateL))
        (State (EraRule "LEDGERS" era)
-> BlocksMade -> ShelleyBbodyState era
forall era.
State (EraRule "LEDGERS" era)
-> BlocksMade -> ShelleyBbodyState era
BbodyState State (EraRule "LEDGERS" era)
LedgerState era
ls (Map (KeyHash 'StakePool) Nat -> BlocksMade
BlocksMade Map (KeyHash 'StakePool) Nat
forall k a. Map k a
Map.empty))
        (BHeaderView -> TxSeq era -> Block BHeaderView era
forall h era. h -> TxSeq era -> Block h era
Block BHeaderView
bhView TxSeq era
txSeq)
    NonEmpty (PredicateFailure (EraRule "BBODY" era))
predFailures
      NonEmpty (PredicateFailure (EraRule "BBODY" era))
-> NonEmpty (PredicateFailure (EraRule "BBODY" era))
-> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` [PredicateFailure (EraRule "BBODY" era)]
-> NonEmpty (PredicateFailure (EraRule "BBODY" era))
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
        [ ConwayBbodyPredFailure era -> EraRuleFailure "BBODY" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure
            ( Mismatch 'RelLTEQ Int -> ConwayBbodyPredFailure era
forall era. Mismatch 'RelLTEQ Int -> ConwayBbodyPredFailure era
BodyRefScriptsSizeTooBig (Mismatch 'RelLTEQ Int -> ConwayBbodyPredFailure era)
-> Mismatch 'RelLTEQ Int -> ConwayBbodyPredFailure era
forall a b. (a -> b) -> a -> b
$
                Mismatch
                  { mismatchSupplied :: Int
mismatchSupplied = Int
expectedTotalRefScriptSize
                  , mismatchExpected :: Int
mismatchExpected = Int
maxRefScriptSizePerBlock
                  }
            )
        ]
  where
    mkTxIn :: ImpTestM era TxIn
    mkTxIn :: ImpTestM era TxIn
mkTxIn = do
      Addr
addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
      Addr -> Coin -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr (Integer -> Coin
Coin Integer
8_000_000)

    largeScript :: Maybe (Script era)
    largeScript :: Maybe (Script era)
largeScript = do
      PlutusScript era
script <- forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (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
      AlonzoScript era -> Maybe (AlonzoScript era)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AlonzoScript era -> Maybe (AlonzoScript era))
-> AlonzoScript era -> Maybe (AlonzoScript era)
forall a b. (a -> b) -> a -> b
$ PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
script

    mkTxWithNScripts :: TxIn -> Script era -> Int -> ImpTestM era (Tx era)
    mkTxWithNScripts :: TxIn -> Script era -> Int -> ImpM (LedgerSpec era) (Tx era)
mkTxWithNScripts TxIn
txIn Script era
script Int
n = do
      [TxIn]
txIns <- Int -> ImpTestM era TxIn -> ImpM (LedgerSpec era) [TxIn]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Script era -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
Script era -> ImpTestM era TxIn
produceRefScript Script era
script)
      Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
        TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody 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
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL ((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. Ord a => [a] -> Set a
Set.fromList [TxIn]
txIns
            TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((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
.~ [Item (Set TxIn)
TxIn
txIn]

-- 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
          Int
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
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
          Int -> [Int] -> m [Int]
go Int
newTot (Int
x Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
acc)