{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.Chain.Direct.WalletSpec where

import Hydra.Cardano.Api.Gen (genTxIn)
import Hydra.Prelude
import Test.Hydra.Prelude

import Cardano.Api qualified as CApi
import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Alonzo.Scripts (AsIx (..))
import Cardano.Ledger.Alonzo.Tx (ScriptIntegrity (..), hashScriptIntegrity)
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..))
import Cardano.Ledger.Api (AlonzoEraTxWits (rdmrsTxWitsL), ConwayEra, EraTx (getMinFeeTx, witsTxL), EraTxBody (feeTxBodyL, inputsTxBodyL), PParams, TxBody, bodyTxL, coinTxOutL, datsTxWitsL, hashScript, outputsTxBodyL, referenceInputsTxBodyL, scriptIntegrityHashTxBodyL, scriptTxWitsL, pattern SpendingPurpose)
import Cardano.Ledger.Api.PParams (getLanguageView)
import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core (Tx, TxLevel (..), Value)
import Cardano.Ledger.Hashes (hashAnnotated)
import Cardano.Ledger.Plutus (Data, ExUnits (..))
import Cardano.Ledger.Plutus.Language (Language (PlutusV3))
import Cardano.Ledger.Shelley.API qualified as Ledger
import Cardano.Ledger.Slot (EpochInfo)
import Cardano.Ledger.Val (Val (..), invert)
import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Lens (view, (.~), (<>~), (^.))
import Control.Tracer (nullTracer)
import Data.Map.Strict qualified as Map
import Data.Sequence.Strict qualified as StrictSeq
import Data.Set qualified as Set
import Hydra.Cardano.Api (
  CardanoSigningKey (..),
  LedgerEra,
  PaymentCredential (PaymentCredentialByKey),
  PaymentKey,
  VerificationKey,
  fromLedgerTx,
  fromLedgerTxOut,
  selectLovelace,
  shelleyBasedEra,
  toLedgerTxIn,
  txOutValue,
  verificationKeyHash,
 )
import Hydra.Cardano.Api qualified as Api
import Hydra.Cardano.Api.Prelude (fromShelleyPaymentCredential)
import Hydra.Cardano.Api.Pretty (renderTx)
import Hydra.Chain.CardanoClient (QueryPoint (..))
import Hydra.Chain.Direct.Wallet (
  Address,
  ChainQuery,
  ErrCoverFee (..),
  TinyWallet (..),
  TxIn,
  TxOut,
  WalletInfoOnChain (..),
  applyTxs,
  coverFee_,
  findLargestUTxO,
  newTinyWallet,
 )
import Hydra.Contract.Dummy (dummyValidatorScript)
import Hydra.Tx.Secret (mkSecret)
import Test.Hydra.Tx.Fixture qualified as Fixture
import Test.Hydra.Tx.Gen (genKeyPair, genOneUTxOFor, genTxOut)
import Test.QuickCheck (
  Discard (..),
  Property,
  checkCoverage,
  conjoin,
  counterexample,
  cover,
  forAll,
  forAllBlind,
  frequency,
  generate,
  getSize,
  property,
  resize,
  scale,
  suchThat,
  vectorOf,
  (.&&.),
  (===),
 )
import Prelude qualified

