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

module Test.Cardano.Ledger.Dijkstra.Imp.SubUtxoSpec (spec) where

import Cardano.Ledger.BaseTypes (
  Mismatch (..),
  Network (..),
  ProtVer,
  StrictMaybe (..),
  pvMajor,
 )
import Cardano.Ledger.Binary (EncCBOR, serialize)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules (
  DijkstraSubUtxoPredFailure (..),
  DijkstraUtxoPredFailure (..),
 )
import Cardano.Ledger.Mary.Value (
  AssetName,
  MaryValue (..),
  MultiAsset,
  PolicyID (..),
  multiAssetFromList,
 )
import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
import Cardano.Ledger.Shelley.Scripts (pattern RequireSignature)
import Cardano.Ledger.Tools (setMinCoinTxOut)
import Cardano.Ledger.TxIn (TxIn, mkTxInPartial)
import Cardano.Ledger.Val (inject)
import Control.Monad.State (gets)
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isNothing)
import qualified Data.OMap.Strict as OMap
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set.NonEmpty as NES
import Data.Word (Word64)
import Lens.Micro ((&), (.~), (<>~), (^.))
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysFailsWithDatum)

spec :: forall era. DijkstraEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp 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
"SUBUTXO" (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
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubOutsideValidityIntervalUTxO" (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
"the validity interval starts after the current slot" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      currentSlot <- (ImpTestState era -> SlotNo) -> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (ImpTestState era
-> Getting SlotNo (ImpTestState era) SlotNo -> SlotNo
forall s a. s -> Getting a s a -> a
^. Getting SlotNo (ImpTestState era) SlotNo
forall era r. Getting r (ImpTestState era) SlotNo
impCurSlotNoG)
      let validityInterval = StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (SlotNo
currentSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)) StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
      submitFailingSubTx
        (mkBasicTx $ mkBasicTxBody & vldtTxBodyL .~ validityInterval)
        [injectFailure $ SubOutsideValidityIntervalUTxO @era validityInterval currentSlot]

    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"the validity interval ends at the current slot" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      currentSlot <- (ImpTestState era -> SlotNo) -> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (ImpTestState era
-> Getting SlotNo (ImpTestState era) SlotNo -> SlotNo
forall s a. s -> Getting a s a -> a
^. Getting SlotNo (ImpTestState era) SlotNo
forall era r. Getting r (ImpTestState era) SlotNo
impCurSlotNoG)
      let validityInterval = StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
currentSlot)
      submitFailingSubTx
        (mkBasicTx $ mkBasicTxBody & vldtTxBodyL .~ validityInterval)
        [injectFailure $ SubOutsideValidityIntervalUTxO @era validityInterval currentSlot]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubOutputTooBigUTxO" (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
"an output holding a minted asset, once only ada-only values fit" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ImpM (LedgerSpec era) ()
forall era. DijkstraEraImp era => ImpTestM era ()
restrictMaxValSizeToAdaOnly
      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
      (multiAsset, txOut) <- freshAssetOutput
      let subTx :: Tx SubTx era
          subTx =
            TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
              TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (MultiAsset -> Identity MultiAsset)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> MultiAsset -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset
multiAsset
                TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
txOut]
      submitFailingTxM (mkTopTxWithSubTxs [subTx]) $ \Tx TopTx era
fixedUpTx -> do
        txOuts <- Tx TopTx era -> ImpM (LedgerSpec era) (NonEmpty (TxOut era))
forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (NonEmpty (TxOut era))
subTxOutputs Tx TopTx era
fixedUpTx
        pure [injectFailure . SubOutputTooBigUTxO @era $ outputTooBigEntry pp <$> txOuts]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"several such outputs, reported in the reverse of their order in the body" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ImpM (LedgerSpec era) ()
forall era. DijkstraEraImp era => ImpTestM era ()
restrictMaxValSizeToAdaOnly
      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
      (firstAsset, firstTxOut) <- freshAssetOutput
      (secondAsset, secondTxOut) <- freshAssetOutput
      let subTx :: Tx SubTx era
          subTx =
            TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
              TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (MultiAsset -> Identity MultiAsset)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> MultiAsset -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset
firstAsset MultiAsset -> MultiAsset -> MultiAsset
forall a. Semigroup a => a -> a -> a
<> MultiAsset
secondAsset
                TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
firstTxOut, Item (StrictSeq (TxOut era))
TxOut era
secondTxOut]
      submitFailingTxM (mkTopTxWithSubTxs [subTx]) $ \Tx TopTx era
fixedUpTx -> do
        txOuts <- Tx TopTx era -> ImpM (LedgerSpec era) (NonEmpty (TxOut era))
forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (NonEmpty (TxOut era))
subTxOutputs Tx TopTx era
fixedUpTx
        pure
          [ injectFailure . SubOutputTooBigUTxO @era . NE.reverse $
              outputTooBigEntry pp <$> txOuts
          ]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubInputSetEmptyUTxO" (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
"a sub-transaction with no inputs" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      txIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      withPostFixup (pure . (bodyTxL . inputsTxBodyL <>~ [txIn])) $
        withPostFixupSubTxs (rederiveAddrTxWits . (bodyTxL . inputsTxBodyL .~ mempty)) $
          submitFailingSubTx
            (mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn])
            [injectFailure $ SubInputSetEmptyUTxO @era]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubBadInputsUTxO" (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
"a reference input in no UTxO fails only the check against the original UTxO" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let badReferenceInput :: TxIn
badReferenceInput = forall era. DijkstraEraImp era => Integer -> TxIn
neverSubmittedTxIn @era Integer
0
      Tx SubTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx SubTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingSubTx
        (TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
badReferenceInput])
        [DijkstraSubUtxoPredFailure era
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
DijkstraSubUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraSubUtxoPredFailure era
 -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> (NonEmptySet TxIn -> DijkstraSubUtxoPredFailure era)
-> NonEmptySet TxIn
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NonEmptySet TxIn -> DijkstraSubUtxoPredFailure era
SubBadInputsUTxO @era (NonEmptySet TxIn -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> NonEmptySet TxIn
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ TxIn -> NonEmptySet TxIn
forall a. a -> NonEmptySet a
NES.singleton TxIn
badReferenceInput]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"an input spent by an earlier sub-transaction fails only the check against the threaded UTxO" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (sharedTxIn, subTxs) <- ImpTestM era (TxIn, [Tx SubTx era])
forall era.
DijkstraEraImp era =>
ImpTestM era (TxIn, [Tx SubTx era])
subTxsSpendingOneInput
      submitFailingTx
        (mkTopTxWithSubTxs subTxs)
        [injectFailure . SubBadInputsUTxO @era $ NES.singleton sharedTxIn]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"an input in no UTxO fails both checks" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let badInput :: TxIn
badInput = forall era. DijkstraEraImp era => Integer -> TxIn
neverSubmittedTxIn @era Integer
0
      Tx SubTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx SubTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingSubTx
        (TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
badInput])
        [ DijkstraSubUtxoPredFailure era
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
DijkstraSubUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraSubUtxoPredFailure era
 -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> (NonEmptySet TxIn -> DijkstraSubUtxoPredFailure era)
-> NonEmptySet TxIn
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NonEmptySet TxIn -> DijkstraSubUtxoPredFailure era
SubBadInputsUTxO @era (NonEmptySet TxIn -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> NonEmptySet TxIn
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ TxIn -> NonEmptySet TxIn
forall a. a -> NonEmptySet a
NES.singleton TxIn
badInput
        , DijkstraSubUtxoPredFailure era
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
DijkstraSubUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraSubUtxoPredFailure era
 -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> (NonEmptySet TxIn -> DijkstraSubUtxoPredFailure era)
-> NonEmptySet TxIn
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NonEmptySet TxIn -> DijkstraSubUtxoPredFailure era
SubBadInputsUTxO @era (NonEmptySet TxIn -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> NonEmptySet TxIn
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ TxIn -> NonEmptySet TxIn
forall a. a -> NonEmptySet a
NES.singleton TxIn
badInput
        ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
      String
"the original UTxO check reports both bad inputs, the threaded check only the bad spend input"
      (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        let badInput :: TxIn
badInput = forall era. DijkstraEraImp era => Integer -> TxIn
neverSubmittedTxIn @era Integer
0
            badReferenceInput :: TxIn
badReferenceInput = forall era. DijkstraEraImp era => Integer -> TxIn
neverSubmittedTxIn @era Integer
1
        Tx SubTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx SubTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingSubTx
          ( TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
              TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
badInput]
                TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
badReferenceInput]
          )
          [ DijkstraSubUtxoPredFailure era
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
DijkstraSubUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraSubUtxoPredFailure era
 -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> (NonEmptySet TxIn -> DijkstraSubUtxoPredFailure era)
-> NonEmptySet TxIn
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NonEmptySet TxIn -> DijkstraSubUtxoPredFailure era
SubBadInputsUTxO @era (NonEmptySet TxIn -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> NonEmptySet TxIn
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ TxIn -> NonEmptySet TxIn
forall a. a -> NonEmptySet a
NES.singleton TxIn
badInput
          , DijkstraSubUtxoPredFailure era
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
DijkstraSubUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraSubUtxoPredFailure era
 -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> (NonEmptySet TxIn -> DijkstraSubUtxoPredFailure era)
-> NonEmptySet TxIn
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NonEmptySet TxIn -> DijkstraSubUtxoPredFailure era
SubBadInputsUTxO @era (NonEmptySet TxIn -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> NonEmptySet TxIn
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall a b. (a -> b) -> a -> b
$
              TxIn -> NonEmptySet TxIn
forall a. a -> NonEmptySet a
NES.singleton TxIn
badInput NonEmptySet TxIn -> NonEmptySet TxIn -> NonEmptySet TxIn
forall a. Semigroup a => a -> a -> a
<> TxIn -> NonEmptySet TxIn
forall a. a -> NonEmptySet a
NES.singleton TxIn
badReferenceInput
          ]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Inputs produced or spent within the batch" (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
"spending an output from an earlier sub-tx fails" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (producingSubTx, producedTxIn) <- ImpTestM era (Tx SubTx era, TxIn)
forall era.
(HasCallStack, DijkstraEraImp era) =>
ImpTestM era (Tx SubTx era, TxIn)
freshSubTxProducingOutput
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ producingSubTx
            , mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [producedTxIn]
            ]
        )
        [injectFailure . SubBadInputsUTxO @era $ NES.singleton producedTxIn]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"referencing an output from an earlier sub-tx fails" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (producingSubTx, producedTxIn) <- ImpTestM era (Tx SubTx era, TxIn)
forall era.
(HasCallStack, DijkstraEraImp era) =>
ImpTestM era (Tx SubTx era, TxIn)
freshSubTxProducingOutput
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ producingSubTx
            , mkBasicTx $ mkBasicTxBody & referenceInputsTxBodyL .~ [producedTxIn]
            ]
        )
        [injectFailure . SubBadInputsUTxO @era $ NES.singleton producedTxIn]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"same input in different sub-transactions" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (producingSubTx, producedTxIn) <- ImpTestM era (Tx SubTx era, TxIn)
