{-# 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.Plutus (SLanguage (..))
import Cardano.Ledger.SafeHash (originalBytesSize)
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 (alwaysFailsWithDatum)

spec ::
  forall era.
  ( AlonzoEraImp era
  , BabbageEraTxBody era
  , EraSegWits era
  , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era, BabbageEraTxBody era, EraSegWits era,
 InjectRuleFailure "BBODY" ConwayBbodyPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"BBODY" forall a b. (a -> b) -> a -> b
$ do
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"BodyRefScriptsSizeTooBig" forall a b. (a -> b) -> a -> b
$ do
    Just (Script era
script :: Script era) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Script era)
largeScript
    let scriptSize :: Int
scriptSize = 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 <-
      forall era. Int -> Int -> Int -> ImpTestM era [Int]
genNumAdditionsExceeding
        Int
scriptSize
        Int
maxRefScriptSizePerTx
        Int
maxRefScriptSizePerBlock

    let expectedTotalRefScriptSize :: Int
expectedTotalRefScriptSize = Int
scriptSize forall a. Num a => 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.
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
txScriptCounts forall a b. (a -> b) -> a -> b
$ \Int
n -> do
        TxIn (EraCrypto era)
txIn <- ImpTestM era (TxIn (EraCrypto era))
mkTxIn
        TxIn (EraCrypto era)
-> Script era -> Int -> ImpM (LedgerSpec era) (Tx era)
mkTxWithNScripts TxIn (EraCrypto era)
txIn Script era
script Int
n
          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupFees
          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> StrictSeq a
SSeq.fromList [Tx era]
txs
    NewEpochState era
nes <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL
    let ls :: LedgerState era
ls = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL
        pp :: PParams era
pp = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. 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
        account :: AccountState
account = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) AccountState
esAccountStateL
    KeyHash 'BlockIssuer (EraCrypto era)
kh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
    SlotNo
slotNo <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. SimpleGetter (ImpTestState era) SlotNo
impLastTickG
    let bhView :: BHeaderView (EraCrypto era)
bhView =
          BHeaderView
            { bhviewID :: KeyHash 'BlockIssuer (EraCrypto era)
bhviewID = KeyHash 'BlockIssuer (EraCrypto era)
kh
            , bhviewBSize :: Word32
bhviewBSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall era. EraSegWits era => ProtVer -> TxSeq era -> Int
bBodySize (Version -> Natural -> ProtVer
ProtVer (forall era. Era era => Version
eraProtVerLow @era) Natural
0) TxSeq era
txSeq
            , bhviewHSize :: Int
bhviewHSize = Int
0
            , bhviewBHash :: Hash (EraCrypto era) EraIndependentBlockBody
bhviewBHash = forall era.
EraSegWits era =>
TxSeq era -> Hash (HASH (EraCrypto era)) 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"
        (forall era. PParams era -> AccountState -> BbodyEnv era
BbodyEnv PParams era
pp AccountState
account)
        (forall era.
State (EraRule "LEDGERS" era)
-> BlocksMade (EraCrypto era) -> ShelleyBbodyState era
BbodyState LedgerState era
ls (forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall k a. Map k a
Map.empty))
        (forall h era. h -> TxSeq era -> Block h era
UnsafeUnserialisedBlock BHeaderView (EraCrypto era)
bhView TxSeq era
txSeq)
    NonEmpty (PredicateFailure (EraRule "BBODY" era))
predFailures
      forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. [a] -> NonEmpty a
NE.fromList
        [ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure
            ( forall era. Mismatch 'RelLTEQ Int -> ConwayBbodyPredFailure era
BodyRefScriptsSizeTooBig forall a b. (a -> b) -> a -> b
$
                Mismatch
                  { mismatchSupplied :: Int
mismatchSupplied = Int
expectedTotalRefScriptSize
                  , mismatchExpected :: Int
mismatchExpected = Int
maxRefScriptSizePerBlock
                  }
            )
        ]
  where
    mkTxIn :: ImpTestM era (TxIn (EraCrypto era))
    mkTxIn :: ImpTestM era (TxIn (EraCrypto era))
mkTxIn = do
      Addr (EraCrypto era)
addr <- forall s c (m :: * -> *) g.
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (Addr c)
freshKeyAddr_
      forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo Addr (EraCrypto era)
addr (Integer -> Coin
Coin Integer
7_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 forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage 'PlutusV2
SPlutusV2
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
script

    mkTxWithNScripts :: TxIn (EraCrypto era) -> Script era -> Int -> ImpTestM era (Tx era)
    mkTxWithNScripts :: TxIn (EraCrypto era)
-> Script era -> Int -> ImpM (LedgerSpec era) (Tx era)
mkTxWithNScripts TxIn (EraCrypto era)
txIn Script era
script Int
n = do
      [TxIn (EraCrypto era)]
txIns <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
Script era -> ImpTestM era (TxIn (EraCrypto era))
produceRefScript Script era
script)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        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.
BabbageEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList [TxIn (EraCrypto era)]
txIns
            forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 = forall {m :: * -> *}. MonadGen m => Int -> [Int] -> m [Int]
go Int
0 []
  where
    go :: Int -> [Int] -> m [Int]
go Int
tot ![Int]
acc
      | Int
tot forall a. Ord a => a -> a -> Bool
> Int
toExceed = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Int]
acc
      | Bool
otherwise = do
          Int
x <- forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, forall a. Ord a => a -> a -> a
min (Int
toExceed forall a. Integral a => a -> a -> a
`div` Int
sc) (Int
maxSingle forall a. Integral a => a -> a -> a
`div` Int
sc))
          let !newTot :: Int
newTot = Int
tot forall a. Num a => a -> a -> a
+ Int
x forall a. Num a => a -> a -> a
* Int
sc
          Int -> [Int] -> m [Int]
go Int
newTot (Int
x forall a. a -> [a] -> [a]
: [Int]
acc)