spec :: Spec
spec :: Spec
spec = Spec -> Spec
forall a. SpecWith a -> SpecWith a
parallel (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"genTxsSpending / genUTxO" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"are well-suited for testing" Property
prop_wellSuitedGenerators

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"applyTxs" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"only reduces the UTXO set when no address is ours" Property
prop_reducesWhenNotOurs
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Seen inputs are consumed and not in the resulting UTXO" Property
prop_seenInputsAreConsumed

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"coverFee" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"sets min utxo values" Property
prop_setsMinUTxOValue
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"balances transaction with fees" Property
prop_balanceTransaction
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"prefers largest utxo" Property
prop_picksLargestUTxOToPayTheFees
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"reports ErrMissingScript when script witness is missing" Property
prop_detectsMissingScript
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not set script integrity hash when no scripts are executed" Property
prop_noScriptIntegrityHashWithoutExecution
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"unrelated reference scripts do not affect the script integrity hash" Property
prop_unrelatedRefScriptDoesNotAffectIntegrityHash

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"newTinyWallet" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"initialises wallet by querying UTxO" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair (((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
 -> Property)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
-> Property
forall a b. (a -> b) -> a -> b
$ \(VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) -> do
        TinyWallet IO
wallet <- Tracer IO TinyWalletLog
-> NetworkId
-> (VerificationKey PaymentKey, Secret CardanoSigningKey)
-> ChainQuery IO
-> IO (EpochInfo (Either Text))
-> IO (PParams ConwayEra)
-> IO (TinyWallet IO)
newTinyWallet Tracer IO TinyWalletLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer NetworkId
Fixture.testNetworkId (VerificationKey PaymentKey
vk, CardanoSigningKey -> Secret CardanoSigningKey
forall a. a -> Secret a
mkSecret (SigningKey PaymentKey -> CardanoSigningKey
CardanoSigningKey SigningKey PaymentKey
sk)) (VerificationKey PaymentKey -> ChainQuery IO
mockChainQuery VerificationKey PaymentKey
vk) IO (EpochInfo (Either Text))
mockQueryEpochInfo IO (PParams ConwayEra)
mockQueryPParams
        Map TxIn (BabbageTxOut ConwayEra)
utxo <- STM IO (Map TxIn (BabbageTxOut ConwayEra))
-> IO (Map TxIn (BabbageTxOut ConwayEra))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TinyWallet IO -> STM IO (Map TxIn TxOut)
forall (m :: * -> *). TinyWallet m -> STM m (Map TxIn TxOut)
getUTxO TinyWallet IO
wallet)
        Map TxIn (BabbageTxOut ConwayEra)
utxo Map TxIn (BabbageTxOut ConwayEra)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \Map TxIn (BabbageTxOut ConwayEra)
m -> Map TxIn (BabbageTxOut ConwayEra) -> Int
forall k a. Map k a -> Int
Map.size Map TxIn (BabbageTxOut ConwayEra)
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"re-queries UTxO from the tip, even on reset" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair (((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
 -> Property)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
-> Property
forall a b. (a -> b) -> a -> b
$ \(VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) -> do
        (ChainQuery IO
queryFn, QueryPoint -> IO ()
assertQueryPoint) <- VerificationKey PaymentKey
-> IO (ChainQuery IO, QueryPoint -> IO ())
setupQuery VerificationKey PaymentKey
vk
        TinyWallet IO
wallet <- Tracer IO TinyWalletLog
-> NetworkId
-> (VerificationKey PaymentKey, Secret CardanoSigningKey)
-> ChainQuery IO
-> IO (EpochInfo (Either Text))
-> IO (PParams ConwayEra)
-> IO (TinyWallet IO)
newTinyWallet Tracer IO TinyWalletLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer NetworkId
Fixture.testNetworkId (VerificationKey PaymentKey
vk, CardanoSigningKey -> Secret CardanoSigningKey
forall a. a -> Secret a
mkSecret (SigningKey PaymentKey -> CardanoSigningKey
CardanoSigningKey SigningKey PaymentKey
sk)) ChainQuery IO
queryFn IO (EpochInfo (Either Text))
mockQueryEpochInfo IO (PParams ConwayEra)
mockQueryPParams
        QueryPoint -> IO ()
assertQueryPoint QueryPoint
QueryTip
        TinyWallet IO -> IO ()
forall (m :: * -> *). TinyWallet m -> m ()
reset TinyWallet IO
wallet
        QueryPoint -> IO ()
assertQueryPoint QueryPoint
QueryTip

setupQuery ::
  VerificationKey PaymentKey ->
  IO (ChainQuery IO, QueryPoint -> Expectation)
setupQuery :: VerificationKey PaymentKey
-> IO (ChainQuery IO, QueryPoint -> IO ())
setupQuery VerificationKey PaymentKey
vk = do
  MVar QueryPoint
queryPointMVar <- IO (MVar QueryPoint)
forall a. IO (MVar a)
newEmptyMVar
  (ChainQuery IO, QueryPoint -> IO ())
-> IO (ChainQuery IO, QueryPoint -> IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MVar QueryPoint -> ChainQuery IO
queryFn MVar QueryPoint
queryPointMVar, MVar QueryPoint -> QueryPoint -> IO ()
assertQueryPoint MVar QueryPoint
queryPointMVar)
 where
  queryFn :: MVar QueryPoint -> ChainQuery IO
queryFn MVar QueryPoint
queryPointMVar QueryPoint
point Address ShelleyAddr
_addr = do
    MVar QueryPoint -> QueryPoint -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar QueryPoint
queryPointMVar QueryPoint
point
    Map TxIn (TxOut ConwayEra)
walletUTxO <- UTxO ConwayEra -> Map TxIn (TxOut ConwayEra)
forall era. UTxO era -> Map TxIn (TxOut era)
Ledger.unUTxO (UTxO ConwayEra -> Map TxIn (TxOut ConwayEra))
-> (UTxO Era -> UTxO ConwayEra)
-> UTxO Era
-> Map TxIn (TxOut ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra Era -> UTxO Era -> UTxO LedgerEra
forall era.
HasCallStack =>
ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
UTxO.toShelleyUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (UTxO Era -> Map TxIn (TxOut ConwayEra))
-> IO (UTxO Era) -> IO (Map TxIn (TxOut ConwayEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (UTxO Era) -> IO (UTxO Era)
forall a. Gen a -> IO a
generate (VerificationKey PaymentKey -> Gen (UTxO Era)
genOneUTxOFor VerificationKey PaymentKey
vk)
    ChainPoint
tip <- Gen ChainPoint -> IO ChainPoint
forall a. Gen a -> IO a
generate Gen ChainPoint
forall a. Arbitrary a => Gen a
arbitrary
    WalletInfoOnChain -> IO WalletInfoOnChain
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalletInfoOnChain -> IO WalletInfoOnChain)
-> WalletInfoOnChain -> IO WalletInfoOnChain
forall a b. (a -> b) -> a -> b
$
      WalletInfoOnChain
        { Map TxIn TxOut
Map TxIn (TxOut ConwayEra)
walletUTxO :: Map TxIn (TxOut ConwayEra)
$sel:walletUTxO:WalletInfoOnChain :: Map TxIn TxOut
walletUTxO
        , $sel:systemStart:WalletInfoOnChain :: SystemStart
systemStart = SystemStart
Fixture.systemStart
        , ChainPoint
tip :: ChainPoint
$sel:tip:WalletInfoOnChain :: ChainPoint
tip
        }

  assertQueryPoint :: MVar QueryPoint -> QueryPoint -> Expectation
  assertQueryPoint :: MVar QueryPoint -> QueryPoint -> IO ()
assertQueryPoint MVar QueryPoint
queryPointMVar QueryPoint
point =
    MVar QueryPoint -> IO QueryPoint
forall a. MVar a -> IO a
takeMVar MVar QueryPoint
queryPointMVar IO QueryPoint -> QueryPoint -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` QueryPoint
point

mockChainQuery :: VerificationKey PaymentKey -> ChainQuery IO
mockChainQuery :: VerificationKey PaymentKey -> ChainQuery IO
mockChainQuery VerificationKey PaymentKey
vk QueryPoint
_point Address ShelleyAddr
addr = do
  let Api.ShelleyAddress Network
_ Credential Payment
cred StakeReference
_ = Address ShelleyAddr
addr
  Credential Payment -> PaymentCredential
fromShelleyPaymentCredential Credential Payment
cred PaymentCredential -> PaymentCredential -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Hash PaymentKey -> PaymentCredential
PaymentCredentialByKey (VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk)
  Map TxIn (TxOut ConwayEra)
walletUTxO <- UTxO ConwayEra -> Map TxIn (TxOut ConwayEra)
forall era. UTxO era -> Map TxIn (TxOut era)
Ledger.unUTxO (UTxO ConwayEra -> Map TxIn (TxOut ConwayEra))
-> (UTxO Era -> UTxO ConwayEra)
-> UTxO Era
-> Map TxIn (TxOut ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra Era -> UTxO Era -> UTxO LedgerEra
forall era.
HasCallStack =>
ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
UTxO.toShelleyUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (UTxO Era -> Map TxIn (TxOut ConwayEra))
-> IO (UTxO Era) -> IO (Map TxIn (TxOut ConwayEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (UTxO Era) -> IO (UTxO Era)
forall a. Gen a -> IO a
generate (VerificationKey PaymentKey -> Gen (UTxO Era)
genOneUTxOFor VerificationKey PaymentKey
vk)
  ChainPoint
tip <- Gen ChainPoint -> IO ChainPoint
forall a. Gen a -> IO a
generate Gen ChainPoint
forall a. Arbitrary a => Gen a
arbitrary
  WalletInfoOnChain -> IO WalletInfoOnChain
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalletInfoOnChain -> IO WalletInfoOnChain)
-> WalletInfoOnChain -> IO WalletInfoOnChain
forall a b. (a -> b) -> a -> b
$
    WalletInfoOnChain
      { Map TxIn TxOut
Map TxIn (TxOut ConwayEra)
$sel:walletUTxO:WalletInfoOnChain :: Map TxIn TxOut
walletUTxO :: Map TxIn (TxOut ConwayEra)
walletUTxO
      , $sel:systemStart:WalletInfoOnChain :: SystemStart
systemStart = SystemStart
Fixture.systemStart
      , ChainPoint
$sel:tip:WalletInfoOnChain :: ChainPoint
tip :: ChainPoint
tip
      }

mockQueryEpochInfo :: IO (EpochInfo (Either Text))
mockQueryEpochInfo :: IO (EpochInfo (Either Text))
mockQueryEpochInfo = EpochInfo (Either Text) -> IO (EpochInfo (Either Text))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo

mockQueryPParams :: IO (PParams ConwayEra)
mockQueryPParams :: IO (PParams ConwayEra)
mockQueryPParams = PParams ConwayEra -> IO (PParams ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PParams LedgerEra
PParams ConwayEra
Fixture.pparams

--
-- Generators
--

prop_wellSuitedGenerators ::
  Property
prop_wellSuitedGenerators :: Property
prop_wellSuitedGenerators =
  Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
utxo ->
    Gen [Tx TopTx ConwayEra]
-> ([Tx TopTx ConwayEra] -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Map TxIn TxOut -> Gen [Tx TopTx LedgerEra]
genTxsSpending Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo) (([Tx TopTx ConwayEra] -> Property) -> Property)
-> ([Tx TopTx ConwayEra] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[Tx TopTx ConwayEra]
txs ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property ([Tx TopTx LedgerEra] -> Bool
smallTxSets [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
0.3 (Map TxIn (BabbageTxOut ConwayEra) -> [Tx TopTx ConwayEra] -> Bool
noneIsOurs Map TxIn (BabbageTxOut ConwayEra)
utxo [Tx TopTx ConwayEra]
txs) String
"has no tx that are ours"
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
0.2 (Map TxIn (BabbageTxOut ConwayEra) -> [Tx TopTx ConwayEra] -> Bool
someAreDependent Map TxIn (BabbageTxOut ConwayEra)
utxo [Tx TopTx ConwayEra]
txs) String
"has dependent txs"
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"All TxIns: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show (Set TxIn -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set TxIn -> Int) -> Set TxIn -> Int
forall a b. (a -> b) -> a -> b
$ [Tx TopTx LedgerEra] -> Set TxIn
allTxIns [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"All TxOuts: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([TxOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxOut] -> Int) -> [TxOut] -> Int
forall a b. (a -> b) -> a -> b
$ [Tx TopTx LedgerEra] -> [TxOut]
allTxOuts [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Our TxIns: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxIn] -> Int) -> [TxIn] -> Int
forall a b. (a -> b) -> a -> b
$ Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxIn]
ourDirectInputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Our TxOuts: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([TxOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxOut] -> Int) -> [TxOut] -> Int
forall a b. (a -> b) -> a -> b
$ Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxOut]
ourOutputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs))
 where
  smallTxSets :: [Tx TopTx LedgerEra] -> Bool
  smallTxSets :: [Tx TopTx LedgerEra] -> Bool
smallTxSets [Tx TopTx LedgerEra]
txs =
    [Tx TopTx ConwayEra] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
10

  noneIsOurs :: Map TxIn (BabbageTxOut ConwayEra) -> [Tx TopTx ConwayEra] -> Bool
noneIsOurs Map TxIn (BabbageTxOut ConwayEra)
utxo [Tx TopTx ConwayEra]
txs =
    [TxIn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxIn]
ourDirectInputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs) Bool -> Bool -> Bool
&& [BabbageTxOut ConwayEra] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxOut]
ourOutputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs)

  someAreDependent :: Map TxIn (BabbageTxOut ConwayEra) -> [Tx TopTx ConwayEra] -> Bool
someAreDependent Map TxIn (BabbageTxOut ConwayEra)
utxo [Tx TopTx ConwayEra]
txs =
    [TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxIn]
ourDirectInputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [BabbageTxOut ConwayEra] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxOut]
ourOutputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs)

--
-- applyTxs
--

prop_reducesWhenNotOurs :: Property
prop_reducesWhenNotOurs :: Property
prop_reducesWhenNotOurs =
  Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
utxo ->
    Gen [Tx TopTx ConwayEra]
-> ([Tx TopTx ConwayEra] -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Map TxIn TxOut -> Gen [Tx TopTx LedgerEra]
genTxsSpending Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo) (([Tx TopTx ConwayEra] -> Property) -> Property)
-> ([Tx TopTx ConwayEra] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[Tx TopTx ConwayEra]
txs ->
      let utxo' :: Map TxIn TxOut
utxo' = [Tx] -> (Address -> Bool) -> Map TxIn TxOut -> Map TxIn TxOut
applyTxs (Tx TopTx LedgerEra -> Tx
Tx TopTx ConwayEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx TopTx ConwayEra -> Tx) -> [Tx TopTx ConwayEra] -> [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx TopTx ConwayEra]
txs) (Bool -> Address -> Bool
forall a b. a -> b -> a
const Bool
False) Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo
       in (Map TxIn (BabbageTxOut ConwayEra) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Map TxIn (BabbageTxOut ConwayEra) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut ConwayEra)
utxo)
            Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"New UTXO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map TxIn (BabbageTxOut ConwayEra) -> String
forall b a. (Show a, IsString b) => a -> b
show Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo')
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"UTXO size:     " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show (Map TxIn (BabbageTxOut ConwayEra) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut ConwayEra)
utxo))
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"New UTXO size: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show (Map TxIn (BabbageTxOut ConwayEra) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo'))

prop_seenInputsAreConsumed :: Property
prop_seenInputsAreConsumed :: Property
prop_seenInputsAreConsumed =
  Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
utxo ->
    Gen [Tx TopTx ConwayEra]
-> ([Tx TopTx ConwayEra] -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Map TxIn TxOut -> Gen [Tx TopTx LedgerEra]
genTxsSpending Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo) (([Tx TopTx ConwayEra] -> Property) -> Property)
-> ([Tx TopTx ConwayEra] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[Tx TopTx ConwayEra]
txs ->
      let utxo' :: Map TxIn TxOut
utxo' = [Tx] -> (Address -> Bool) -> Map TxIn TxOut -> Map TxIn TxOut
applyTxs (Tx TopTx LedgerEra -> Tx
Tx TopTx ConwayEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx TopTx ConwayEra -> Tx) -> [Tx TopTx ConwayEra] -> [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx TopTx ConwayEra]
txs) (Map TxIn TxOut -> Address -> Bool
isOurs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo) Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo
          seenInputs :: Set TxIn
seenInputs = [Item (Set TxIn)] -> Set TxIn
forall l. IsList l => [Item l] -> l
fromList ([Item (Set TxIn)] -> Set TxIn) -> [Item (Set TxIn)] -> Set TxIn
forall a b. (a -> b) -> a -> b
$ Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxIn]
ourDirectInputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs
       in Map TxIn (BabbageTxOut ConwayEra) -> Bool
forall a. Map TxIn a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map TxIn (BabbageTxOut ConwayEra)
-> Set TxIn -> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo' Set TxIn
seenInputs)
            Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Seen inputs: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Set TxIn -> String
forall b a. (Show a, IsString b) => a -> b
show Set TxIn
seenInputs)
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"New UTXO:    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map TxIn (BabbageTxOut ConwayEra) -> String
forall b a. (Show a, IsString b) => a -> b
show Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo')

--
-- coverFee
--

prop_setsMinUTxOValue :: Property
prop_setsMinUTxOValue :: Property
prop_setsMinUTxOValue =
  Gen (Tx TopTx ConwayEra)
-> (Tx TopTx ConwayEra -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (Tx TopTx ConwayEra) -> Gen (Tx TopTx ConwayEra)
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
0 Gen (Tx TopTx LedgerEra)
Gen (Tx TopTx ConwayEra)
genLedgerTx) ((Tx TopTx ConwayEra -> Property) -> Property)
-> (Tx TopTx ConwayEra -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx TopTx ConwayEra
tx ->
    Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut)
forall a. Gen a -> Gen a
reasonablySized (Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut))
-> Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut)
forall a b. (a -> b) -> a -> b
$ Tx TopTx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO ->
      Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn (BabbageTxOut ConwayEra))
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. Gen a -> Gen a
reasonablySized Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
walletUTxO ->
        Gen (TxOut ConwayEra) -> (TxOut ConwayEra -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (TxOut ConwayEra)
genTxOutWithoutADA ((TxOut ConwayEra -> Property) -> Property)
-> (TxOut ConwayEra -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \TxOut ConwayEra
txOutWithoutADA -> do
          let newTx :: Tx TopTx ConwayEra
newTx = Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((StrictSeq (TxOut ConwayEra)
     -> Identity (StrictSeq (TxOut ConwayEra)))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictSeq (TxOut ConwayEra)
    -> Identity (StrictSeq (TxOut ConwayEra)))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL ((StrictSeq (TxOut ConwayEra)
  -> Identity (StrictSeq (TxOut ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictSeq (TxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ TxOut ConwayEra -> StrictSeq (TxOut ConwayEra)
forall a. a -> StrictSeq a
StrictSeq.singleton TxOut ConwayEra
txOutWithoutADA
          case PParams ConwayEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut ConwayEra)
-> Map TxIn (TxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Either ErrCoverFee (Tx TopTx ConwayEra)
forall era.
(EraPlutusContext era, EraCertState era, AlonzoEraTx era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Tx TopTx era
-> Either ErrCoverFee (Tx TopTx era)
coverFee_ PParams LedgerEra
PParams ConwayEra
Fixture.pparams SystemStart
Fixture.systemStart EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
lookupUTxO Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
walletUTxO Tx TopTx ConwayEra
newTx of
            Left ErrCoverFee
err ->
              Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrCoverFee -> String
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
err)
            Right Tx TopTx ConwayEra
balancedTx -> do
              let outs :: [BabbageTxOut ConwayEra]
outs = StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra])
-> StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall a b. (a -> b) -> a -> b
$ Tx TopTx ConwayEra
balancedTx Tx TopTx ConwayEra
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra
-> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const
       (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Const
          (StrictSeq (BabbageTxOut ConwayEra))
          (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (BabbageTxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra))
      (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL
              Bool -> Bool
not ((BabbageTxOut ConwayEra -> Bool)
-> [BabbageTxOut ConwayEra] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\BabbageTxOut ConwayEra
o -> BabbageTxOut ConwayEra
o BabbageTxOut ConwayEra
-> Getting Coin (BabbageTxOut ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (BabbageTxOut ConwayEra) Coin
(Coin -> Const Coin Coin)
-> TxOut ConwayEra -> Const Coin (TxOut ConwayEra)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
forall a. Monoid a => a
mempty) [BabbageTxOut ConwayEra]
outs)
                Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"No 0 ADA outputs expected:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [BabbageTxOut ConwayEra] -> String
forall b a. (Show a, IsString b) => a -> b
show [BabbageTxOut ConwayEra]
outs)
 where
  -- Generate a deliberately "under-valued" TxOut
  genTxOutWithoutADA :: Gen (TxOut ConwayEra)
genTxOutWithoutADA = Gen (TxOut ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary Gen (TxOut ConwayEra)
-> (TxOut ConwayEra -> TxOut ConwayEra) -> Gen (TxOut ConwayEra)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Coin -> Identity Coin)
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL ((Coin -> Identity Coin)
 -> TxOut ConwayEra -> Identity (TxOut ConwayEra))
-> Coin -> TxOut ConwayEra -> TxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
forall a. Monoid a => a
mempty

prop_balanceTransaction :: Property
prop_balanceTransaction :: Property
prop_balanceTransaction =
  Gen (Tx TopTx ConwayEra)
-> (Tx TopTx ConwayEra -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (Tx TopTx ConwayEra) -> Gen (Tx TopTx ConwayEra)
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
0 Gen (Tx TopTx LedgerEra)
Gen (Tx TopTx ConwayEra)
genLedgerTx) ((Tx TopTx ConwayEra -> Property) -> Property)
-> (Tx TopTx ConwayEra -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx TopTx ConwayEra
tx ->
    Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut)
forall a. Gen a -> Gen a
reasonablySized (Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut))
-> Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut)
forall a b. (a -> b) -> a -> b
$ Tx TopTx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
      \Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO ->
        Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn (BabbageTxOut ConwayEra))
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. Gen a -> Gen a
reasonablySized Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
walletUTxO ->
          case PParams ConwayEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut ConwayEra)
-> Map TxIn (TxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Either ErrCoverFee (Tx TopTx ConwayEra)
forall era.
(EraPlutusContext era, EraCertState era, AlonzoEraTx era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Tx TopTx era
-> Either ErrCoverFee (Tx TopTx era)
coverFee_ PParams LedgerEra
PParams ConwayEra
Fixture.pparams SystemStart
Fixture.systemStart EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
lookupUTxO Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
walletUTxO Tx TopTx ConwayEra
tx of
            Left ErrCoverFee
err ->
              Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrCoverFee -> String
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
err)
            Right Tx TopTx ConwayEra
tx' ->
              [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                [ Map TxIn TxOut
-> Tx TopTx LedgerEra -> Tx TopTx LedgerEra -> Property
isBalanced (Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
forall a. Semigroup a => a -> a -> a
<> Map TxIn (BabbageTxOut ConwayEra)
walletUTxO) Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx'
                , PParams LedgerEra -> Tx TopTx LedgerEra -> Property
hasLowFees PParams LedgerEra
Fixture.pparams Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx'
                ]
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Balanced tx: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx -> String
renderTx (Tx TopTx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx'))
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Partial tx: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx -> String
renderTx (Tx TopTx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx))
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Lookup UTXO: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Map TxIn (BabbageTxOut ConwayEra) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO))
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Wallet UTXO: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Map TxIn (BabbageTxOut ConwayEra) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map TxIn (BabbageTxOut ConwayEra)
walletUTxO))
            -- XXX: This is not exercising any script cost estimation because
            -- genLedgerTx does not generate txs spending from scripts seemingly.
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 (Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting
     (Redeemers ConwayEra) (Tx TopTx ConwayEra) (Redeemers ConwayEra)
-> Redeemers ConwayEra
forall s a. s -> Getting a s a -> a
^. (TxWits ConwayEra
 -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
-> Tx TopTx ConwayEra
-> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra
 -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra
-> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra
  -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra))
-> ((Redeemers ConwayEra
     -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra
    -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
-> Getting
     (Redeemers ConwayEra) (Tx TopTx ConwayEra) (Redeemers ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> TxWits ConwayEra
-> Const (Redeemers ConwayEra) (TxWits ConwayEra)
(Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra
-> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL Redeemers ConwayEra -> Redeemers ConwayEra -> Bool
forall a. Eq a => a -> a -> Bool
/= Redeemers ConwayEra
forall a. Monoid a => a
mempty) String
"spending script"

hasLowFees :: PParams LedgerEra -> Tx TopTx LedgerEra -> Property
hasLowFees :: PParams LedgerEra -> Tx TopTx LedgerEra -> Property
hasLowFees PParams LedgerEra
pparams Tx TopTx LedgerEra
tx =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"PParams: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PParams ConwayEra -> String
forall b a. (Show a, IsString b) => a -> b
show PParams LedgerEra
PParams ConwayEra
pparams) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Property
notTooLow Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
notTooHigh
 where
  notTooLow :: Property
notTooLow =
    Coin
actualFee Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
minFee
      Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Fee too low: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
actualFee String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" < " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
minFee)

  notTooHigh :: Property
notTooHigh =
    Coin
actualFee Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
minFee Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
acceptableOverestimation
      Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Fee too high: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
actualFee String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" > " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show (Coin
minFee Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
acceptableOverestimation))

  acceptableOverestimation :: Coin
acceptableOverestimation = Integer -> Coin
Coin Integer
100_000

  actualFee :: Coin
actualFee = Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting Coin (Tx TopTx ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Const Coin (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Const Coin (Tx TopTx ConwayEra))
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
-> Getting Coin (Tx TopTx ConwayEra) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx ConwayEra) Coin
feeTxBodyL

  minFee :: Coin
  minFee :: Coin
minFee = PParams ConwayEra -> Tx TopTx ConwayEra -> Int -> Coin
forall era (l :: TxLevel).
EraTx era =>
PParams era -> Tx l era -> Int -> Coin
forall (l :: TxLevel).
PParams ConwayEra -> Tx l ConwayEra -> Int -> Coin
getMinFeeTx PParams LedgerEra
PParams ConwayEra
pparams Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx Int
0

isBalanced :: Map TxIn TxOut -> Tx TopTx LedgerEra -> Tx TopTx LedgerEra -> Property
isBalanced :: Map TxIn TxOut
-> Tx TopTx LedgerEra -> Tx TopTx LedgerEra -> Property
isBalanced Map TxIn TxOut
utxo Tx TopTx LedgerEra
originalTx Tx TopTx LedgerEra
balancedTx =
  let inp' :: Value LedgerEra
inp' = Map TxIn TxOut -> Tx TopTx LedgerEra -> Value LedgerEra
knownInputBalance Map TxIn TxOut
utxo Tx TopTx LedgerEra
balancedTx
      out' :: Value LedgerEra
out' = Tx TopTx LedgerEra -> Value LedgerEra
outputBalance Tx TopTx LedgerEra
balancedTx
      out :: Value LedgerEra
out = Tx TopTx LedgerEra -> Value LedgerEra
outputBalance Tx TopTx LedgerEra
originalTx
      fee :: Coin
fee = Getting Coin (Tx TopTx ConwayEra) Coin
-> Tx TopTx ConwayEra -> Coin
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Const Coin (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Const Coin (Tx TopTx ConwayEra))
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
-> Getting Coin (Tx TopTx ConwayEra) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx ConwayEra) Coin
feeTxBodyL) Tx TopTx LedgerEra
Tx TopTx ConwayEra
balancedTx
   in MaryValue -> Coin
forall t. Val t => t -> Coin
coin (Value LedgerEra -> Value LedgerEra -> Value LedgerEra
deltaValue Value LedgerEra
out' Value LedgerEra
inp') Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
fee
        Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Fee:             " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
fee)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Delta value:     " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show (Value LedgerEra -> Coin
forall t. Val t => t -> Coin
coin (Value LedgerEra -> Coin) -> Value LedgerEra -> Coin
forall a b. (a -> b) -> a -> b
$ Value LedgerEra -> Value LedgerEra -> Value LedgerEra
deltaValue Value LedgerEra
out' Value LedgerEra
inp'))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Added value:     " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show (MaryValue -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue
inp'))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Outputs after:   " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show (MaryValue -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue
out'))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Outputs before:  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show (MaryValue -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue
out))

prop_picksLargestUTxOToPayTheFees :: Property
prop_picksLargestUTxOToPayTheFees :: Property
prop_picksLargestUTxOToPayTheFees =
  Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
utxo1 ->
    Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
utxo2 -> do
      let combinedUTxO :: Map TxIn (BabbageTxOut ConwayEra)
combinedUTxO = Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map TxIn (BabbageTxOut ConwayEra)
utxo1 Map TxIn (BabbageTxOut ConwayEra)
utxo2
      case Map TxIn (TxOut ConwayEra) -> Maybe (TxIn, TxOut ConwayEra)
forall era.
EraTxOut era =>
Map TxIn (TxOut era) -> Maybe (TxIn, TxOut era)
findLargestUTxO Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
combinedUTxO of
        Maybe (TxIn, TxOut ConwayEra)
Nothing ->
          Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"No utxo found: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Map TxIn (BabbageTxOut ConwayEra) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map TxIn (BabbageTxOut ConwayEra)
combinedUTxO))
        Just (TxIn
_, TxOut ConwayEra
txout) -> do
          let foundLovelace :: Coin
foundLovelace = Value -> Coin
selectLovelace (Value -> Coin) -> Value -> Coin
forall a b. (a -> b) -> a -> b
$ TxOut Any -> Value
forall ctx. TxOut ctx -> Value
txOutValue (TxOut -> TxOut Any
forall era ctx.
IsShelleyBasedEra era =>
TxOut (ShelleyLedgerEra era) -> TxOut ctx era
fromLedgerTxOut TxOut
TxOut ConwayEra
txout)
              mapToLovelace :: Map TxIn (BabbageTxOut ConwayEra) -> [Coin]
mapToLovelace = (TxOut CtxUTxO -> Coin) -> [TxOut CtxUTxO] -> [Coin]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> Coin
selectLovelace (Value -> Coin)
-> (TxOut CtxUTxO -> Value) -> TxOut CtxUTxO -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue) ([TxOut CtxUTxO] -> [Coin])
-> (Map TxIn (BabbageTxOut ConwayEra) -> [TxOut CtxUTxO])
-> Map TxIn (BabbageTxOut ConwayEra)
-> [Coin]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO Era -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs (UTxO Era -> [TxOut CtxUTxO])
-> (Map TxIn (BabbageTxOut ConwayEra) -> UTxO Era)
-> Map TxIn (BabbageTxOut ConwayEra)
-> [TxOut CtxUTxO]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra Era -> UTxO LedgerEra -> UTxO Era
forall era.
ShelleyBasedEra era -> UTxO (ShelleyLedgerEra era) -> UTxO era
UTxO.fromShelleyUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (UTxO ConwayEra -> UTxO Era)
-> (Map TxIn (BabbageTxOut ConwayEra) -> UTxO ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
-> UTxO Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (BabbageTxOut ConwayEra) -> UTxO ConwayEra
Map TxIn (TxOut ConwayEra) -> UTxO ConwayEra
forall era. Map TxIn (TxOut era) -> UTxO era
Ledger.UTxO
          Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            (Coin -> Bool) -> [Coin] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Coin
foundLovelace >=) (Map TxIn (BabbageTxOut ConwayEra) -> [Coin]
mapToLovelace Map TxIn (BabbageTxOut ConwayEra)
utxo1)
              Bool -> Bool -> Bool
&& (Coin -> Bool) -> [Coin] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Coin
foundLovelace >=) (Map TxIn (BabbageTxOut ConwayEra) -> [Coin]
mapToLovelace Map TxIn (BabbageTxOut ConwayEra)
utxo2)
              Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Found lovelace: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
foundLovelace)
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Found lovelace not greater than all of: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Map TxIn (BabbageTxOut ConwayEra) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map TxIn (BabbageTxOut ConwayEra)
combinedUTxO))

--
-- Generators
--

-- | Generate an arbitrary list of transactions from a UTXO set such that,
-- transactions may *sometimes* consume given UTXO and produce new ones. The
-- generator is geared towards certain use-cases,
genTxsSpending :: Map TxIn TxOut -> Gen [Tx TopTx LedgerEra]
genTxsSpending :: Map TxIn TxOut -> Gen [Tx TopTx LedgerEra]
genTxsSpending Map TxIn TxOut
utxo = (Int -> Int)
-> Gen [Tx TopTx LedgerEra] -> Gen [Tx TopTx LedgerEra]
forall a. (Int -> Int) -> Gen a -> Gen a
scale (forall a b. (RealFrac a, Integral b) => a -> b
round @Double (Double -> Int) -> (Int -> Double) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a. Floating a => a -> a
sqrt (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Gen [Tx TopTx LedgerEra] -> Gen [Tx TopTx LedgerEra])
-> Gen [Tx TopTx LedgerEra] -> Gen [Tx TopTx LedgerEra]
forall a b. (a -> b) -> a -> b
$ do
  StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen [Tx TopTx ConwayEra]
-> Map TxIn (BabbageTxOut ConwayEra) -> Gen [Tx TopTx ConwayEra]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen [Tx TopTx ConwayEra]
StateT (Map TxIn TxOut) Gen [Tx TopTx LedgerEra]
genTxs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo
 where
  genTxs :: StateT (Map TxIn TxOut) Gen [Tx TopTx LedgerEra]
  genTxs :: StateT (Map TxIn TxOut) Gen [Tx TopTx LedgerEra]
genTxs = do
    Int
n <- Gen Int -> StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
getSize
    Int
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (Tx TopTx ConwayEra)
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen [Tx TopTx ConwayEra]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen (Tx TopTx ConwayEra)
StateT (Map TxIn TxOut) Gen (Tx TopTx LedgerEra)
genTx

  genTx :: StateT (Map TxIn TxOut) Gen (Tx TopTx LedgerEra)
  genTx :: StateT (Map TxIn TxOut) Gen (Tx TopTx LedgerEra)
genTx = do
    StateT
  (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)
genBody <-
      Gen
  (StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra))
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra))
     Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra))
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen
   (StateT
      (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra))
 -> StateT
      (Map TxIn (BabbageTxOut ConwayEra))
      Gen
      (StateT
         (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)))
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra))
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra))
     Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra))
forall a b. (a -> b) -> a -> b
$
        [(Int,
  Gen
    (StateT
       (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)))]
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
4, StateT
  (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateT
   (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)
 -> Gen
      (StateT
         (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)))
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra))
forall a b. (a -> b) -> a -> b
$ Gen (TxBody TopTx ConwayEra)
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (TxBody TopTx ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary)
          , (Int
1, StateT
  (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateT
  (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)
StateT (Map TxIn TxOut) Gen (TxBody TopTx LedgerEra)
genBodyFromUTxO)
          ]
    TxBody TopTx ConwayEra
body <- StateT
  (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)
genBody
    Gen (Tx TopTx ConwayEra)
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (Tx TopTx ConwayEra)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen (Tx TopTx ConwayEra)
 -> StateT
      (Map TxIn (BabbageTxOut ConwayEra)) Gen (Tx TopTx ConwayEra))
-> Gen (Tx TopTx ConwayEra)
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (Tx TopTx ConwayEra)
forall a b. (a -> b) -> a -> b
$ do
      Tx TopTx ConwayEra
tx <- Gen (Tx TopTx ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary
      Tx TopTx ConwayEra -> Gen (Tx TopTx ConwayEra)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx TopTx ConwayEra -> Gen (Tx TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Gen (Tx TopTx ConwayEra)
forall a b. (a -> b) -> a -> b
$ Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> TxBody TopTx ConwayEra
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxBody TopTx ConwayEra
body

  -- Generate a TxBody by consuming a UTXO from the state, and generating a new
  -- one. The number of UTXO in the state after calling this function remains
  -- identical.
  genBodyFromUTxO :: StateT (Map TxIn TxOut) Gen (TxBody TopTx LedgerEra)
  genBodyFromUTxO :: StateT (Map TxIn TxOut) Gen (TxBody TopTx LedgerEra)
genBodyFromUTxO = do
    TxBody TopTx ConwayEra
base <- Gen (TxBody TopTx ConwayEra)
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (TxBody TopTx ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary
    (TxIn
input, BabbageTxOut ConwayEra
output) <- (Map TxIn (BabbageTxOut ConwayEra)
 -> (TxIn, BabbageTxOut ConwayEra))
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra))
     Gen
     (TxIn, BabbageTxOut ConwayEra)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Map TxIn (BabbageTxOut ConwayEra) -> (TxIn, BabbageTxOut ConwayEra)
forall k a. Map k a -> (k, a)
Map.findMax
    let body :: TxBody TopTx ConwayEra
body =
          TxBody TopTx ConwayEra
base
            TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Set TxIn -> TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
input
            TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (BabbageTxOut ConwayEra)
 -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL ((StrictSeq (BabbageTxOut ConwayEra)
  -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
-> TxBody TopTx ConwayEra
-> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BabbageTxOut ConwayEra -> StrictSeq (BabbageTxOut ConwayEra)
forall a. a -> StrictSeq a
StrictSeq.singleton BabbageTxOut ConwayEra
output
    let input' :: TxIn
input' = TxId -> TxIx -> TxIn
Ledger.TxIn (SafeHash EraIndependentTxBody -> TxId
Ledger.TxId (SafeHash EraIndependentTxBody -> TxId)
-> SafeHash EraIndependentTxBody -> TxId
forall a b. (a -> b) -> a -> b
$ TxBody TopTx ConwayEra -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody TopTx ConwayEra
body) (Word16 -> TxIx
Ledger.TxIx Word16
0)
    (Map TxIn (BabbageTxOut ConwayEra)
 -> Map TxIn (BabbageTxOut ConwayEra))
-> StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Map TxIn (BabbageTxOut ConwayEra)
m -> Map TxIn (BabbageTxOut ConwayEra)
m Map TxIn (BabbageTxOut ConwayEra)
-> (Map TxIn (BabbageTxOut ConwayEra)
    -> Map TxIn (BabbageTxOut ConwayEra))
-> Map TxIn (BabbageTxOut ConwayEra)
forall a b. a -> (a -> b) -> b
& TxIn
-> Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TxIn
input Map TxIn (BabbageTxOut ConwayEra)
-> (Map TxIn (BabbageTxOut ConwayEra)
    -> Map TxIn (BabbageTxOut ConwayEra))
-> Map TxIn (BabbageTxOut ConwayEra)
forall a b. a -> (a -> b) -> b
& TxIn
-> BabbageTxOut ConwayEra
-> Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
input' BabbageTxOut ConwayEra
output)
    TxBody TopTx ConwayEra
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody TopTx ConwayEra)
forall a. a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxBody TopTx ConwayEra
body

genUTxO :: Gen (Map TxIn TxOut)
genUTxO :: Gen (Map TxIn TxOut)
genUTxO = do
  Tx TopTx ConwayEra
tx <- forall a. Arbitrary a => Gen a
arbitrary @(Tx TopTx LedgerEra) Gen (Tx TopTx ConwayEra)
-> (Tx TopTx ConwayEra -> Bool) -> Gen (Tx TopTx ConwayEra)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
Prelude.not (Bool -> Bool)
-> (Tx TopTx ConwayEra -> Bool) -> Tx TopTx ConwayEra -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (TxOut ConwayEra) -> Bool
forall a. StrictSeq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null (StrictSeq (TxOut ConwayEra) -> Bool)
-> (Tx TopTx ConwayEra -> StrictSeq (TxOut ConwayEra))
-> Tx TopTx ConwayEra
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (StrictSeq (TxOut ConwayEra))
  (Tx TopTx ConwayEra)
  (StrictSeq (TxOut ConwayEra))
-> Tx TopTx ConwayEra -> StrictSeq (TxOut ConwayEra)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((TxBody TopTx ConwayEra
 -> Const (StrictSeq (TxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra
-> Const (StrictSeq (TxOut ConwayEra)) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const (StrictSeq (TxOut ConwayEra)) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (StrictSeq (TxOut ConwayEra)) (Tx TopTx ConwayEra))
-> ((StrictSeq (TxOut ConwayEra)
     -> Const
          (StrictSeq (TxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const (StrictSeq (TxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Getting
     (StrictSeq (TxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (TxOut ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (TxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const (StrictSeq (TxOut ConwayEra)) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL))
  TxIn
txIn <- TxIn -> TxIn
toLedgerTxIn (TxIn -> TxIn) -> Gen TxIn -> Gen TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
genTxIn
  let txOut :: TxOut
txOut = TxOut -> TxOut
scaleAda (TxOut -> TxOut) -> TxOut -> TxOut
forall a b. (a -> b) -> a -> b
$ [TxOut] -> TxOut
forall a. HasCallStack => [a] -> a
Prelude.head ([TxOut] -> TxOut) -> [TxOut] -> TxOut
forall a b. (a -> b) -> a -> b
$ StrictSeq TxOut -> [TxOut]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq TxOut -> [TxOut]) -> StrictSeq TxOut -> [TxOut]
forall a b. (a -> b) -> a -> b
$ Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. ((TxBody TopTx ConwayEra
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra
-> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const
       (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Const
          (StrictSeq (BabbageTxOut ConwayEra))
          (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (BabbageTxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra))
      (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL)
  Map TxIn (BabbageTxOut ConwayEra)
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (BabbageTxOut ConwayEra)
 -> Gen (Map TxIn (BabbageTxOut ConwayEra)))
-> Map TxIn (BabbageTxOut ConwayEra)
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a b. (a -> b) -> a -> b
$ TxIn -> BabbageTxOut ConwayEra -> Map TxIn (BabbageTxOut ConwayEra)
forall k a. k -> a -> Map k a
Map.singleton TxIn
txIn BabbageTxOut ConwayEra
TxOut
txOut
 where
  scaleAda :: TxOut -> TxOut
  scaleAda :: TxOut -> TxOut
scaleAda (BabbageTxOut Address
addr Value ConwayEra
value Datum ConwayEra
datum StrictMaybe (Script ConwayEra)
refScript) =
    let value' :: MaryValue
value' = Value ConwayEra
MaryValue
value MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> Coin -> MaryValue
forall t s. Inject t s => t -> s
Ledger.inject (Integer -> Coin
Coin Integer
20_000_000)
     in Address
-> Value ConwayEra
-> Datum ConwayEra
-> StrictMaybe (Script ConwayEra)
-> BabbageTxOut ConwayEra
forall era.
(Era era, Val (Value era), HasCallStack) =>
Address
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut Address
addr Value ConwayEra
MaryValue
value' Datum ConwayEra
datum StrictMaybe (Script ConwayEra)
refScript

genOutputsForInputs :: Tx TopTx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs :: Tx TopTx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs Tx TopTx LedgerEra
tx = do
  let n :: Int
n = Set TxIn -> Int
forall a. Set a -> Int
Set.size (Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
-> Tx TopTx ConwayEra -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((TxBody TopTx ConwayEra
 -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Const (Set TxIn) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const (Set TxIn) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Const (Set TxIn) (Tx TopTx ConwayEra))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx ConwayEra
    -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx ConwayEra
-> Const (Set TxIn) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL) Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx)
  [BabbageTxOut ConwayEra]
outs <- Int -> Gen (BabbageTxOut ConwayEra) -> Gen [BabbageTxOut ConwayEra]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen (BabbageTxOut ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary
  Map TxIn (BabbageTxOut ConwayEra)
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (BabbageTxOut ConwayEra)
 -> Gen (Map TxIn (BabbageTxOut ConwayEra)))
-> Map TxIn (BabbageTxOut ConwayEra)
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a b. (a -> b) -> a -> b
$ [(TxIn, BabbageTxOut ConwayEra)]
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, BabbageTxOut ConwayEra)]
 -> Map TxIn (BabbageTxOut ConwayEra))
-> [(TxIn, BabbageTxOut ConwayEra)]
-> Map TxIn (BabbageTxOut ConwayEra)
forall a b. (a -> b) -> a -> b
$ [TxIn]
-> [BabbageTxOut ConwayEra] -> [(TxIn, BabbageTxOut ConwayEra)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
-> Tx TopTx ConwayEra -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((TxBody TopTx ConwayEra
 -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Const (Set TxIn) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const (Set TxIn) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Const (Set TxIn) (Tx TopTx ConwayEra))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx ConwayEra
    -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx ConwayEra
-> Const (Set TxIn) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL) Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx)) [BabbageTxOut ConwayEra]
outs

genLedgerTx :: Gen (Tx TopTx LedgerEra)
genLedgerTx :: Gen (Tx TopTx LedgerEra)
genLedgerTx = do
  Tx TopTx ConwayEra
tx <- Gen (Tx TopTx ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary
  Tx TopTx ConwayEra -> Gen (Tx TopTx ConwayEra)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx TopTx ConwayEra -> Gen (Tx TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Gen (Tx TopTx ConwayEra)
forall a b. (a -> b) -> a -> b
$ Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Coin -> Identity Coin)
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Coin -> Identity Coin)
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx ConwayEra) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Coin -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
0

--
-- Helpers
--

allTxIns :: [Tx TopTx LedgerEra] -> Set TxIn
allTxIns :: [Tx TopTx LedgerEra] -> Set TxIn
allTxIns [Tx TopTx LedgerEra]
txs =
  [Set TxIn] -> Set TxIn
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
-> Tx TopTx ConwayEra -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((TxBody TopTx ConwayEra
 -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Const (Set TxIn) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const (Set TxIn) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Const (Set TxIn) (Tx TopTx ConwayEra))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx ConwayEra
    -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx ConwayEra
-> Const (Set TxIn) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL) (Tx TopTx ConwayEra -> Set TxIn)
-> [Tx TopTx ConwayEra] -> [Set TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs)

allTxOuts :: [Tx TopTx LedgerEra] -> [TxOut]
allTxOuts :: [Tx TopTx LedgerEra] -> [TxOut]
allTxOuts [Tx TopTx LedgerEra]
txs =
  StrictSeq TxOut -> [TxOut]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq TxOut -> [TxOut]) -> StrictSeq TxOut -> [TxOut]
forall a b. (a -> b) -> a -> b
$ [StrictSeq (BabbageTxOut ConwayEra)]
-> StrictSeq (BabbageTxOut ConwayEra)
forall a. Monoid a => [a] -> a
mconcat (Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (Tx TopTx ConwayEra)
  (StrictSeq (BabbageTxOut ConwayEra))
-> Tx TopTx ConwayEra -> StrictSeq (BabbageTxOut ConwayEra)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((TxBody TopTx ConwayEra
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra
-> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const
       (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Const
          (StrictSeq (BabbageTxOut ConwayEra))
          (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (BabbageTxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra))
      (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL) (Tx TopTx ConwayEra -> StrictSeq (BabbageTxOut ConwayEra))
-> [Tx TopTx ConwayEra] -> [StrictSeq (BabbageTxOut ConwayEra)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx TopTx LedgerEra]
[Tx TopTx ConwayEra]
txs)

isOurs :: Map TxIn TxOut -> Address -> Bool
isOurs :: Map TxIn TxOut -> Address -> Bool
isOurs Map TxIn TxOut
utxo Address
addr =
  Address
addr Address -> [Address] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` ((\(BabbageTxOut Address
addr' Value ConwayEra
_ Datum ConwayEra
_ StrictMaybe (Script ConwayEra)
_) -> Address
addr') (BabbageTxOut ConwayEra -> Address)
-> [BabbageTxOut ConwayEra] -> [Address]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall k a. Map k a -> [a]
Map.elems Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo)

-- NOTE: 'direct' here means inputs that can be identified from our initial
-- UTXO set. UTXOs that are created in a transaction from that blk aren't
-- counted here.
ourDirectInputs :: Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxIn]
ourDirectInputs :: Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxIn]
ourDirectInputs Map TxIn TxOut
utxo [Tx TopTx LedgerEra]
txs =
  Map TxIn (BabbageTxOut ConwayEra) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys (Map TxIn (BabbageTxOut ConwayEra) -> [TxIn])
-> Map TxIn (BabbageTxOut ConwayEra) -> [TxIn]
forall a b. (a -> b) -> a -> b
$ Map TxIn (BabbageTxOut ConwayEra)
-> Set TxIn -> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo ([Tx TopTx LedgerEra] -> Set TxIn
allTxIns [Tx TopTx LedgerEra]
txs)

ourOutputs :: Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxOut]
ourOutputs :: Map TxIn TxOut -> [Tx TopTx LedgerEra] -> [TxOut]
ourOutputs Map TxIn TxOut
utxo [Tx TopTx LedgerEra]
blk =
  let ours :: [BabbageTxOut ConwayEra]
ours = Map TxIn (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall k a. Map k a -> [a]
Map.elems Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo
   in (BabbageTxOut ConwayEra -> Bool)
-> [BabbageTxOut ConwayEra] -> [BabbageTxOut ConwayEra]
forall a. (a -> Bool) -> [a] -> [a]
filter (BabbageTxOut ConwayEra -> [BabbageTxOut ConwayEra] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [BabbageTxOut ConwayEra]
ours) ([Tx TopTx LedgerEra] -> [TxOut]
allTxOuts [Tx TopTx LedgerEra]
blk)

getValue :: TxOut -> Value LedgerEra
getValue :: TxOut -> Value LedgerEra
getValue (BabbageTxOut Address
_ Value ConwayEra
value Datum ConwayEra
_ StrictMaybe (Script ConwayEra)
_) = Value LedgerEra
Value ConwayEra
value

deltaValue :: Value LedgerEra -> Value LedgerEra -> Value LedgerEra
deltaValue :: Value LedgerEra -> Value LedgerEra -> Value LedgerEra
deltaValue Value LedgerEra
a Value LedgerEra
b
  | MaryValue -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue
a Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> MaryValue -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue
b = Value LedgerEra
MaryValue
a MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> MaryValue -> MaryValue
forall t. Val t => t -> t
invert Value LedgerEra
MaryValue
b
  | Bool
otherwise = MaryValue -> MaryValue
forall t. Val t => t -> t
invert Value LedgerEra
MaryValue
a MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> Value LedgerEra
MaryValue
b

-- | NOTE: This does not account for withdrawals
knownInputBalance :: Map TxIn TxOut -> Tx TopTx LedgerEra -> Value LedgerEra
knownInputBalance :: Map TxIn TxOut -> Tx TopTx LedgerEra -> Value LedgerEra
knownInputBalance Map TxIn TxOut
utxo = (TxIn -> MaryValue) -> [TxIn] -> MaryValue
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxIn -> Value LedgerEra
TxIn -> MaryValue
resolve ([TxIn] -> MaryValue)
-> (Tx TopTx ConwayEra -> [TxIn])
-> Tx TopTx ConwayEra
-> MaryValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set TxIn -> [TxIn])
-> (Tx TopTx ConwayEra -> Set TxIn) -> Tx TopTx ConwayEra -> [TxIn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
-> Tx TopTx ConwayEra -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((TxBody TopTx ConwayEra
 -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Const (Set TxIn) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const (Set TxIn) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Const (Set TxIn) (Tx TopTx ConwayEra))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx ConwayEra
    -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx ConwayEra
-> Const (Set TxIn) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL)
 where
  resolve :: TxIn -> Value LedgerEra
  resolve :: TxIn -> Value LedgerEra
resolve TxIn
k = MaryValue
-> (BabbageTxOut ConwayEra -> MaryValue)
-> Maybe (BabbageTxOut ConwayEra)
-> MaryValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaryValue
forall t. Val t => t
zero BabbageTxOut ConwayEra -> MaryValue
TxOut -> Value LedgerEra
getValue (TxIn
-> Map TxIn (BabbageTxOut ConwayEra)
-> Maybe (BabbageTxOut ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
k Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo)

-- | NOTE: This does not account for deposits
outputBalance :: Tx TopTx LedgerEra -> Value LedgerEra
outputBalance :: Tx TopTx LedgerEra -> Value LedgerEra
outputBalance =
  (BabbageTxOut ConwayEra -> MaryValue)
-> StrictSeq (BabbageTxOut ConwayEra) -> MaryValue
forall m a. Monoid m => (a -> m) -> StrictSeq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap BabbageTxOut ConwayEra -> MaryValue
TxOut -> Value LedgerEra
getValue (StrictSeq (BabbageTxOut ConwayEra) -> MaryValue)
-> (Tx TopTx ConwayEra -> StrictSeq (BabbageTxOut ConwayEra))
-> Tx TopTx ConwayEra
-> MaryValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (Tx TopTx ConwayEra)
  (StrictSeq (BabbageTxOut ConwayEra))
-> Tx TopTx ConwayEra -> StrictSeq (BabbageTxOut ConwayEra)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((TxBody TopTx ConwayEra
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra
-> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const
       (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Const
          (StrictSeq (BabbageTxOut ConwayEra))
          (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (BabbageTxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra))
      (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL)

-- | Test that coverFee detects missing script witnesses.
-- Generates transactions that spend from script-locked UTxOs but omit the script witness.
prop_detectsMissingScript :: Property
prop_detectsMissingScript :: Property
prop_detectsMissingScript =
  Gen (Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
-> ((Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
    -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (Tx TopTx LedgerEra, Map TxIn TxOut)
Gen (Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
genScriptSpendingTx (((Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
  -> Property)
 -> Property)
-> ((Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(Tx TopTx ConwayEra
tx, Map TxIn (BabbageTxOut ConwayEra)
scriptUTxO) ->
    Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn (BabbageTxOut ConwayEra))
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. Gen a -> Gen a
reasonablySized Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
walletUTxO ->
      Gen (Data ConwayEra) -> (Data ConwayEra -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Data ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary ((Data ConwayEra -> Property) -> Property)
-> (Data ConwayEra -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(Data LedgerEra
arbitraryData :: Data LedgerEra) -> do
        let
          -- Add a redeemer for the script input but DON'T add the script witness.
          -- This creates the missing script scenario: redeemer present but script absent.
          -- NB: ExUnits are irrelevant since script execution will fail due to missing script.
          redeemers :: Redeemers ConwayEra
redeemers = Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
 -> Redeemers ConwayEra)
-> Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall a b. (a -> b) -> a -> b
$ PlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits)
-> Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a. k -> a -> Map k a
Map.singleton (AsIx Word32 TxIn -> PlutusPurpose AsIx ConwayEra
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0)) (Data LedgerEra
Data ConwayEra
arbitraryData, Natural -> Natural -> ExUnits
ExUnits Natural
0 Natural
0)
          txWithRedeemer :: Tx TopTx ConwayEra
txWithRedeemer = Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
(Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Redeemers ConwayEra -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers ConwayEra
redeemers

        case PParams ConwayEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut ConwayEra)
-> Map TxIn (TxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Either ErrCoverFee (Tx TopTx ConwayEra)
forall era.
(EraPlutusContext era, EraCertState era, AlonzoEraTx era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Tx TopTx era
-> Either ErrCoverFee (Tx TopTx era)
coverFee_ PParams LedgerEra
PParams ConwayEra
Fixture.pparams SystemStart
Fixture.systemStart EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
scriptUTxO Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
walletUTxO Tx TopTx ConwayEra
txWithRedeemer of
          Left (ErrMissingScript Text
scriptHash Text
purpose) ->
            Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"✓ Correctly detected missing script"
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"  Script hash: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
scriptHash)
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"  Purpose: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
purpose)
          Left ErrCoverFee
otherError ->
            Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Expected ErrMissingScript but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrCoverFee -> String
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
otherError)
          Right Tx TopTx ConwayEra
_balancedTx ->
            Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Expected ErrMissingScript but transaction succeeded"
 where
  -- Generate a transaction that spends from a script-locked UTxO
  genScriptSpendingTx :: Gen (Tx TopTx LedgerEra, Map TxIn TxOut)
  genScriptSpendingTx :: Gen (Tx TopTx LedgerEra, Map TxIn TxOut)
genScriptSpendingTx = do
    -- Generate a dummy script hash
    ScriptHash
scriptHash <- Gen ScriptHash
forall a. Arbitrary a => Gen a
arbitrary

    -- Create a script-locked output
    BabbageTxOut ConwayEra
baseOutput <- Gen (BabbageTxOut ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary
    let scriptAddress :: Address
scriptAddress = Network -> Credential Payment -> StakeReference -> Address
Ledger.Addr Network
Ledger.Testnet (ScriptHash -> Credential Payment
forall (kr :: KeyRole). ScriptHash -> Credential kr
Ledger.ScriptHashObj ScriptHash
scriptHash) StakeReference
Ledger.StakeRefNull
        scriptTxOut :: BabbageTxOut ConwayEra
scriptTxOut = BabbageTxOut ConwayEra
baseOutput BabbageTxOut ConwayEra
-> (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (\(BabbageTxOut Address
_ Value ConwayEra
val Datum ConwayEra
dat StrictMaybe (Script ConwayEra)
ref) -> Address
-> Value ConwayEra
-> Datum ConwayEra
-> StrictMaybe (Script ConwayEra)
-> BabbageTxOut ConwayEra
forall era.
(Era era, Val (Value era), HasCallStack) =>
Address
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut Address
scriptAddress Value ConwayEra
val Datum ConwayEra
dat StrictMaybe (Script ConwayEra)
ref)

    -- Create an input spending from this script output
    TxIn
scriptTxIn <- TxIn -> TxIn
toLedgerTxIn (TxIn -> TxIn) -> Gen TxIn -> Gen TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
genTxIn

    -- Generate a transaction with this input
    Tx TopTx ConwayEra
baseTx <- Gen (Tx TopTx LedgerEra)
Gen (Tx TopTx ConwayEra)
genLedgerTx
    let txSpendingScript :: Tx TopTx ConwayEra
txSpendingScript = Tx TopTx ConwayEra
baseTx Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Set TxIn -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
scriptTxIn
        lookupUTxO :: Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO = TxIn -> BabbageTxOut ConwayEra -> Map TxIn (BabbageTxOut ConwayEra)
forall k a. k -> a -> Map k a
Map.singleton TxIn
scriptTxIn BabbageTxOut ConwayEra
scriptTxOut

    (Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
-> Gen (Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx TopTx ConwayEra
txSpendingScript, Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO)

-- | Reference inputs carrying Plutus scripts must not produce a script
-- integrity hash when the transaction executes no scripts (no redeemers, no
-- datums). The ledger expects SNothing in that case and rejects the tx with
-- PPViewHashesDontMatch otherwise.
prop_noScriptIntegrityHashWithoutExecution :: Property
prop_noScriptIntegrityHashWithoutExecution :: Property
prop_noScriptIntegrityHashWithoutExecution =
  Gen (Tx TopTx ConwayEra)
-> (Tx TopTx ConwayEra -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (Tx TopTx ConwayEra) -> Gen (Tx TopTx ConwayEra)
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
0 Gen (Tx TopTx LedgerEra)
Gen (Tx TopTx ConwayEra)
genLedgerTx) ((Tx TopTx ConwayEra -> Property) -> Property)
-> (Tx TopTx ConwayEra -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx TopTx ConwayEra
tx ->
    Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut)
forall a. Gen a -> Gen a
reasonablySized (Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut))
-> Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut)
forall a b. (a -> b) -> a -> b
$ Tx TopTx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO ->
      Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn (BabbageTxOut ConwayEra))
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. Gen a -> Gen a
reasonablySized Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
walletUTxO ->
        Gen (TxIn, BabbageTxOut ConwayEra)
-> ((TxIn, BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (TxIn, BabbageTxOut ConwayEra)
genRefScriptUTxO (((TxIn, BabbageTxOut ConwayEra) -> Property) -> Property)
-> ((TxIn, BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(TxIn
refIn, BabbageTxOut ConwayEra
refOut) -> do
          let txWithRefInput :: Tx TopTx ConwayEra
txWithRefInput =
                Tx TopTx ConwayEra
tx
                  Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Set TxIn -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
refIn
                  -- Ensure nothing executes: no redeemers, no datums, no witness scripts
                  Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
(Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Redeemers ConwayEra -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers ConwayEra
forall a. Monoid a => a
mempty
                  Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((TxDats ConwayEra -> Identity (TxDats ConwayEra))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (TxDats ConwayEra -> Identity (TxDats ConwayEra))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats ConwayEra -> Identity (TxDats ConwayEra))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
(TxDats ConwayEra -> Identity (TxDats ConwayEra))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits ConwayEra) (TxDats ConwayEra)
datsTxWitsL ((TxDats ConwayEra -> Identity (TxDats ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> TxDats ConwayEra -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxDats ConwayEra
forall a. Monoid a => a
mempty
                  Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Map ScriptHash (Script ConwayEra)
     -> Identity (Map ScriptHash (Script ConwayEra)))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Map ScriptHash (Script ConwayEra)
    -> Identity (Map ScriptHash (Script ConwayEra)))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script ConwayEra)
 -> Identity (Map ScriptHash (Script ConwayEra)))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
(Map ScriptHash (Script ConwayEra)
 -> Identity (Map ScriptHash (Script ConwayEra)))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits ConwayEra) (Map ScriptHash (Script ConwayEra))
scriptTxWitsL ((Map ScriptHash (Script ConwayEra)
  -> Identity (Map ScriptHash (Script ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Map ScriptHash (Script ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (Script ConwayEra)
forall a. Monoid a => a
mempty
          case PParams ConwayEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut ConwayEra)
-> Map TxIn (TxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Either ErrCoverFee (Tx TopTx ConwayEra)
forall era.
(EraPlutusContext era, EraCertState era, AlonzoEraTx era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Tx TopTx era
-> Either ErrCoverFee (Tx TopTx era)
coverFee_ PParams LedgerEra
PParams ConwayEra
Fixture.pparams SystemStart
Fixture.systemStart EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo (TxIn
-> BabbageTxOut ConwayEra
-> Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
refIn BabbageTxOut ConwayEra
refOut Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO) Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
walletUTxO Tx TopTx ConwayEra
txWithRefInput of
            Left ErrCoverFee
ErrNoFuelUTxOFound -> Discard -> Property
forall prop. Testable prop => prop -> Property
property Discard
Discard
            Left err :: ErrCoverFee
err@ErrNotEnoughFunds{} -> Discard -> Property
forall prop. Testable prop => prop -> Property
property Discard
Discard Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (ErrCoverFee -> String
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
err)
            Left ErrCoverFee
err ->
              Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Unexpected coverFee error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrCoverFee -> String
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
err)
            Right Tx TopTx ConwayEra
balancedTx ->
              ( (Tx TopTx ConwayEra
balancedTx Tx TopTx ConwayEra
-> Getting
     (StrictMaybe ScriptIntegrityHash)
     (Tx TopTx ConwayEra)
     (StrictMaybe ScriptIntegrityHash)
-> StrictMaybe ScriptIntegrityHash
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const
      (StrictMaybe ScriptIntegrityHash) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra
-> Const (StrictMaybe ScriptIntegrityHash) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const
       (StrictMaybe ScriptIntegrityHash) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (StrictMaybe ScriptIntegrityHash) (Tx TopTx ConwayEra))
-> ((StrictMaybe ScriptIntegrityHash
     -> Const
          (StrictMaybe ScriptIntegrityHash)
          (StrictMaybe ScriptIntegrityHash))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictMaybe ScriptIntegrityHash) (TxBody TopTx ConwayEra))
-> Getting
     (StrictMaybe ScriptIntegrityHash)
     (Tx TopTx ConwayEra)
     (StrictMaybe ScriptIntegrityHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Const
      (StrictMaybe ScriptIntegrityHash)
      (StrictMaybe ScriptIntegrityHash))
-> TxBody TopTx ConwayEra
-> Const (StrictMaybe ScriptIntegrityHash) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe ScriptIntegrityHash)
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL) StrictMaybe ScriptIntegrityHash
-> StrictMaybe ScriptIntegrityHash -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== StrictMaybe ScriptIntegrityHash
forall a. StrictMaybe a
Ledger.SNothing
                  Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Balanced tx: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx -> String
renderTx (Tx TopTx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx Tx TopTx LedgerEra
Tx TopTx ConwayEra
balancedTx))
              )
                Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
                  String
"fixture no longer carries a reference script — property is vacuous"
                  (BabbageTxOut ConwayEra -> Bool
hasReferenceScript BabbageTxOut ConwayEra
refOut)
 where
  -- A UTxO carrying a Plutus V3 reference script that the tx does not execute
  genRefScriptUTxO :: Gen (TxIn, BabbageTxOut ConwayEra)
genRefScriptUTxO = do
    TxIn
refIn <- TxIn -> TxIn
toLedgerTxIn (TxIn -> TxIn) -> Gen TxIn -> Gen TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
genTxIn
    TxOut CtxUTxO
out <- Gen (TxOut CtxUTxO)
forall ctx. Gen (TxOut ctx)
genTxOut
    let Api.TxOut AddressInEra
addr Value
value TxOutDatum CtxUTxO
datum ReferenceScript
_ = TxOut CtxUTxO
out
    let refOut :: TxOut
refOut = TxOut CtxUTxO -> TxOut
forall era.
(HasCallStack, IsShelleyBasedEra era) =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
Api.toLedgerTxOut (TxOut CtxUTxO -> TxOut) -> TxOut CtxUTxO -> TxOut
forall a b. (a -> b) -> a -> b
$ AddressInEra
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
Api.TxOut AddressInEra
addr Value
value TxOutDatum CtxUTxO
datum (PlutusScript PlutusScriptV3 -> ReferenceScript
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> ReferenceScript
Api.mkScriptRef PlutusScript PlutusScriptV3
dummyValidatorScript)
    (TxIn, BabbageTxOut ConwayEra)
-> Gen (TxIn, BabbageTxOut ConwayEra)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn
refIn, BabbageTxOut ConwayEra
TxOut
refOut)

hasReferenceScript :: BabbageTxOut ConwayEra -> Bool
hasReferenceScript :: BabbageTxOut ConwayEra -> Bool
hasReferenceScript BabbageTxOut ConwayEra
out =
  case BabbageTxOut ConwayEra
out of
    BabbageTxOut Address
_ Value ConwayEra
_ Datum ConwayEra
_ (Ledger.SJust Script ConwayEra
_) -> Bool
True
    BabbageTxOut ConwayEra
_ -> Bool
False

-- | Transactions that execute scripts while merely referencing unrelated ones
-- must hash only the executed scripts' language views into the script
-- integrity hash. The expected hash is recomputed here against an explicit
-- PlutusV3-only language set: if the unrelated (V2) reference script's
-- language view ever leaked into the hash, or the redeemers on the balanced
-- transaction were not the ones hashed, the comparison fails.
prop_unrelatedRefScriptDoesNotAffectIntegrityHash :: Property
prop_unrelatedRefScriptDoesNotAffectIntegrityHash :: Property
prop_unrelatedRefScriptDoesNotAffectIntegrityHash =
  Gen (Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
-> ((Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
    -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (Tx TopTx LedgerEra, Map TxIn TxOut)
Gen (Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
genTxExecutingScript (((Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
  -> Property)
 -> Property)
-> ((Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(Tx TopTx ConwayEra
tx, Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO) ->
    Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn (BabbageTxOut ConwayEra))
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. Gen a -> Gen a
reasonablySized Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Bool)
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
not (Bool -> Bool)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Bool)
-> Map TxIn (BabbageTxOut ConwayEra)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BabbageTxOut ConwayEra -> Bool)
-> Map TxIn (BabbageTxOut ConwayEra) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any BabbageTxOut ConwayEra -> Bool
isBootstrapOut)) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
walletUTxO ->
      Gen (TxIn, BabbageTxOut ConwayEra)
-> ((TxIn, BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (TxIn, BabbageTxOut ConwayEra)
Gen (TxIn, TxOut)
genUnrelatedRefScriptUTxO (((TxIn, BabbageTxOut ConwayEra) -> Property) -> Property)
-> ((TxIn, BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(TxIn
refIn, BabbageTxOut ConwayEra
refOut) -> do
        let txWithRefInput :: Tx TopTx ConwayEra
txWithRefInput = Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Set TxIn -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
refIn
        case PParams ConwayEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut ConwayEra)
-> Map TxIn (TxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Either ErrCoverFee (Tx TopTx ConwayEra)
forall era.
(EraPlutusContext era, EraCertState era, AlonzoEraTx era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Tx TopTx era
-> Either ErrCoverFee (Tx TopTx era)
coverFee_ PParams LedgerEra
PParams ConwayEra
Fixture.pparams SystemStart
Fixture.systemStart EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo (TxIn
-> BabbageTxOut ConwayEra
-> Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
refIn BabbageTxOut ConwayEra
refOut Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO) Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
walletUTxO Tx TopTx ConwayEra
txWithRefInput of
          Left ErrCoverFee
ErrNoFuelUTxOFound -> Discard -> Property
forall prop. Testable prop => prop -> Property
property Discard
Discard
          Left err :: ErrCoverFee
err@ErrNotEnoughFunds{} -> Discard -> Property
forall prop. Testable prop => prop -> Property
property Discard
Discard Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (ErrCoverFee -> String
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
err)
          Left ErrCoverFee
err ->
            Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Unexpected coverFee error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrCoverFee -> String
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
err)
          Right Tx TopTx ConwayEra
balancedTx ->
            let expected :: ScriptIntegrityHash
expected =
                  ScriptIntegrity ConwayEra -> ScriptIntegrityHash
forall era. Era era => ScriptIntegrity era -> ScriptIntegrityHash
hashScriptIntegrity (ScriptIntegrity ConwayEra -> ScriptIntegrityHash)
-> ScriptIntegrity ConwayEra -> ScriptIntegrityHash
forall a b. (a -> b) -> a -> b
$
                    Redeemers ConwayEra
-> TxDats ConwayEra -> Set LangDepView -> ScriptIntegrity ConwayEra
forall era.
Redeemers era
-> TxDats era -> Set LangDepView -> ScriptIntegrity era
ScriptIntegrity
                      (Tx TopTx ConwayEra
balancedTx Tx TopTx ConwayEra
-> Getting
     (Redeemers ConwayEra) (Tx TopTx ConwayEra) (Redeemers ConwayEra)
-> Redeemers ConwayEra
forall s a. s -> Getting a s a -> a
^. (TxWits ConwayEra
 -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
-> Tx TopTx ConwayEra
-> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra
 -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra
-> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra
  -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra))
-> ((Redeemers ConwayEra
     -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra
    -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
-> Getting
     (Redeemers ConwayEra) (Tx TopTx ConwayEra) (Redeemers ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> TxWits ConwayEra
-> Const (Redeemers ConwayEra) (TxWits ConwayEra)
(Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra
-> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL)
                      (Tx TopTx ConwayEra
balancedTx Tx TopTx ConwayEra
-> Getting
     (TxDats ConwayEra) (Tx TopTx ConwayEra) (TxDats ConwayEra)
-> TxDats ConwayEra
forall s a. s -> Getting a s a -> a
^. (TxWits ConwayEra -> Const (TxDats ConwayEra) (TxWits ConwayEra))
-> Tx TopTx ConwayEra
-> Const (TxDats ConwayEra) (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra
 -> Const (TxDats ConwayEra) (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra
-> Const (TxDats ConwayEra) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra
  -> Const (TxDats ConwayEra) (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (TxDats ConwayEra) (Tx TopTx ConwayEra))
-> ((TxDats ConwayEra
     -> Const (TxDats ConwayEra) (TxDats ConwayEra))
    -> AlonzoTxWits ConwayEra
    -> Const (TxDats ConwayEra) (AlonzoTxWits ConwayEra))
-> Getting
     (TxDats ConwayEra) (Tx TopTx ConwayEra) (TxDats ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats ConwayEra -> Const (TxDats ConwayEra) (TxDats ConwayEra))
-> TxWits ConwayEra -> Const (TxDats ConwayEra) (TxWits ConwayEra)
(TxDats ConwayEra -> Const (TxDats ConwayEra) (TxDats ConwayEra))
-> AlonzoTxWits ConwayEra
-> Const (TxDats ConwayEra) (AlonzoTxWits ConwayEra)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits ConwayEra) (TxDats ConwayEra)
datsTxWitsL)
                      (LangDepView -> Set LangDepView
forall a. a -> Set a
Set.singleton (LangDepView -> Set LangDepView) -> LangDepView -> Set LangDepView
forall a b. (a -> b) -> a -> b
$ PParams ConwayEra -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams LedgerEra
PParams ConwayEra
Fixture.pparams Language
PlutusV3)
             in ( (Tx TopTx ConwayEra
balancedTx Tx TopTx ConwayEra
-> Getting
     (StrictMaybe ScriptIntegrityHash)
     (Tx TopTx ConwayEra)
     (StrictMaybe ScriptIntegrityHash)
-> StrictMaybe ScriptIntegrityHash
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const
      (StrictMaybe ScriptIntegrityHash) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra
-> Const (StrictMaybe ScriptIntegrityHash) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const
       (StrictMaybe ScriptIntegrityHash) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (StrictMaybe ScriptIntegrityHash) (Tx TopTx ConwayEra))
-> ((StrictMaybe ScriptIntegrityHash
     -> Const
          (StrictMaybe ScriptIntegrityHash)
          (StrictMaybe ScriptIntegrityHash))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictMaybe ScriptIntegrityHash) (TxBody TopTx ConwayEra))
-> Getting
     (StrictMaybe ScriptIntegrityHash)
     (Tx TopTx ConwayEra)
     (StrictMaybe ScriptIntegrityHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Const
      (StrictMaybe ScriptIntegrityHash)
      (StrictMaybe ScriptIntegrityHash))
-> TxBody TopTx ConwayEra
-> Const (StrictMaybe ScriptIntegrityHash) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe ScriptIntegrityHash)
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL) StrictMaybe ScriptIntegrityHash
-> StrictMaybe ScriptIntegrityHash -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a. a -> StrictMaybe a
Ledger.SJust ScriptIntegrityHash
expected
                    Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Balanced tx: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx -> String
renderTx (Tx TopTx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx Tx TopTx LedgerEra
Tx TopTx ConwayEra
balancedTx))
                )
                  Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
                    String
"fixture no longer carries a reference script — property is vacuous"
                    (BabbageTxOut ConwayEra -> Bool
hasReferenceScript BabbageTxOut ConwayEra
refOut)
 where
  -- Byron-addressed outputs cannot be represented in a PlutusV3 script
  -- context, so a Byron fee input would fail script evaluation for reasons
  -- unrelated to this property.
  isBootstrapOut :: BabbageTxOut ConwayEra -> Bool
  isBootstrapOut :: BabbageTxOut ConwayEra -> Bool
isBootstrapOut (BabbageTxOut Address
addr Value ConwayEra
_ Datum ConwayEra
_ StrictMaybe (Script ConwayEra)
_) =
    case Address
addr of
      Ledger.AddrBootstrap{} -> Bool
True
      Address
_ -> Bool
False

  -- A transaction spending a UTxO locked by the always-succeeding dummy
  -- validator, with script witness and redeemer attached so the script
  -- actually executes. No datum: V3 spending scripts may go datum-less and
  -- the dummy validator does not expect one.
  genTxExecutingScript :: Gen (Tx TopTx LedgerEra, Map TxIn TxOut)
  genTxExecutingScript :: Gen (Tx TopTx LedgerEra, Map TxIn TxOut)
genTxExecutingScript = do
    TxIn
scriptTxIn <- TxIn -> TxIn
toLedgerTxIn (TxIn -> TxIn) -> Gen TxIn -> Gen TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
genTxIn
    Data LedgerEra
redeemerData :: Data LedgerEra <- Gen (Data ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary
    Tx TopTx ConwayEra
baseTx <- Int -> Gen (Tx TopTx ConwayEra) -> Gen (Tx TopTx ConwayEra)
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
0 Gen (Tx TopTx LedgerEra)
Gen (Tx TopTx ConwayEra)
genLedgerTx
    let script :: AlonzoScript LedgerEra
script = forall lang era.
ToAlonzoScript lang era =>
PlutusScript lang -> AlonzoScript (ShelleyLedgerEra era)
Api.toLedgerScript @_ @Api.Era PlutusScript PlutusScriptV3
dummyValidatorScript
        scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @LedgerEra Script LedgerEra
AlonzoScript ConwayEra
script
        scriptTxOut :: TxOut
scriptTxOut =
          TxOut CtxUTxO -> TxOut
forall era.
(HasCallStack, IsShelleyBasedEra era) =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
Api.toLedgerTxOut (TxOut CtxUTxO -> TxOut) -> TxOut CtxUTxO -> TxOut
forall a b. (a -> b) -> a -> b
$
            AddressInEra
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
Api.TxOut
              (NetworkId -> PlutusScript PlutusScriptV3 -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
Api.mkScriptAddress NetworkId
Fixture.testNetworkId PlutusScript PlutusScriptV3
dummyValidatorScript)
              (Coin -> Value
Api.lovelaceToValue (Integer -> Coin
Coin Integer
20_000_000))
              TxOutDatum CtxUTxO
forall ctx. TxOutDatum ctx
Api.TxOutDatumNone
              ReferenceScript
Api.ReferenceScriptNone
        redeemers :: Redeemers ConwayEra
redeemers = Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
 -> Redeemers ConwayEra)
-> Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall a b. (a -> b) -> a -> b
$ PlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits)
-> Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a. k -> a -> Map k a
Map.singleton (AsIx Word32 TxIn -> PlutusPurpose AsIx ConwayEra
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0)) (Data LedgerEra
Data ConwayEra
redeemerData, Natural -> Natural -> ExUnits
ExUnits Natural
0 Natural
0)
        txExecutingScript :: Tx TopTx ConwayEra
txExecutingScript =
          Tx TopTx ConwayEra
baseTx
            Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Set TxIn -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
scriptTxIn
            Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictSeq (BabbageTxOut ConwayEra)
    -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (BabbageTxOut ConwayEra)
 -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL ((StrictSeq (BabbageTxOut ConwayEra)
  -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (BabbageTxOut ConwayEra)
forall a. Monoid a => a
mempty
            Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
(Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Redeemers ConwayEra -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers ConwayEra
redeemers
            Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((TxDats ConwayEra -> Identity (TxDats ConwayEra))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (TxDats ConwayEra -> Identity (TxDats ConwayEra))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats ConwayEra -> Identity (TxDats ConwayEra))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
(TxDats ConwayEra -> Identity (TxDats ConwayEra))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits ConwayEra) (TxDats ConwayEra)
datsTxWitsL ((TxDats ConwayEra -> Identity (TxDats ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> TxDats ConwayEra -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxDats ConwayEra
forall a. Monoid a => a
mempty
            Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Map ScriptHash (Script ConwayEra)
     -> Identity (Map ScriptHash (AlonzoScript ConwayEra)))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Map ScriptHash (Script ConwayEra)
    -> Identity (Map ScriptHash (AlonzoScript ConwayEra)))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script ConwayEra)
 -> Identity (Map ScriptHash (Script ConwayEra)))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
(Map ScriptHash (Script ConwayEra)
 -> Identity (Map ScriptHash (AlonzoScript ConwayEra)))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits ConwayEra) (Map ScriptHash (Script ConwayEra))
scriptTxWitsL ((Map ScriptHash (Script ConwayEra)
  -> Identity (Map ScriptHash (AlonzoScript ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Map ScriptHash (AlonzoScript ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScriptHash
-> AlonzoScript ConwayEra
-> Map ScriptHash (AlonzoScript ConwayEra)
forall k a. k -> a -> Map k a
Map.singleton ScriptHash
scriptHash AlonzoScript ConwayEra
script
    (Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
-> Gen (Tx TopTx ConwayEra, Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx TopTx ConwayEra
txExecutingScript, TxIn -> BabbageTxOut ConwayEra -> Map TxIn (BabbageTxOut ConwayEra)
forall k a. k -> a -> Map k a
Map.singleton TxIn
scriptTxIn BabbageTxOut ConwayEra
scriptTxOut)

  -- A UTxO carrying a PlutusV2-tagged reference script that the transaction
  -- never executes. The distinct language is what makes this test
  -- discriminating: a V3 reference script would produce the same
  -- language-view set even if it wrongly leaked into the integrity hash.
  genUnrelatedRefScriptUTxO :: Gen (TxIn, TxOut)
  genUnrelatedRefScriptUTxO :: Gen (TxIn, TxOut)
genUnrelatedRefScriptUTxO = do
    TxIn
refIn <- TxIn -> TxIn
toLedgerTxIn (TxIn -> TxIn) -> Gen TxIn -> Gen TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
genTxIn
    TxOut CtxUTxO
out <- Gen (TxOut CtxUTxO)
forall ctx. Gen (TxOut ctx)
genTxOut
    let Api.TxOut AddressInEra
addr Value
value TxOutDatum CtxUTxO
datum ReferenceScript
_ = TxOut CtxUTxO
out
    let refOut :: TxOut
refOut = TxOut CtxUTxO -> TxOut
forall era.
(HasCallStack, IsShelleyBasedEra era) =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
Api.toLedgerTxOut (TxOut CtxUTxO -> TxOut) -> TxOut CtxUTxO -> TxOut
forall a b. (a -> b) -> a -> b
$ AddressInEra
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
Api.TxOut AddressInEra
addr Value
value TxOutDatum CtxUTxO
datum (PlutusScript PlutusScriptV2 -> ReferenceScript
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> ReferenceScript
Api.mkScriptRef PlutusScript PlutusScriptV2
unrelatedV2Script)
    (TxIn, BabbageTxOut ConwayEra)
-> Gen (TxIn, BabbageTxOut ConwayEra)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn
refIn, BabbageTxOut ConwayEra
TxOut
refOut)

  -- Merely carried and never executed or validated, so the bytes need not be
  -- a runnable V2 program; only the language tag matters.
  unrelatedV2Script :: CApi.PlutusScript CApi.PlutusScriptV2
  unrelatedV2Script :: PlutusScript PlutusScriptV2
unrelatedV2Script =
    let Api.PlutusScriptSerialised ShortByteString
bytes = PlutusScript PlutusScriptV3
dummyValidatorScript
     in ShortByteString -> PlutusScript PlutusScriptV2
forall lang. ShortByteString -> PlutusScript lang
CApi.PlutusScriptSerialised ShortByteString
bytes