{-# 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.Alonzo.Rules (AlonzoUtxosPredFailure)
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 (..),
Event,
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.Core.Utils (txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysFailsNoDatum, purposeIsWellformedNoDatum)
spec ::
forall era.
( AlonzoEraImp era
, BabbageEraTxBody era
, InjectRuleFailure "BBODY" ConwayBbodyPredFailure era
, InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
, ToExpr (Event (EraRule "BBODY" era))
, ConwayEraPParams era
) =>
SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era, BabbageEraTxBody era,
InjectRuleFailure "BBODY" ConwayBbodyPredFailure era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
ToExpr (Event (EraRule "BBODY" era)), ConwayEraPParams 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 era
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 :: Int
scriptSize = PlutusScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize PlutusScript era
plutusScript
PParams era
pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
let
maxRefScriptSizePerTx :: Int
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 :: Int
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
[Int]
txScriptCounts <-
Int -> Int -> Int -> ImpTestM era [Int]
forall era. Int -> Int -> Int -> ImpTestM era [Int]
genNumAdditionsExceeding
Int
scriptSize
Int
maxRefScriptSizePerTx
Int
maxRefScriptSizePerBlock
let mkTxWithNScripts :: Int -> ImpM (LedgerSpec era) (Tx era)
mkTxWithNScripts Int
n = do
TxIn
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)
[TxIn]
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)
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
$ TxIn -> NonEmpty TxIn -> Tx era
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
TxIn -> NonEmpty TxIn -> Tx era
mkTxWithRefInputs TxIn
txIn ([TxIn] -> NonEmpty TxIn
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [TxIn]
refIns)
[Tx era]
txs <- do
[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
Int -> ImpM (LedgerSpec era) (Tx era)
forall {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 (Event (EraRule "TICK" era)),
ToExpr (Event (EraRule "LEDGER" era)),
Eq (Event (EraRule "TICK" era)), Eq (Event (EraRule "LEDGER" era)),
NFData (Event (EraRule "TICK" era)),
NFData (Event (EraRule "LEDGER" era)),
Typeable (Event (EraRule "TICK" era)),
Typeable (Event (EraRule "LEDGER" era))) =>
Int -> ImpM (LedgerSpec era) (Tx era)
mkTxWithNScripts 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 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
NonEmpty (PredicateFailure (EraRule "BBODY" era))
predFailures <- Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(ShelleyBbodyState era, [Event (EraRule "BBODY" era)])
-> ImpM
(LedgerSpec era)
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
forall b (m :: * -> *) a.
(HasCallStack, ToExpr b, MonadIO m) =>
Either a b -> m a
expectLeftExpr (Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(ShelleyBbodyState era, [Event (EraRule "BBODY" era)])
-> ImpM
(LedgerSpec era)
(NonEmpty (PredicateFailure (EraRule "BBODY" era))))
-> ImpM
(LedgerSpec era)
(Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(ShelleyBbodyState era, [Event (EraRule "BBODY" era)]))
-> ImpM
(LedgerSpec era)
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Tx era]
-> ImpM
(LedgerSpec era)
(Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(State (EraRule "BBODY" era), [Event (EraRule "BBODY" era)]))
tryRunBBODY [Tx era]
txs
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
}
)
]
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 era
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 :: Int
scriptSize = PlutusScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize PlutusScript era
plutusScript
PParams era
pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
let
maxRefScriptSizePerTx :: Int
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 :: Int
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
[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 :: [Tx era] <- ImpM (LedgerSpec era) [Tx era] -> ImpM (LedgerSpec era) [Tx era]
forall era a. ImpTestM era a -> ImpTestM era a
simulateThenRestore (ImpM (LedgerSpec era) [Tx era] -> ImpM (LedgerSpec era) [Tx era])
-> ImpM (LedgerSpec era) [Tx era] -> ImpM (LedgerSpec era) [Tx era]
forall a b. (a -> b) -> a -> b
$ do
[[Tx era]] -> [Tx era]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
([[Tx era]] -> [Tx era])
-> ImpM (LedgerSpec era) [[Tx era]]
-> ImpM (LedgerSpec era) [Tx era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [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
n -> do
[Tx era]
refScriptTxs <-
Int
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) [Tx era]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (NonEmpty (Script era) -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
NonEmpty (Script era) -> ImpTestM era (Tx 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
:| []))
let txIns :: [TxIn]
txIns = (HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
`mkTxInPartial` Integer
0) (TxId -> TxIn) -> (Tx era -> TxId) -> Tx era -> TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx era -> TxId
forall era. EraTx era => Tx era -> TxId
txIdTx (Tx era -> TxIn) -> [Tx era] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx era]
refScriptTxs
TxIn
rootIn <- (TxIn, TxOut era) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, TxOut era) -> TxIn)
-> ImpM (LedgerSpec era) (TxIn, TxOut era)
-> ImpM (LedgerSpec era) TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (TxIn, TxOut era)
forall era. ImpTestM era (TxIn, TxOut era)
getImpRootTxOut
Tx era
spendTx <- TxIn -> NonEmpty TxIn -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
TxIn -> NonEmpty TxIn -> ImpTestM era (Tx era)
submitTxWithRefInputs TxIn
rootIn ([TxIn] -> NonEmpty TxIn
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [TxIn]
txIns)
[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
$ [Tx era]
refScriptTxs [Tx era] -> [Tx era] -> [Tx era]
forall a. [a] -> [a] -> [a]
++ [Item [Tx era]
Tx era
spendTx]
)
NonEmpty (PredicateFailure (EraRule "BBODY" era))
predFailures <- Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(ShelleyBbodyState era, [Event (EraRule "BBODY" era)])
-> ImpM
(LedgerSpec era)
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
forall b (m :: * -> *) a.
(HasCallStack, ToExpr b, MonadIO m) =>
Either a b -> m a
expectLeftExpr (Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(ShelleyBbodyState era, [Event (EraRule "BBODY" era)])
-> ImpM
(LedgerSpec era)
(NonEmpty (PredicateFailure (EraRule "BBODY" era))))
-> ImpM
(LedgerSpec era)
(Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(ShelleyBbodyState era, [Event (EraRule "BBODY" era)]))
-> ImpM
(LedgerSpec era)
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Tx era]
-> ImpM
(LedgerSpec era)
(Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(State (EraRule "BBODY" era), [Event (EraRule "BBODY" era)]))
tryRunBBODY [Tx era]
txs
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
}
)
]
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
Timelock era
script <- forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature @era (KeyHash 'Witness -> Timelock era)
-> ImpM (LedgerSpec era) (KeyHash 'Witness)
-> ImpM (LedgerSpec era) (Timelock 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 :: Int
scriptSize = Timelock era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize Timelock era
script
TxIn
scriptSpendIn <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript Timelock era
NativeScript era
script ImpTestM era ScriptHash
-> (ScriptHash -> 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
>>= ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript
TxIn
scriptSpendIn2 <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript Timelock era
NativeScript era
script ImpTestM era ScriptHash
-> (ScriptHash -> 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
>>= ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript
ProtVer
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
([(Tx era, Int)], Int)
txsWithRefScriptSizes :: ([(Tx era, Int)], Int) <- ImpTestM era ([(Tx era, Int)], Int)
-> ImpTestM era ([(Tx era, Int)], Int)
forall era a. ImpTestM era a -> ImpTestM era a
simulateThenRestore (ImpTestM era ([(Tx era, Int)], Int)
-> ImpTestM era ([(Tx era, Int)], Int))
-> ImpTestM era ([(Tx era, Int)], Int)
-> ImpTestM era ([(Tx era, Int)], Int)
forall a b. (a -> b) -> a -> b
$ do
let mkTxWithExpectedSize :: Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
mkTxWithExpectedSize Int
expectedSize ImpM (LedgerSpec era) (Tx era)
txAction = do
Tx era
tx <- ImpM (LedgerSpec era) (Tx era)
txAction
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
forall era.
(AlonzoEraTx era, BabbageEraTxBody era) =>
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
totalRefScriptSizeInBlock ProtVer
protVer [Item (StrictSeq (Tx era))
Tx era
tx] (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
(Tx era, Int) -> ImpM (LedgerSpec era) (Tx era, Int)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era
tx, Int
expectedSize)
(Tx era, Int)
refScriptTx1 <-
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall {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 ...),
AlonzoEraTx era, BabbageEraTxBody era) =>
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
mkTxWithExpectedSize Int
0 (ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int))
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall a b. (a -> b) -> a -> b
$
NonEmpty (Script era) -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
NonEmpty (Script era) -> ImpTestM era (Tx era)
produceRefScriptsTx (NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
NativeScript era
script AlonzoScript era
-> [AlonzoScript era] -> NonEmpty (AlonzoScript era)
forall a. a -> [a] -> NonEmpty a
:| [])
let refScriptTx1In :: TxIn
refScriptTx1In = Int -> Tx era -> TxIn
forall era. (HasCallStack, EraTx era) => Int -> Tx era -> TxIn
txInAt Int
0 ((Tx era, Int) -> Tx era
forall a b. (a, b) -> a
fst (Tx era, Int)
refScriptTx1)
(Tx era, Int)
refScriptTx2 <-
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall {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 ...),
AlonzoEraTx era, BabbageEraTxBody era) =>
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
mkTxWithExpectedSize Int
0 (ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int))
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall a b. (a -> b) -> a -> b
$
NonEmpty (Script era) -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
NonEmpty (Script era) -> ImpTestM era (Tx era)
produceRefScriptsTx (NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
NativeScript era
script AlonzoScript era
-> [AlonzoScript era] -> NonEmpty (AlonzoScript era)
forall a. a -> [a] -> NonEmpty a
:| [])
(Tx era, Int)
spendScriptWithRefScriptTx <-
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall {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 ...),
AlonzoEraTx era, BabbageEraTxBody era) =>
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
mkTxWithExpectedSize Int
scriptSize (ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int))
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall a b. (a -> b) -> a -> b
$
TxIn -> NonEmpty TxIn -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
TxIn -> NonEmpty TxIn -> ImpTestM era (Tx era)
submitTxWithRefInputs TxIn
scriptSpendIn [Item (NonEmpty TxIn)
TxIn
refScriptTx1In]
(Tx era, Int)
spendScriptWithTwoRefScriptsTx <-
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall {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 ...),
AlonzoEraTx era, BabbageEraTxBody era) =>
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
mkTxWithExpectedSize (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
scriptSize) (ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int))
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall a b. (a -> b) -> a -> b
$
TxIn -> NonEmpty TxIn -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
TxIn -> NonEmpty TxIn -> ImpTestM era (Tx era)
submitTxWithRefInputs TxIn
scriptSpendIn2 [Item (NonEmpty TxIn)
TxIn
refScriptTx1In, Int -> Tx era -> TxIn
forall era. (HasCallStack, EraTx era) => Int -> Tx era -> TxIn
txInAt Int
0 ((Tx era, Int) -> Tx era
forall a b. (a, b) -> a
fst (Tx era, Int)
refScriptTx2)]
TxIn
rootIn <- (TxIn, TxOut era) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, TxOut era) -> TxIn)
-> ImpM (LedgerSpec era) (TxIn, TxOut era)
-> ImpM (LedgerSpec era) TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (TxIn, TxOut era)
forall era. ImpTestM era (TxIn, TxOut era)
getImpRootTxOut
(Tx era, Int)
spendRootUtxoTx <-
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall {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 ...),
AlonzoEraTx era, BabbageEraTxBody era) =>
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
mkTxWithExpectedSize Int
scriptSize (ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int))
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall a b. (a -> b) -> a -> b
$
TxIn -> NonEmpty TxIn -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
TxIn -> NonEmpty TxIn -> ImpTestM era (Tx era)
submitTxWithRefInputs TxIn
rootIn [Item (NonEmpty TxIn)
TxIn
refScriptTx1In]
(Tx era, Int)
spendRefScriptTx <-
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall {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 ...),
AlonzoEraTx era, BabbageEraTxBody era) =>
Int
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
mkTxWithExpectedSize Int
scriptSize (ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int))
-> ImpM (LedgerSpec era) (Tx era)
-> ImpM (LedgerSpec era) (Tx era, Int)
forall a b. (a -> b) -> a -> b
$
Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
TxIn -> NonEmpty TxIn -> Tx era
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
TxIn -> NonEmpty TxIn -> Tx era
mkTxWithRefInputs TxIn
refScriptTx1In ([TxIn] -> NonEmpty TxIn
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [Item [TxIn]
TxIn
refScriptTx1In])
let txsWithRefScriptSizes :: [(Tx era, Int)]
txsWithRefScriptSizes =
[ (Tx era, Int)
Item [(Tx era, Int)]
refScriptTx1
, (Tx era, Int)
Item [(Tx era, Int)]
refScriptTx2
, (Tx era, Int)
Item [(Tx era, Int)]
spendScriptWithRefScriptTx
, (Tx era, Int)
Item [(Tx era, Int)]
spendScriptWithTwoRefScriptsTx
, (Tx era, Int)
Item [(Tx era, Int)]
spendRootUtxoTx
, (Tx era, Int)
Item [(Tx era, Int)]
spendRefScriptTx
]
let expectedTotalRefScriptSize :: Int
expectedTotalRefScriptSize = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
scriptSize
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
forall era.
(AlonzoEraTx era, BabbageEraTxBody era) =>
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
totalRefScriptSizeInBlock ProtVer
protVer ([Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
SSeq.fromList ((Tx era, Int) -> Tx era
forall a b. (a, b) -> a
fst ((Tx era, Int) -> Tx era) -> [(Tx era, Int)] -> [Tx era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Tx era, Int)]
txsWithRefScriptSizes))
(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
expectedTotalRefScriptSize
([(Tx era, Int)], Int) -> ImpTestM era ([(Tx era, Int)], Int)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Tx era, Int)]
txsWithRefScriptSizes, Int
expectedTotalRefScriptSize)
let ([(Tx era, Int)]
txWithSizes, Int
expectedTotalSize) = ([(Tx era, Int)], Int)
txsWithRefScriptSizes
[Int]
-> (Int -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int
Item [Int]
1 .. [(Tx era, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Tx era, Int)]
txWithSizes] :: [Int]) ((Int -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ())
-> (Int -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \Int
ix -> do
let slice :: [(Tx era, Int)]
slice = Int -> [(Tx era, Int)] -> [(Tx era, Int)]
forall a. Int -> [a] -> [a]
take Int
ix [(Tx era, Int)]
txWithSizes
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
forall era.
(AlonzoEraTx era, BabbageEraTxBody era) =>
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
totalRefScriptSizeInBlock ProtVer
protVer ([Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
SSeq.fromList ((Tx era, Int) -> Tx era
forall a b. (a, b) -> a
fst ((Tx era, Int) -> Tx era) -> [(Tx era, Int)] -> [Tx era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Tx 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 era, Int) -> Int
forall a b. (a, b) -> b
snd ((Tx era, Int) -> Int) -> [(Tx era, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Tx era, Int)]
slice) else Int
0)
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
forall era.
(AlonzoEraTx era, BabbageEraTxBody era) =>
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
totalRefScriptSizeInBlock ProtVer
protVer ([Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
SSeq.fromList ((Tx era, Int) -> Tx era
forall a b. (a, b) -> a
fst ((Tx era, Int) -> Tx era) -> [(Tx era, Int)] -> [Tx era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Tx era, Int)]
txWithSizes))
(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
expectedTotalSize else Int
0)
SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall era.
SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
disableImpInitExpectLedgerRuleConformance (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Use a reference script in a collateral output" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
ProtVer
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
TxIn
failingPlutusTxIn <- do
let plutus :: Plutus 'PlutusV3
plutus = SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage 'PlutusV3
SPlutusV3
ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpM (LedgerSpec era) TxIn)
-> ScriptHash -> ImpM (LedgerSpec era) TxIn
forall a b. (a -> b) -> a -> b
$ Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript Plutus 'PlutusV3
plutus
Timelock era
script <- forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature @era (KeyHash 'Witness -> Timelock era)
-> ImpM (LedgerSpec era) (KeyHash 'Witness)
-> ImpM (LedgerSpec era) (Timelock 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
TxIn
scriptTxIn <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript Timelock era
NativeScript era
script ImpTestM era ScriptHash
-> (ScriptHash -> 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
>>= ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript
let scriptSize :: Int
scriptSize = Timelock era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize Timelock era
script
TxOut era
collRefScriptTxOut <- do
Addr
addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
TxOut era -> ImpM (LedgerSpec era) (TxOut era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut era -> ImpM (LedgerSpec era) (TxOut era))
-> TxOut era -> ImpM (LedgerSpec era) (TxOut era)
forall a b. (a -> b) -> a -> b
$ Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
forall a. Monoid a => a
mempty TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
-> TxOut era -> Identity (TxOut era)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL ((StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
-> TxOut era -> Identity (TxOut era))
-> StrictMaybe (Script era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Script era -> StrictMaybe (Script era)
forall a. a -> StrictMaybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Timelock era
NativeScript era
script)
([Tx era]
txs :: [Tx era]) <- ImpM (LedgerSpec era) [Tx era] -> ImpM (LedgerSpec era) [Tx era]
forall era a. ImpTestM era a -> ImpTestM era a
simulateThenRestore (ImpM (LedgerSpec era) [Tx era] -> ImpM (LedgerSpec era) [Tx era])
-> ImpM (LedgerSpec era) [Tx era] -> ImpM (LedgerSpec era) [Tx era]
forall a b. (a -> b) -> a -> b
$ do
Tx era
createCollateralTx <-
Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, AlonzoEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era (Tx era)
submitPhase2Invalid (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
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. 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
failingPlutusTxIn]
TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (TxOut era))
Lens' (TxBody era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL ((StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
-> TxBody era -> Identity (TxBody era))
-> StrictMaybe (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictMaybe (TxOut era)
forall a. a -> StrictMaybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut era
collRefScriptTxOut
)
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
forall era.
(AlonzoEraTx era, BabbageEraTxBody era) =>
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
totalRefScriptSizeInBlock ProtVer
protVer [Item (StrictSeq (Tx era))
Tx era
createCollateralTx] (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
0
let refScriptTxIn :: TxIn
refScriptTxIn = Int -> Tx era -> TxIn
forall era. (HasCallStack, EraTx era) => Int -> Tx era -> TxIn
txInAt Int
1 Tx era
createCollateralTx
Tx era
useCollateralTx <- TxIn -> NonEmpty TxIn -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
TxIn -> NonEmpty TxIn -> ImpTestM era (Tx era)
submitTxWithRefInputs TxIn
scriptTxIn [Item (NonEmpty TxIn)
TxIn
refScriptTxIn]
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
forall era.
(AlonzoEraTx era, BabbageEraTxBody era) =>
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
totalRefScriptSizeInBlock ProtVer
protVer [Item (StrictSeq (Tx era))
Tx era
createCollateralTx, Item (StrictSeq (Tx era))
Tx era
useCollateralTx]
(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
scriptSize
[Tx era] -> ImpM (LedgerSpec era) [Tx era]
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Item [Tx era]
Tx era
createCollateralTx, Item [Tx era]
Tx era
useCollateralTx]
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
forall era.
(AlonzoEraTx era, BabbageEraTxBody era) =>
ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
totalRefScriptSizeInBlock ProtVer
protVer ([Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
SSeq.fromList [Tx 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` (if ProtVer -> Bool
isPostV10 ProtVer
protVer then Int
scriptSize else Int
0)
where
tryRunBBODY :: [Tx era]
-> ImpM
(LedgerSpec era)
(Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(State (EraRule "BBODY" era), [Event (EraRule "BBODY" era)]))
tryRunBBODY [Tx 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 era) -> Identity (StrictSeq (Tx era)))
-> BlockBody era -> Identity (BlockBody era)
forall era.
EraBlockBody era =>
Lens' (BlockBody era) (StrictSeq (Tx era))
Lens' (BlockBody era) (StrictSeq (Tx era))
txSeqBlockBodyL ((StrictSeq (Tx era) -> Identity (StrictSeq (Tx era)))
-> BlockBody era -> Identity (BlockBody era))
-> StrictSeq (Tx era) -> BlockBody era -> BlockBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [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
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL @era
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 -> 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
}
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 -> BlockBody era -> Block BHeaderView era
forall h era. h -> BlockBody era -> Block h era
Block BHeaderView
bhView BlockBody era
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
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)