forall era.
(HasCallStack, DijkstraEraImp era) =>
ImpTestM era (Tx SubTx era, TxIn)
freshSubTxProducingOutput
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [producedTxIn]
            , producingSubTx
            ]
        )
        [ injectFailure . SubBadInputsUTxO @era $ NES.singleton producedTxIn
        , injectFailure . SubBadInputsUTxO @era $ NES.singleton producedTxIn
        ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"referencing an out that another sub-tx spends is accepted" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      txIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      submitTx_ $
        mkTopTxWithSubTxs
          [ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]
          , mkBasicTx $ mkBasicTxBody & referenceInputsTxBodyL .~ [txIn]
          ]
      getUTxO >>= (`expectUTxOContent` [(txIn, isNothing)])

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubOutputBootAddrAttrsTooBig" (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 (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"an output to a bootstrap address whose attributes exceed the limit" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      bootAddr <- ImpM (LedgerSpec era) BootstrapAddress
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m BootstrapAddress
freshBootstrapAddressOversizedPayload
      let subTx :: Tx SubTx era
          subTx =
            TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
              TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut (BootstrapAddress -> Addr
AddrBootstrap BootstrapAddress
bootAddr) Value era
MaryValue
forall a. Monoid a => a
mempty]
      submitFailingTxM (mkTopTxWithSubTxs [subTx]) $ \Tx TopTx era
fixedUpTx -> do
        txOuts <- Tx TopTx era -> ImpM (LedgerSpec era) (NonEmpty (TxOut era))
forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (NonEmpty (TxOut era))
subTxOutputs Tx TopTx era
fixedUpTx
        pure [injectFailure $ SubOutputBootAddrAttrsTooBig @era txOuts]

    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"several such outputs, reported in their order in the body" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      firstBootAddr <- ImpM (LedgerSpec era) BootstrapAddress
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m BootstrapAddress
freshBootstrapAddressOversizedPayload
      secondBootAddr <- freshBootstrapAddressOversizedPayload
      let firstTxOut = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut (BootstrapAddress -> Addr
AddrBootstrap BootstrapAddress
firstBootAddr) Value era
forall a. Monoid a => a
mempty
          secondTxOut = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut (BootstrapAddress -> Addr
AddrBootstrap BootstrapAddress
secondBootAddr) Value era
forall a. Monoid a => a
mempty
          subTx :: Tx SubTx era
          subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
firstTxOut, Item (StrictSeq (TxOut era))
TxOut era
secondTxOut]
      submitFailingTxM (mkTopTxWithSubTxs [subTx]) $ \Tx TopTx era
fixedUpTx -> do
        txOuts <- Tx TopTx era -> ImpM (LedgerSpec era) (NonEmpty (TxOut era))
forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (NonEmpty (TxOut era))
subTxOutputs Tx TopTx era
fixedUpTx
        pure [injectFailure $ SubOutputBootAddrAttrsTooBig @era txOuts]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubBabbageOutputTooSmallUTxO" (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
"an output that holds less than the minimum coin" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      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
      txOut <- freshTxOutWithCoin $ Coin 1
      submitFailingSubTx
        (mkBasicTx $ mkBasicTxBody & outputsTxBodyL .~ [txOut])
        [injectFailure $ SubBabbageOutputTooSmallUTxO @era [(txOut, getMinCoinTxOut pp txOut)]]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"several such outputs, reported in their order in the body" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      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
      firstTxOut <- freshTxOutWithCoin $ Coin 1
      secondTxOut <- freshTxOutWithCoin $ Coin 2
      submitFailingSubTx
        (mkBasicTx $ mkBasicTxBody & outputsTxBodyL .~ [firstTxOut, secondTxOut])
        [ injectFailure $
            SubBabbageOutputTooSmallUTxO @era
              [ (firstTxOut, getMinCoinTxOut pp firstTxOut)
              , (secondTxOut, getMinCoinTxOut pp secondTxOut)
              ]
        ]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubWrongNetwork" (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
"an output to a mainnet address" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m Addr
freshMainnetKeyAddr_
      submitFailingSubTx
        (mkBasicTx $ mkBasicTxBody & outputsTxBodyL .~ [mkBasicTxOut addr mempty])
        [injectFailure . SubWrongNetwork @era Testnet $ NES.singleton addr]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"several outputs to mainnet addresses" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      firstAddr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m Addr
freshMainnetKeyAddr_
      secondAddr <- freshMainnetKeyAddr_
      submitFailingSubTx
        ( mkBasicTx $
            mkBasicTxBody
              & outputsTxBodyL .~ [mkBasicTxOut firstAddr mempty, mkBasicTxOut secondAddr mempty]
        )
        [ injectFailure . SubWrongNetwork @era Testnet $
            NES.singleton firstAddr <> NES.singleton secondAddr
        ]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubWrongNetworkInTxBody" (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
"a sub-transaction body with a mainnet network id" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$
      Tx SubTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx SubTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingSubTx
        (TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Network -> Identity (StrictMaybe Network))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe Network)
forall (l :: TxLevel). Lens' (TxBody l era) (StrictMaybe Network)
networkIdTxBodyL ((StrictMaybe Network -> Identity (StrictMaybe Network))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictMaybe Network -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Network -> StrictMaybe Network
forall a. a -> StrictMaybe a
SJust Network
Mainnet)
        [ DijkstraSubUtxoPredFailure era
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
DijkstraSubUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraSubUtxoPredFailure era
 -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> (Mismatch RelEQ Network -> DijkstraSubUtxoPredFailure era)
-> Mismatch RelEQ Network
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Mismatch RelEQ Network -> DijkstraSubUtxoPredFailure era
SubWrongNetworkInTxBody @era (Mismatch RelEQ Network
 -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> Mismatch RelEQ Network
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall a b. (a -> b) -> a -> b
$
            Mismatch {mismatchSupplied :: Network
mismatchSupplied = Network
Mainnet, mismatchExpected :: Network
mismatchExpected = Network
Testnet}
        ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a sub-transaction larger than maxTxSize is rejected only by the top level rule" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    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
    addr <- freshKeyAddr_
    let txOut = PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp (TxOut era -> TxOut era) -> TxOut 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
        subTx :: Tx SubTx era
        subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
SSeq.fromList (Int -> TxOut era -> [TxOut era]
forall a. Int -> a -> [a]
replicate Int
20 TxOut era
txOut)
        maxTxSize = Tx SubTx era
subTx Tx SubTx era -> Getting Word32 (Tx SubTx era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (Tx SubTx era) Word32
forall era (l :: TxLevel).
(EraTx era, HasCallStack) =>
SimpleGetter (Tx l era) Word32
SimpleGetter (Tx SubTx era) Word32
forall (l :: TxLevel).
HasCallStack =>
SimpleGetter (Tx l era) Word32
sizeTxF Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1
    modifyPParams $ ppMaxTxSizeL .~ maxTxSize
    submitFailingTxM (mkTopTxWithSubTxs [subTx]) $ \Tx TopTx era
fixedUpTx ->
      NonEmpty (EraRuleFailure "LEDGER" era)
-> ImpM (LedgerSpec era) (NonEmpty (EraRuleFailure "LEDGER" era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ DijkstraUtxoPredFailure era
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
DijkstraUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraUtxoPredFailure era
 -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> (Mismatch RelLTEQ Word32 -> DijkstraUtxoPredFailure era)
-> Mismatch RelLTEQ Word32
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Mismatch RelLTEQ Word32 -> DijkstraUtxoPredFailure era
MaxTxSizeUTxO @era (Mismatch RelLTEQ Word32
 -> Item (NonEmpty (EraRuleFailure "LEDGER" era)))
-> Mismatch RelLTEQ Word32
-> Item (NonEmpty (EraRuleFailure "LEDGER" era))
forall a b. (a -> b) -> a -> b
$
            Mismatch {mismatchSupplied :: Word32
mismatchSupplied = Tx TopTx era
fixedUpTx Tx TopTx era -> Getting Word32 (Tx TopTx era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (Tx TopTx era) Word32
forall era (l :: TxLevel).
(EraTx era, HasCallStack) =>
SimpleGetter (Tx l era) Word32
SimpleGetter (Tx TopTx era) Word32
forall (l :: TxLevel).
HasCallStack =>
SimpleGetter (Tx l era) Word32
sizeTxF, mismatchExpected :: Word32
mismatchExpected = Word32
maxTxSize}
        ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"one input listed as both a spend and a reference input is accepted, and consumed" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    txIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
    submitTx_ . mkTopTxWithSubTxs . pure . mkBasicTx $
      mkBasicTxBody
        & inputsTxBodyL .~ [txIn]
        & referenceInputsTxBodyL .~ [txIn]
    getUTxO >>= (`expectUTxOContent` [(txIn, isNothing)])

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Composite tests" (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 (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt
      String
"seven failures of one sub-transaction, in the reverse of the order the rule checks them"
      (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        ImpM (LedgerSpec era) ()
forall era. DijkstraEraImp era => ImpTestM era ()
restrictMaxValSizeToAdaOnly
        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
        currentSlot <- gets (^. impCurSlotNoG)
        (multiAsset, assetTxOut) <- freshAssetOutput
        bootAddr <- freshBootstrapAddressOversizedPayload
        mainnetAddr <- freshMainnetKeyAddr_
        let badReferenceInput = forall era. DijkstraEraImp era => Integer -> TxIn
neverSubmittedTxIn @era Integer
0
            validityInterval = StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (SlotNo
currentSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)) StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
            tooBigTxOut = PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp TxOut era
assetTxOut
            bootstrapAttrsTxOut = PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp (TxOut era -> TxOut era) -> TxOut 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 (BootstrapAddress -> Addr
AddrBootstrap BootstrapAddress
bootAddr) Value era
forall a. Monoid a => a
mempty
            tooSmallTxOut = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
mainnetAddr (Value era -> TxOut era)
-> (Coin -> Value era) -> Coin -> TxOut era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> TxOut era) -> Coin -> TxOut era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1
        submitFailingSubTx
          ( mkBasicTx $
              mkBasicTxBody
                & vldtTxBodyL .~ validityInterval
                & mintTxBodyL .~ multiAsset
                & referenceInputsTxBodyL .~ [badReferenceInput]
                & outputsTxBodyL .~ [tooBigTxOut, bootstrapAttrsTxOut, tooSmallTxOut]
                & networkIdTxBodyL .~ SJust Mainnet
          )
          [ injectFailure . SubWrongNetworkInTxBody @era $
              Mismatch {mismatchSupplied = Mainnet, mismatchExpected = Testnet}
          , injectFailure . SubWrongNetwork @era Testnet $ NES.singleton mainnetAddr
          , injectFailure $
              SubBabbageOutputTooSmallUTxO @era
                [(tooSmallTxOut, getMinCoinTxOut pp tooSmallTxOut)]
          , injectFailure $ SubOutputBootAddrAttrsTooBig @era [bootstrapAttrsTxOut]
          , injectFailure . SubBadInputsUTxO @era $ NES.singleton badReferenceInput
          , injectFailure $ SubOutputTooBigUTxO @era [outputTooBigEntry pp tooBigTxOut]
          , injectFailure $ SubOutsideValidityIntervalUTxO @era validityInterval currentSlot
          ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"failures of several sub-transactions, in sub-transaction order" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      currentSlot <- (ImpTestState era -> SlotNo) -> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (ImpTestState era
-> Getting SlotNo (ImpTestState era) SlotNo -> SlotNo
forall s a. s -> Getting a s a -> a
^. Getting SlotNo (ImpTestState era) SlotNo
forall era r. Getting r (ImpTestState era) SlotNo
impCurSlotNoG)
      let validityInterval = StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (SlotNo
currentSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)) StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
          wrongNetworkSubTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Network -> Identity (StrictMaybe Network))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe Network)
forall (l :: TxLevel). Lens' (TxBody l era) (StrictMaybe Network)
networkIdTxBodyL ((StrictMaybe Network -> Identity (StrictMaybe Network))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictMaybe Network -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Network -> StrictMaybe Network
forall a. a -> StrictMaybe a
SJust Network
Mainnet
          outsideValiditySubTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (ValidityInterval -> Identity ValidityInterval)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l era) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> ValidityInterval -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ValidityInterval
validityInterval
      submitFailingTx
        (mkTopTxWithSubTxs [wrongNetworkSubTx, outsideValiditySubTx])
        [ injectFailure . SubWrongNetworkInTxBody @era $
            Mismatch {mismatchSupplied = Mainnet, mismatchExpected = Testnet}
        , injectFailure $ SubOutsideValidityIntervalUTxO @era validityInterval currentSlot
        ]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Accepted at the boundary" (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
"a validity interval that starts at the current slot and ends at the next one" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      currentSlot <- (ImpTestState era -> SlotNo) -> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (ImpTestState era
-> Getting SlotNo (ImpTestState era) SlotNo -> SlotNo
forall s a. s -> Getting a s a -> a
^. Getting SlotNo (ImpTestState era) SlotNo
forall era r. Getting r (ImpTestState era) SlotNo
impCurSlotNoG)
      submitTx_ . mkTopTxWithSubTxs . pure . mkBasicTx $
        mkBasicTxBody
          & vldtTxBodyL .~ ValidityInterval (SJust currentSlot) (SJust (currentSlot + 1))

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"an output that holds exactly the minimum coin" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      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
      addr <- freshKeyAddr_
      submitTx_ . mkTopTxWithSubTxs . pure . mkBasicTx $
        mkBasicTxBody & outputsTxBodyL .~ [setMinCoinTxOut pp $ mkBasicTxOut addr mempty]

    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"an output to a bootstrap address whose payload is the largest allowed size" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      bootAddr <- Maybe Int -> ImpM (LedgerSpec era) BootstrapAddress
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
Maybe Int -> m BootstrapAddress
freshBootstrapAddressWithPayloadSize (Maybe Int -> ImpM (LedgerSpec era) BootstrapAddress)
-> Maybe Int -> ImpM (LedgerSpec era) BootstrapAddress
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
largestBootstrapAddressAttrsSize
      submitTx_ . mkTopTxWithSubTxs . pure . mkBasicTx $
        mkBasicTxBody & outputsTxBodyL .~ [mkBasicTxOut (AddrBootstrap bootAddr) mempty]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"A phase-2 invalid top level transaction" (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
"still rejects a sub-transaction with the wrong network id in its body" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let subTx :: Tx SubTx era
          subTx :: Tx SubTx era
subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Network -> Identity (StrictMaybe Network))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe Network)
forall (l :: TxLevel). Lens' (TxBody l era) (StrictMaybe Network)
networkIdTxBodyL ((StrictMaybe Network -> Identity (StrictMaybe Network))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictMaybe Network -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Network -> StrictMaybe Network
forall a. a -> StrictMaybe a
SJust Network
Mainnet
      topTx <- [Tx SubTx era] -> ImpTestM era (Tx TopTx era)
forall era.
(HasCallStack, DijkstraEraImp era) =>
[Tx SubTx era] -> ImpTestM era (Tx TopTx era)
phase2InvalidTxWithSubTxs [Item [Tx SubTx era]
Tx SubTx era
subTx]
      withNoFixup $
        submitFailingTx
          topTx
          [ injectFailure . SubWrongNetworkInTxBody @era $
              Mismatch {mismatchSupplied = Mainnet, mismatchExpected = Testnet}
          ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not check the threaded UTxO, so two sub-transactions may name one input" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (sharedTxIn, subTxs) <- ImpTestM era (TxIn, [Tx SubTx era])
forall era.
DijkstraEraImp era =>
ImpTestM era (TxIn, [Tx SubTx era])
subTxsSpendingOneInput
      topTx <- phase2InvalidTxWithSubTxs subTxs
      withNoFixup $ submitTx_ topTx
      void $ impGetUTxO sharedTxIn

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"spending an output from an earlier sub-tx fails twice" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (producingSubTx, producedTxIn) <- ImpTestM era (Tx SubTx era, TxIn)
forall era.
(HasCallStack, DijkstraEraImp era) =>
ImpTestM era (Tx SubTx era, TxIn)
freshSubTxProducingOutput
      topTx <-
        phase2InvalidTxWithSubTxs
          [ producingSubTx
          , mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [producedTxIn]
          ]
      withNoFixup $
        submitFailingTx
          topTx
          [ injectFailure . SubBadInputsUTxO @era $ NES.singleton producedTxIn
          , injectFailure . SubBadInputsUTxO @era $ NES.singleton producedTxIn
          ]

freshSubTxProducingOutput ::
  (HasCallStack, DijkstraEraImp era) =>
  ImpTestM era (Tx SubTx era, TxIn)
freshSubTxProducingOutput :: forall era.
(HasCallStack, DijkstraEraImp era) =>
ImpTestM era (Tx SubTx era, TxIn)
freshSubTxProducingOutput = do
  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
  spentTxIn <- freshFundedTxIn
  producedAddr <- freshKeyAddr_
  let subTx =
        TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
          TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
            TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
spentTxIn]
            TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp (TxOut era -> TxOut era) -> TxOut 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
producedAddr Value era
forall a. Monoid a => a
mempty]
  pure (subTx, mkTxInPartial (txIdTx subTx) 0)

subTxOutputs :: DijkstraEraImp era => Tx TopTx era -> ImpTestM era (NonEmpty (TxOut era))
subTxOutputs :: forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (NonEmpty (TxOut era))
subTxOutputs Tx TopTx era
topTx =
  Maybe (NonEmpty (TxOut era))
-> ImpM (LedgerSpec era) (NonEmpty (TxOut era))
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust (Maybe (NonEmpty (TxOut era))
 -> ImpM (LedgerSpec era) (NonEmpty (TxOut era)))
-> (OMap TxId (Tx SubTx era) -> Maybe (NonEmpty (TxOut era)))
-> OMap TxId (Tx SubTx era)
-> ImpM (LedgerSpec era) (NonEmpty (TxOut era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOut era] -> Maybe (NonEmpty (TxOut era))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([TxOut era] -> Maybe (NonEmpty (TxOut era)))
-> (OMap TxId (Tx SubTx era) -> [TxOut era])
-> OMap TxId (Tx SubTx era)
-> Maybe (NonEmpty (TxOut era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx SubTx era -> [TxOut era]) -> [Tx SubTx era] -> [TxOut era]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (StrictSeq (TxOut era) -> [TxOut era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (TxOut era) -> [TxOut era])
-> (Tx SubTx era -> StrictSeq (TxOut era))
-> Tx SubTx era
-> [TxOut era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx SubTx era
-> Getting
     (StrictSeq (TxOut era)) (Tx SubTx era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. (TxBody SubTx era
 -> Const (StrictSeq (TxOut era)) (TxBody SubTx era))
-> Tx SubTx era -> Const (StrictSeq (TxOut era)) (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era
  -> Const (StrictSeq (TxOut era)) (TxBody SubTx era))
 -> Tx SubTx era -> Const (StrictSeq (TxOut era)) (Tx SubTx era))
-> ((StrictSeq (TxOut era)
     -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
    -> TxBody SubTx era
    -> Const (StrictSeq (TxOut era)) (TxBody SubTx era))
-> Getting
     (StrictSeq (TxOut era)) (Tx SubTx era) (StrictSeq (TxOut era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era)
 -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
-> TxBody SubTx era
-> Const (StrictSeq (TxOut era)) (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL)) ([Tx SubTx era] -> [TxOut era])
-> (OMap TxId (Tx SubTx era) -> [Tx SubTx era])
-> OMap TxId (Tx SubTx era)
-> [TxOut era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OMap TxId (Tx SubTx era) -> [Tx SubTx era]
forall k v. Ord k => OMap k v -> [v]
OMap.elems (OMap TxId (Tx SubTx era)
 -> ImpM (LedgerSpec era) (NonEmpty (TxOut era)))
-> OMap TxId (Tx SubTx era)
-> ImpM (LedgerSpec era) (NonEmpty (TxOut era))
forall a b. (a -> b) -> a -> b
$
    Tx TopTx era
topTx Tx TopTx era
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
-> OMap TxId (Tx SubTx era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era
  -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era
    -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era)
 -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era
-> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL

freshAssetOutput :: DijkstraEraImp era => ImpTestM era (MultiAsset, TxOut era)
freshAssetOutput :: forall era.
DijkstraEraImp era =>
ImpTestM era (MultiAsset, TxOut era)
freshAssetOutput = do
  policyId <- ScriptHash -> PolicyID
PolicyID (ScriptHash -> PolicyID)
-> ImpM (LedgerSpec era) ScriptHash
-> ImpM (LedgerSpec era) PolicyID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NativeScript era -> ImpM (LedgerSpec era) ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpM (LedgerSpec era) ScriptHash)
-> (KeyHash Witness -> NativeScript era)
-> KeyHash Witness
-> ImpM (LedgerSpec era) ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature (KeyHash Witness -> ImpM (LedgerSpec era) ScriptHash)
-> ImpM (LedgerSpec era) (KeyHash Witness)
-> ImpM (LedgerSpec era) ScriptHash
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (KeyHash Witness)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash)
  assetName <- arbitrary @AssetName
  addr <- freshKeyAddr_
  let multiAsset = [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList [(PolicyID
policyId, AssetName
assetName, Integer
1)]
  pure (multiAsset, mkBasicTxOut addr $ MaryValue mempty multiAsset)

subTxsSpendingOneInput :: DijkstraEraImp era => ImpTestM era (TxIn, [Tx SubTx era])
subTxsSpendingOneInput :: forall era.
DijkstraEraImp era =>
ImpTestM era (TxIn, [Tx SubTx era])
subTxsSpendingOneInput = do
  sharedTxIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
  otherTxIn <- freshFundedTxIn
  pure
    ( sharedTxIn
    ,
      [ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [sharedTxIn]
      , mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [sharedTxIn, otherTxIn]
      ]
    )

neverSubmittedTxIn :: forall era. DijkstraEraImp era => Integer -> TxIn
neverSubmittedTxIn :: forall era. DijkstraEraImp era => Integer -> TxIn
neverSubmittedTxIn = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial (TxId -> Integer -> TxIn)
-> (Tx TopTx era -> TxId) -> Tx TopTx era -> Integer -> TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx TopTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx (Tx TopTx era -> Integer -> TxIn)
-> Tx TopTx era -> Integer -> TxIn
forall a b. (a -> b) -> a -> b
$ (TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody :: Tx TopTx era)

restrictMaxValSizeToAdaOnly :: forall era. DijkstraEraImp era => ImpTestM era ()
restrictMaxValSizeToAdaOnly :: forall era. DijkstraEraImp era => ImpTestM era ()
restrictMaxValSizeToAdaOnly = do
  protVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  let largestAdaOnlyValue = Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> (Word64 -> Coin) -> Word64 -> Value era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin (Integer -> Coin) -> (Word64 -> Integer) -> Word64 -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Value era) -> Word64 -> Value era
forall a b. (a -> b) -> a -> b
$ (Word64
forall a. Bounded a => a
maxBound :: Word64) :: Value era
      largestAdaOnlyValueSize = ProtVer -> Value era -> Int
forall value. EncCBOR value => ProtVer -> value -> Int
serializedValueSize ProtVer
protVer Value era
largestAdaOnlyValue
  modifyPParams $ ppMaxValSizeL .~ fromIntegral largestAdaOnlyValueSize

serializedValueSize :: EncCBOR value => ProtVer -> value -> Int
serializedValueSize :: forall value. EncCBOR value => ProtVer -> value -> Int
serializedValueSize ProtVer
protVer = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> (value -> Int64) -> value -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BSL.length (ByteString -> Int64) -> (value -> ByteString) -> value -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> value -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize (ProtVer -> Version
pvMajor ProtVer
protVer)

outputTooBigEntry :: DijkstraEraImp era => PParams era -> TxOut era -> (Int, Int, TxOut era)
outputTooBigEntry :: forall era.
DijkstraEraImp era =>
PParams era -> TxOut era -> (Int, Int, TxOut era)
outputTooBigEntry PParams era
pp TxOut era
txOut =
  ( ProtVer -> Value era -> Int
forall value. EncCBOR value => ProtVer -> value -> Int
serializedValueSize (PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL) (Value era -> Int) -> Value era -> Int
forall a b. (a -> b) -> a -> b
$ TxOut era
txOut TxOut era
-> Getting (Value era) (TxOut era) (Value era) -> Value era
forall s a. s -> Getting a s a -> a
^. Getting (Value era) (TxOut era) (Value era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL
  , Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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. AlonzoEraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
ppMaxValSizeL
  , TxOut era
txOut
  )

phase2InvalidTxWithSubTxs ::
  (HasCallStack, DijkstraEraImp era) =>
  [Tx SubTx era] ->
  ImpTestM era (Tx TopTx era)
phase2InvalidTxWithSubTxs :: forall era.
(HasCallStack, DijkstraEraImp era) =>
[Tx SubTx era] -> ImpTestM era (Tx TopTx era)
phase2InvalidTxWithSubTxs [Tx SubTx era]
subTxs = do
  failingScriptTxIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpTestM era TxIn)
-> (Plutus 'PlutusV3 -> ScriptHash)
-> Plutus 'PlutusV3
-> ImpTestM era TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV3 -> ImpTestM era TxIn)
-> Plutus 'PlutusV3 -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage 'PlutusV3
SPlutusV3
  fixedUpTx <- fixupTx $ mkTopTxWithSubTxs subTxs & bodyTxL . inputsTxBodyL .~ [failingScriptTxIn]
  pure $ fixedUpTx & isPhase2ValidTxL .~ Phase2Invalid