{-# OPTIONS_GHC -Wno-missing-local-signatures #-}

-- | Remainder of tests covering observation and tx creation by the "direct"
-- chain component.
-- XXX: This does not have a corresponding "source" module which it tests.
module Hydra.Chain.Direct.TxSpec where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (label)
import Test.Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..))
import Cardano.Ledger.Api (
  ConwayPlutusPurpose (ConwayRewarding, ConwaySpending),
  IsValid (..),
  Metadatum,
  TxAuxData,
  ValidityInterval (..),
  auxDataHashTxBodyL,
  auxDataTxL,
  bodyTxL,
  hashTxAuxData,
  inputsTxBodyL,
  isValidTxL,
  outputsTxBodyL,
  ppProtocolVersionL,
  rdmrsTxWitsL,
  referenceInputsTxBodyL,
  reqSignerHashesTxBodyL,
  unRedeemers,
  validateTxAuxData,
  vldtTxBodyL,
  witsTxL,
  pattern ShelleyTxAuxData,
 )
import Cardano.Ledger.Api qualified as Ledger
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Val (pointwise)
import Control.Lens ((.~), (^.))
import Data.Map.Strict qualified as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Set qualified as Set
import Hydra.Cardano.Api.Pretty (renderTxWithUTxO)
import Hydra.Chain.Direct.State (HasKnownUTxO (getKnownUTxO))
import Hydra.Contract.Dummy (dummyRewardingScript, dummyValidatorScript)
import Hydra.Ledger.Cardano.Builder (addTxInsSpending, unsafeBuildTransaction)
import Hydra.Ledger.Cardano.Time (slotNoToUTCTime)
import Hydra.Tx.BlueprintTx (CommitBlueprintTx (..))
import Hydra.Tx.Deposit (depositTx)
import Hydra.Tx.HeadId (mkHeadId)
import Hydra.Tx.Observe (HeadObservation (..), observeHeadTx)
import Test.Cardano.Ledger.Shelley.Arbitrary (genMetadata')
import Test.Gen.Cardano.Api.Typed qualified as Gen
import Test.Hydra.Chain.Direct.State (genChainStateWithTx)
import Test.Hydra.Chain.Direct.State qualified as Transition
import Test.Hydra.Tx.Fixture (
  pparams,
  testNetworkId,
 )
import Test.Hydra.Tx.Fixture qualified as Fixture
import Test.Hydra.Tx.Gen (
  genTxOut,
  genTxOutWithReferenceScript,
  genUTxO1,
  genUTxOAdaOnlyOfSize,
  genValue,
  propTransactionEvaluates,
 )
import Test.QuickCheck (
  Property,
  checkCoverage,
  choose,
  conjoin,
  counterexample,
  cover,
  forAll,
  forAllBlind,
  forAllShow,
  oneof,
  property,
  (.&&.),
  (===),
 )
import Test.QuickCheck.Hedgehog (hedgehog)
import Test.QuickCheck.Instances.Semigroup ()

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
    -- TODO: DRY with prop_observeAnyTx
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"observeHeadTx" (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
"Invalid transactions are never observed" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- state transition happened.
        -- state transition happened.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.
        -- state transition happened.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- state transition happened.
        -- state transition happened.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- This is sufficient to simulate an where and adversary would create a
        -- This is sufficient to simulate an where and adversary would create a
        -- transaction that looks like a proper transaction, but not entirely and
        -- transaction that looks like a proper transaction, but not entirely and
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- state transition happened.
        -- state transition happened.

        -- NOTE: Generate a valid state transition, but then mark it as invalid.
        -- This is sufficient to simulate an where and adversary would create a
        -- transaction that looks like a proper transaction, but not entirely and
        -- scripts would fail, but deliberately marks the tx as invalid (only at
        -- the expense of collateral) to trick the hydra-node into thinking the
        -- state transition happened.
        Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genChainStateWithTx (((ChainContext, ChainState, UTxO, Tx, ChainTransition)
  -> Property)
 -> Property)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
_ctx, ChainState
st, UTxO
additionalUTxO, Tx
validTx, ChainTransition
transition) ->
          Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChainTransition] -> Property -> Property
forall a prop.
(Show a, Enum a, Bounded a, Typeable a, Testable prop) =>
[a] -> prop -> Property
genericCoverTable [ChainTransition
transition] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            let utxo :: UTxO
utxo = ChainState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainState
st UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
additionalUTxO
                tx :: Tx
tx = Tx TopTx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx TopTx LedgerEra -> Tx) -> Tx TopTx LedgerEra -> Tx
forall a b. (a -> b) -> a -> b
$ Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
validTx Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (IsValid -> Identity IsValid)
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx ConwayEra) IsValid
isValidTxL ((IsValid -> Identity IsValid)
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> IsValid -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> IsValid
IsValid Bool
False
             in NetworkId -> UTxO -> Tx -> HeadObservation
observeHeadTx NetworkId
testNetworkId UTxO
utxo Tx
tx HeadObservation -> HeadObservation -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== HeadObservation
NoHeadTx

      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"All valid transitions for all possible states can be observed." (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genChainStateWithTx (((ChainContext, ChainState, UTxO, Tx, ChainTransition)
  -> Property)
 -> Property)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
_ctx, ChainState
st, UTxO
additionalUTxO, Tx
tx, ChainTransition
transition) ->
            [ChainTransition] -> Property -> Property
forall a prop.
(Show a, Enum a, Bounded a, Typeable a, Testable prop) =>
[a] -> prop -> Property
genericCoverTable [ChainTransition
transition] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
              String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (ChainTransition -> String
forall b a. (Show a, IsString b) => a -> b
show ChainTransition
transition) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                let utxo :: UTxO
utxo = ChainState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainState
st UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
additionalUTxO
                 in case NetworkId -> UTxO -> Tx -> HeadObservation
observeHeadTx NetworkId
testNetworkId UTxO
utxo Tx
tx of
                      HeadObservation
NoHeadTx -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                      Init{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Init
                      Deposit{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Deposit
                      Recover{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Recover
                      Increment{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Increment
                      Decrement{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Decrement
                      Close{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Close
                      Contest{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Contest
                      PartialFanout{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.PartialFanout
                      Fanout{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Fanout
                      FinalPartialFanout{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.FinalPartialFanout

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"depositTx" (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
"genBlueprintTx generates interesting txs" Property
prop_interestingBlueprintTx

      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"creates valid txs from blueprint" Property
prop_validDepositTx

-- | Transactions produced by 'depositTx' provided with arbitrary, valid
-- blueprint txs, are valid.
prop_validDepositTx :: Property
prop_validDepositTx :: Property
prop_validDepositTx = do
  -- These are not under test here and known good values
  let depositSlot :: SlotNo
depositSlot = SlotNo
0
      depositDeadline :: UTCTime
depositDeadline = SystemStart -> SlotLength -> SlotNo -> UTCTime
slotNoToUTCTime SystemStart
Fixture.systemStart SlotLength
Fixture.slotLength SlotNo
100
  Gen (UTxO, Tx) -> ((UTxO, Tx) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (UTxO, Tx)
genBlueprintTxWithUTxO (((UTxO, Tx) -> Property) -> Property)
-> ((UTxO, Tx) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO
lookupUTxO, Tx
blueprintTx) ->
    Gen (Maybe AddressInEra)
-> (Maybe AddressInEra -> String)
-> (Maybe AddressInEra -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow Gen (Maybe AddressInEra)
forall a. Arbitrary a => Gen a
arbitrary Maybe AddressInEra -> String
forall {addr}. SerialiseAddress addr => Maybe addr -> String
showChangeAddress ((Maybe AddressInEra -> Property) -> Property)
-> (Maybe AddressInEra -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Maybe AddressInEra
mayChangeAddress ->
      String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Blueprint tx: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
blueprintTx) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ do
        let createdTx :: Tx
createdTx =
              HasCallStack =>
NetworkId
-> PParams LedgerEra
-> HeadId
-> CommitBlueprintTx Tx
-> SlotNo
-> UTCTime
-> Maybe AddressInEra
-> Tx
NetworkId
-> PParams LedgerEra
-> HeadId
-> CommitBlueprintTx Tx
-> SlotNo
-> UTCTime
-> Maybe AddressInEra
-> Tx
depositTx
                NetworkId
testNetworkId
                PParams LedgerEra
Fixture.pparams
                (PolicyId -> HeadId
mkHeadId PolicyId
Fixture.testPolicyId)
                CommitBlueprintTx{UTxOType Tx
UTxO
lookupUTxO :: UTxO
$sel:lookupUTxO:CommitBlueprintTx :: UTxOType Tx
lookupUTxO, Tx
blueprintTx :: Tx
$sel:blueprintTx:CommitBlueprintTx :: Tx
blueprintTx}
                SlotNo
depositSlot
                UTCTime
depositDeadline
                Maybe AddressInEra
mayChangeAddress
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"\n\n\nDeposit tx: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
createdTx) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ do
          let blueprintBody :: TxBody TopTx ConwayEra
blueprintBody = Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx Tx TopTx ConwayEra
-> Getting
     (TxBody TopTx ConwayEra)
     (Tx TopTx ConwayEra)
     (TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall s a. s -> Getting a s a -> a
^. Getting
  (TxBody TopTx ConwayEra)
  (Tx TopTx ConwayEra)
  (TxBody 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
          let depositTxBody :: TxBody TopTx ConwayEra
depositTxBody = Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
createdTx Tx TopTx ConwayEra
-> Getting
     (TxBody TopTx ConwayEra)
     (Tx TopTx ConwayEra)
     (TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall s a. s -> Getting a s a -> a
^. Getting
  (TxBody TopTx ConwayEra)
  (Tx TopTx ConwayEra)
  (TxBody 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
          let spendableUTxO :: UTxO
spendableUTxO = UTxO
lookupUTxO
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
            [ (Tx, UTxO) -> Property
propTransactionEvaluates (Tx
blueprintTx, UTxO
lookupUTxO)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Blueprint transaction failed to evaluate"
            , (Tx, UTxO) -> Property
propTransactionEvaluates (Tx
createdTx, UTxO
spendableUTxO)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Deposit transaction failed to evaluate"
            , [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                [ Tx -> Map Word64 Metadatum
getAuxMetadata Tx
blueprintTx Map Word64 Metadatum -> Map Word64 Metadatum -> Property
forall k v.
(Show k, Show v, Ord k, Eq v) =>
Map k v -> Map k v -> Property
`propIsSubmapOf` Tx -> Map Word64 Metadatum
getAuxMetadata Tx
createdTx
                    Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Blueprint metadata incomplete"
                , Tx -> Property
propHasValidAuxData Tx
blueprintTx
                    Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Blueprint tx has invalid aux data"
                , Tx -> Property
propHasValidAuxData Tx
createdTx
                    Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Deposit tx has invalid aux data"
                ]
            , TxBody TopTx ConwayEra
depositTxBody TxBody TopTx ConwayEra
-> Getting
     ValidityInterval (TxBody TopTx ConwayEra) ValidityInterval
-> ValidityInterval
forall s a. s -> Getting a s a -> a
^. Getting ValidityInterval (TxBody TopTx ConwayEra) ValidityInterval
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) ValidityInterval
vldtTxBodyL ValidityInterval -> ValidityInterval -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ValidityInterval{invalidBefore :: StrictMaybe SlotNo
invalidBefore = StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing, invalidHereafter :: StrictMaybe SlotNo
invalidHereafter = SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
depositSlot}
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Validity range overridden by blueprint"
            , (TxBody TopTx ConwayEra
blueprintBody TxBody TopTx ConwayEra
-> Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
-> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL) Set TxIn -> Set TxIn -> Property
forall a. (Show a, Ord a) => Set a -> Set a -> Property
`propIsSubsetOf` (TxBody TopTx ConwayEra
depositTxBody TxBody TopTx ConwayEra
-> Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
-> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Blueprint inputs missing"
            , Tx -> Int
forall {era}.
(Assert
   (OrdCond
      (CmpNat
         (ProtVerLow (ShelleyLedgerEra era))
         (ProtVerHigh (ShelleyLedgerEra era)))
      'True
      'True
      'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat 0 (ProtVerLow (ShelleyLedgerEra era))) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat 0 (ProtVerHigh (ShelleyLedgerEra era))) 'True 'True 'False)
   (TypeError ...),
 EraTx (ShelleyLedgerEra era),
 AlonzoEraTxWits (ShelleyLedgerEra era)) =>
Tx era -> Int
redeemerCount Tx
blueprintTx Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Tx -> Int
forall {era}.
(Assert
   (OrdCond
      (CmpNat
         (ProtVerLow (ShelleyLedgerEra era))
         (ProtVerHigh (ShelleyLedgerEra era)))
      'True
      'True
      'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat 0 (ProtVerLow (ShelleyLedgerEra era))) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat 0 (ProtVerHigh (ShelleyLedgerEra era))) 'True 'True 'False)
   (TypeError ...),
 EraTx (ShelleyLedgerEra era),
 AlonzoEraTxWits (ShelleyLedgerEra era)) =>
Tx era -> Int
redeemerCount Tx
createdTx
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Blueprint redeemers missing"
            , Bool -> Property
forall prop. Testable prop => prop -> Property
property
                (((BabbageTxOut ConwayEra -> Bool)
-> StrictSeq (BabbageTxOut ConwayEra) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`all` (TxBody TopTx ConwayEra
blueprintBody TxBody TopTx ConwayEra
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (TxBody TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (TxBody TopTx ConwayEra)
  (StrictSeq (BabbageTxOut 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)) (BabbageTxOut ConwayEra
-> StrictSeq (BabbageTxOut ConwayEra) -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` (TxBody TopTx ConwayEra
depositTxBody TxBody TopTx ConwayEra
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (TxBody TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (TxBody TopTx ConwayEra)
  (StrictSeq (BabbageTxOut 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)))
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Blueprint outputs not discarded"
            , (TxBody TopTx ConwayEra
blueprintBody TxBody TopTx ConwayEra
-> Getting
     (Set (KeyHash Guard))
     (TxBody TopTx ConwayEra)
     (Set (KeyHash Guard))
-> Set (KeyHash Guard)
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (KeyHash Guard))
  (TxBody TopTx ConwayEra)
  (Set (KeyHash Guard))
forall era (l :: TxLevel).
(AlonzoEraTxBody era, AtMostEra "Conway" era) =>
Lens' (TxBody l era) (Set (KeyHash Guard))
forall (l :: TxLevel).
AtMostEra "Conway" ConwayEra =>
Lens' (TxBody l ConwayEra) (Set (KeyHash Guard))
Lens' (TxBody TopTx ConwayEra) (Set (KeyHash Guard))
Cardano.Ledger.Api.reqSignerHashesTxBodyL) Set (KeyHash Guard) -> Set (KeyHash Guard) -> Property
forall a. (Show a, Ord a) => Set a -> Set a -> Property
`propIsSubsetOf` (TxBody TopTx ConwayEra
depositTxBody TxBody TopTx ConwayEra
-> Getting
     (Set (KeyHash Guard))
     (TxBody TopTx ConwayEra)
     (Set (KeyHash Guard))
-> Set (KeyHash Guard)
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (KeyHash Guard))
  (TxBody TopTx ConwayEra)
  (Set (KeyHash Guard))
forall era (l :: TxLevel).
(AlonzoEraTxBody era, AtMostEra "Conway" era) =>
Lens' (TxBody l era) (Set (KeyHash Guard))
forall (l :: TxLevel).
AtMostEra "Conway" ConwayEra =>
Lens' (TxBody l ConwayEra) (Set (KeyHash Guard))
Lens' (TxBody TopTx ConwayEra) (Set (KeyHash Guard))
Cardano.Ledger.Api.reqSignerHashesTxBodyL)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Blueprint required signatures missing"
            , (TxBody TopTx ConwayEra
blueprintBody TxBody TopTx ConwayEra
-> Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
-> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
Cardano.Ledger.Api.referenceInputsTxBodyL) Set TxIn -> Set TxIn -> Property
forall a. (Show a, Ord a) => Set a -> Set a -> Property
`propIsSubsetOf` (TxBody TopTx ConwayEra
depositTxBody TxBody TopTx ConwayEra
-> Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
-> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
Cardano.Ledger.Api.referenceInputsTxBodyL)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Blueprint reference inputs missing"
            ]
 where
  redeemerCount :: Tx era -> Int
redeemerCount Tx era
tx = Map
  (PlutusPurpose AsIx (ShelleyLedgerEra era))
  (Data (ShelleyLedgerEra era), ExUnits)
-> Int
forall a. Map (PlutusPurpose AsIx (ShelleyLedgerEra era)) a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map
   (PlutusPurpose AsIx (ShelleyLedgerEra era))
   (Data (ShelleyLedgerEra era), ExUnits)
 -> Int)
-> Map
     (PlutusPurpose AsIx (ShelleyLedgerEra era))
     (Data (ShelleyLedgerEra era), ExUnits)
-> Int
forall a b. (a -> b) -> a -> b
$ Tx era -> Tx TopTx (ShelleyLedgerEra era)
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx era
tx Tx TopTx (ShelleyLedgerEra era)
-> Getting
     (Redeemers (ShelleyLedgerEra era))
     (Tx TopTx (ShelleyLedgerEra era))
     (Redeemers (ShelleyLedgerEra era))
-> Redeemers (ShelleyLedgerEra era)
forall s a. s -> Getting a s a -> a
^. (TxWits (ShelleyLedgerEra era)
 -> Const
      (Redeemers (ShelleyLedgerEra era)) (TxWits (ShelleyLedgerEra era)))
-> Tx TopTx (ShelleyLedgerEra era)
-> Const
     (Redeemers (ShelleyLedgerEra era))
     (Tx TopTx (ShelleyLedgerEra era))
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel).
Lens' (Tx l (ShelleyLedgerEra era)) (TxWits (ShelleyLedgerEra era))
witsTxL ((TxWits (ShelleyLedgerEra era)
  -> Const
       (Redeemers (ShelleyLedgerEra era)) (TxWits (ShelleyLedgerEra era)))
 -> Tx TopTx (ShelleyLedgerEra era)
 -> Const
      (Redeemers (ShelleyLedgerEra era))
      (Tx TopTx (ShelleyLedgerEra era)))
-> ((Redeemers (ShelleyLedgerEra era)
     -> Const
          (Redeemers (ShelleyLedgerEra era))
          (Redeemers (ShelleyLedgerEra era)))
    -> TxWits (ShelleyLedgerEra era)
    -> Const
         (Redeemers (ShelleyLedgerEra era)) (TxWits (ShelleyLedgerEra era)))
-> Getting
     (Redeemers (ShelleyLedgerEra era))
     (Tx TopTx (ShelleyLedgerEra era))
     (Redeemers (ShelleyLedgerEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers (ShelleyLedgerEra era)
 -> Const
      (Redeemers (ShelleyLedgerEra era))
      (Redeemers (ShelleyLedgerEra era)))
-> TxWits (ShelleyLedgerEra era)
-> Const
     (Redeemers (ShelleyLedgerEra era)) (TxWits (ShelleyLedgerEra era))
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens'
  (TxWits (ShelleyLedgerEra era)) (Redeemers (ShelleyLedgerEra era))
rdmrsTxWitsL Redeemers (ShelleyLedgerEra era)
-> (Redeemers (ShelleyLedgerEra era)
    -> Map
         (PlutusPurpose AsIx (ShelleyLedgerEra era))
         (Data (ShelleyLedgerEra era), ExUnits))
-> Map
     (PlutusPurpose AsIx (ShelleyLedgerEra era))
     (Data (ShelleyLedgerEra era), ExUnits)
forall a b. a -> (a -> b) -> b
& Redeemers (ShelleyLedgerEra era)
-> Map
     (PlutusPurpose AsIx (ShelleyLedgerEra era))
     (Data (ShelleyLedgerEra era), ExUnits)
forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
unRedeemers

  showChangeAddress :: Maybe addr -> String
showChangeAddress Maybe addr
Nothing = String
"No change address"
  showChangeAddress (Just addr
a) = String
"Change address: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString (addr -> Text
forall addr. SerialiseAddress addr => addr -> Text
serialiseAddress addr
a)

-- | Check auxiliary data of a transaction against 'pparams' and whether the aux
-- data hash is consistent.
propHasValidAuxData :: Tx -> Property
propHasValidAuxData :: Tx -> Property
propHasValidAuxData Tx
tx =
  case Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx Tx TopTx ConwayEra
-> Getting
     (StrictMaybe (TxAuxData ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictMaybe (TxAuxData ConwayEra))
-> StrictMaybe (TxAuxData ConwayEra)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (TxAuxData ConwayEra))
  (Tx TopTx ConwayEra)
  (StrictMaybe (TxAuxData ConwayEra))
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l ConwayEra) (StrictMaybe (TxAuxData ConwayEra))
auxDataTxL of
    StrictMaybe (TxAuxData ConwayEra)
SNothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    SJust TxAuxData ConwayEra
auxData ->
      TxAuxData ConwayEra -> Property
isValid TxAuxData ConwayEra
auxData Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. TxAuxData ConwayEra -> Property
hashConsistent TxAuxData ConwayEra
auxData
 where
  isValid :: TxAuxData Ledger.ConwayEra -> Property
  isValid :: TxAuxData ConwayEra -> Property
isValid TxAuxData ConwayEra
auxData =
    ProtVer -> TxAuxData ConwayEra -> Bool
forall era. EraTxAuxData era => ProtVer -> TxAuxData era -> Bool
validateTxAuxData (PParams LedgerEra
PParams ConwayEra
pparams PParams ConwayEra
-> Getting ProtVer (PParams ConwayEra) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams ConwayEra) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams ConwayEra) ProtVer
ppProtocolVersionL) TxAuxData ConwayEra
auxData
      Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Auxiliary data validation failed"

  hashConsistent :: TxAuxData ConwayEra -> Property
hashConsistent TxAuxData ConwayEra
auxData =
    Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx Tx TopTx ConwayEra
-> Getting
     (StrictMaybe TxAuxDataHash)
     (Tx TopTx ConwayEra)
     (StrictMaybe TxAuxDataHash)
-> StrictMaybe TxAuxDataHash
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const (StrictMaybe TxAuxDataHash) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra
-> Const (StrictMaybe TxAuxDataHash) (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 TxAuxDataHash) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (StrictMaybe TxAuxDataHash) (Tx TopTx ConwayEra))
-> ((StrictMaybe TxAuxDataHash
     -> Const (StrictMaybe TxAuxDataHash) (StrictMaybe TxAuxDataHash))
    -> TxBody TopTx ConwayEra
    -> Const (StrictMaybe TxAuxDataHash) (TxBody TopTx ConwayEra))
-> Getting
     (StrictMaybe TxAuxDataHash)
     (Tx TopTx ConwayEra)
     (StrictMaybe TxAuxDataHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash
 -> Const (StrictMaybe TxAuxDataHash) (StrictMaybe TxAuxDataHash))
-> TxBody TopTx ConwayEra
-> Const (StrictMaybe TxAuxDataHash) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL StrictMaybe TxAuxDataHash -> StrictMaybe TxAuxDataHash -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxAuxDataHash -> StrictMaybe TxAuxDataHash
forall a. a -> StrictMaybe a
SJust (TxAuxData ConwayEra -> TxAuxDataHash
forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData TxAuxData ConwayEra
auxData)
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Auxiliary data hash inconsistent"

-- | Check whether one set 'isSubsetOf' of another with nice counter examples.
propIsSubsetOf :: (Show a, Ord a) => Set a -> Set a -> Property
propIsSubsetOf :: forall a. (Show a, Ord a) => Set a -> Set a -> Property
propIsSubsetOf Set a
as Set a
bs =
  Set a
as Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set a
bs
    Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Set a -> String
forall b a. (Show a, IsString b) => a -> b
show Set a
as String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n  is not a subset of\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Set a -> String
forall b a. (Show a, IsString b) => a -> b
show Set a
bs)

-- | Check whether one map 'isSubmapOf' of another with nice counter examples.
propIsSubmapOf :: (Show k, Show v, Ord k, Eq v) => Map k v -> Map k v -> Property
propIsSubmapOf :: forall k v.
(Show k, Show v, Ord k, Eq v) =>
Map k v -> Map k v -> Property
propIsSubmapOf Map k v
as Map k v
bs =
  Map k v
as Map k v -> Map k v -> Bool
forall k a. (Ord k, Eq a) => Map k a -> Map k a -> Bool
`Map.isSubmapOf` Map k v
bs
    Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Map k v -> String
forall b a. (Show a, IsString b) => a -> b
show Map k v
as String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n  is not a submap of\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map k v -> String
forall b a. (Show a, IsString b) => a -> b
show Map k v
bs)

genBlueprintTxWithUTxO :: Gen (UTxO, Tx)
genBlueprintTxWithUTxO :: Gen (UTxO, Tx)
genBlueprintTxWithUTxO =
  ((UTxO, TxBodyContent BuildTx) -> (UTxO, Tx))
-> Gen (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, Tx)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TxBodyContent BuildTx -> Tx)
-> (UTxO, TxBodyContent BuildTx) -> (UTxO, Tx)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction) (Gen (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, Tx))
-> Gen (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, Tx)
forall a b. (a -> b) -> a -> b
$
    (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
spendingPubKeyOutput (UTxO
forall a. Monoid a => a
mempty, TxBodyContent BuildTx
defaultTxBodyContent)
      Gen (UTxO, TxBodyContent BuildTx)
-> ((UTxO, TxBodyContent BuildTx)
    -> Gen (UTxO, TxBodyContent BuildTx))
-> Gen (UTxO, TxBodyContent BuildTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
spendSomeScriptInputs
      Gen (UTxO, TxBodyContent BuildTx)
-> ((UTxO, TxBodyContent BuildTx)
    -> Gen (UTxO, TxBodyContent BuildTx))
-> Gen (UTxO, TxBodyContent BuildTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
addSomeReferenceInputs
      Gen (UTxO, TxBodyContent BuildTx)
-> ((UTxO, TxBodyContent BuildTx)
    -> Gen (UTxO, TxBodyContent BuildTx))
-> Gen (UTxO, TxBodyContent BuildTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
addValidityRange
      Gen (UTxO, TxBodyContent BuildTx)
-> ((UTxO, TxBodyContent BuildTx)
    -> Gen (UTxO, TxBodyContent BuildTx))
-> Gen (UTxO, TxBodyContent BuildTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
addRandomMetadata
      Gen (UTxO, TxBodyContent BuildTx)
-> ((UTxO, TxBodyContent BuildTx)
    -> Gen (UTxO, TxBodyContent BuildTx))
-> Gen (UTxO, TxBodyContent BuildTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
addCollateralInput
      Gen (UTxO, TxBodyContent BuildTx)
-> ((UTxO, TxBodyContent BuildTx)
    -> Gen (UTxO, TxBodyContent BuildTx))
-> Gen (UTxO, TxBodyContent BuildTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
sometimesAddRewardRedeemer
      Gen (UTxO, TxBodyContent BuildTx)
-> ((UTxO, TxBodyContent BuildTx)
    -> Gen (UTxO, TxBodyContent BuildTx))
-> Gen (UTxO, TxBodyContent BuildTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
forall {build}.
(UTxO, TxBodyContent build) -> Gen (UTxO, TxBodyContent build)
sometimesExtractsValue
 where
  spendingPubKeyOutput :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
spendingPubKeyOutput (UTxO
utxo, TxBodyContent BuildTx
txbody) = do
    UTxO
utxoToSpend <- Int -> Gen UTxO
genUTxOAdaOnlyOfSize (Int -> Gen UTxO) -> Gen Int -> Gen UTxO
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
3)
    (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( UTxO
utxo UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
utxoToSpend
      , TxBodyContent BuildTx
txbody TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addTxInsSpending (Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set TxIn -> [TxIn]) -> Set TxIn -> [TxIn]
forall a b. (a -> b) -> a -> b
$ UTxO -> Set TxIn
forall era. UTxO era -> Set TxIn
UTxO.inputSet UTxO
utxoToSpend)
      )

  spendSomeScriptInputs :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
spendSomeScriptInputs (UTxO
utxo, TxBodyContent BuildTx
txbody) = do
    let alwaysSucceedingScript :: PlutusScript
alwaysSucceedingScript = PlutusScript
dummyValidatorScript
    HashableScriptData
datum <- ScriptData -> HashableScriptData
unsafeHashableScriptData (ScriptData -> HashableScriptData)
-> (Data -> ScriptData) -> Data -> HashableScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> ScriptData
fromPlutusData (Data -> HashableScriptData) -> Gen Data -> Gen HashableScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Data
forall a. Arbitrary a => Gen a
arbitrary
    HashableScriptData
redeemer <- ScriptData -> HashableScriptData
unsafeHashableScriptData (ScriptData -> HashableScriptData)
-> (Data -> ScriptData) -> Data -> HashableScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> ScriptData
fromPlutusData (Data -> HashableScriptData) -> Gen Data -> Gen HashableScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Data
forall a. Arbitrary a => Gen a
arbitrary
    let genTxOutScript :: Gen (TxOut CtxUTxO)
genTxOutScript = do
          Value
value <- Gen Value
genValue
          let scriptAddress :: AddressInEra
scriptAddress = NetworkId -> PlutusScript -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
testNetworkId PlutusScript
alwaysSucceedingScript
          TxOut CtxUTxO -> Gen (TxOut CtxUTxO)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut CtxUTxO -> Gen (TxOut CtxUTxO))
-> TxOut CtxUTxO -> Gen (TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ AddressInEra
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
scriptAddress Value
value (HashableScriptData -> TxOutDatum CtxUTxO
forall ctx. HashableScriptData -> TxOutDatum ctx
TxOutDatumInline HashableScriptData
datum) ReferenceScript
ReferenceScriptNone
    UTxO
utxoToSpend <- Gen (TxOut CtxUTxO) -> Gen UTxO
genUTxO1 Gen (TxOut CtxUTxO)
genTxOutScript
    (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( UTxO
utxo UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
utxoToSpend
      , TxBodyContent BuildTx
txbody
          TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns
            ( ((TxIn, TxOut CtxUTxO)
 -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)))
-> [(TxIn, TxOut CtxUTxO)] -> TxIns BuildTx Era
forall a b. (a -> b) -> [a] -> [b]
map
                ( \(TxIn
x, TxOut CtxUTxO
_) ->
                    ( TxIn
x
                    , Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
                        ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
ScriptWitnessForSpending (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
                          PlutusScript
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
alwaysSucceedingScript (Maybe HashableScriptData -> ScriptDatum WitCtxTxIn
ScriptDatumForTxIn (Maybe HashableScriptData -> ScriptDatum WitCtxTxIn)
-> Maybe HashableScriptData -> ScriptDatum WitCtxTxIn
forall a b. (a -> b) -> a -> b
$ HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
Just HashableScriptData
datum) HashableScriptData
redeemer
                    )
                )
                (UTxO -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
utxoToSpend)
            )
      )

  addSomeReferenceInputs :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
  addSomeReferenceInputs :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
addSomeReferenceInputs (UTxO
utxo, TxBodyContent BuildTx
txbody) = do
    TxOut CtxUTxO
txout <- Gen (TxOut CtxUTxO)
forall ctx. Gen (TxOut ctx)
genTxOutWithReferenceScript
    TxIn
txin <- Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
    (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO
utxo UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> TxIn -> TxOut CtxUTxO -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
txin TxOut CtxUTxO
txout, TxBodyContent BuildTx
txbody TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn]
-> Set HashableScriptData
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall build era.
(Applicative (BuildTxWith build), IsBabbageBasedEra era) =>
[TxIn]
-> Set HashableScriptData
-> TxBodyContent build era
-> TxBodyContent build era
addTxInsReference [TxIn
txin] Set HashableScriptData
forall a. Monoid a => a
mempty)

  addValidityRange :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
  addValidityRange :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
addValidityRange (UTxO
utxo, TxBodyContent BuildTx
txbody) = do
    TxValidityLowerBound Era
start <- Gen (TxValidityLowerBound Era) -> Gen (TxValidityLowerBound Era)
forall a. Gen a -> Gen a
hedgehog (Gen (TxValidityLowerBound Era) -> Gen (TxValidityLowerBound Era))
-> Gen (TxValidityLowerBound Era) -> Gen (TxValidityLowerBound Era)
forall a b. (a -> b) -> a -> b
$ CardanoEra Era -> Gen (TxValidityLowerBound Era)
forall era. CardanoEra era -> Gen (TxValidityLowerBound era)
Gen.genTxValidityLowerBound CardanoEra Era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra
    TxValidityUpperBound Era
end <- Gen (TxValidityUpperBound Era) -> Gen (TxValidityUpperBound Era)
forall a. Gen a -> Gen a
hedgehog (Gen (TxValidityUpperBound Era) -> Gen (TxValidityUpperBound Era))
-> Gen (TxValidityUpperBound Era) -> Gen (TxValidityUpperBound Era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra Era -> Gen (TxValidityUpperBound Era)
forall era. ShelleyBasedEra era -> Gen (TxValidityUpperBound era)
Gen.genTxValidityUpperBound ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra
    (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( UTxO
utxo
      , TxBodyContent BuildTx
txbody{txValidityLowerBound = start, txValidityUpperBound = end}
      )

  addRandomMetadata :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
  addRandomMetadata :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
addRandomMetadata (UTxO
utxo, TxBodyContent BuildTx
txbody) = do
    TxMetadataInEra
mtdt <- Gen TxMetadataInEra
genMetadata
    (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO
utxo, TxBodyContent BuildTx
txbody{txMetadata = mtdt})

  addCollateralInput :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
  addCollateralInput :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
addCollateralInput (UTxO
utxo, TxBodyContent BuildTx
txbody) = do
    UTxO
utxoToSpend <- Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
1
    (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( UTxO
utxo UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
utxoToSpend
      , TxBodyContent BuildTx
txbody{txInsCollateral = TxInsCollateral $ toList (UTxO.inputSet utxoToSpend)}
      )

  sometimesAddRewardRedeemer :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
  sometimesAddRewardRedeemer :: (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
sometimesAddRewardRedeemer (UTxO
utxo, TxBodyContent BuildTx
txbody) =
    [Gen (UTxO, TxBodyContent BuildTx)]
-> Gen (UTxO, TxBodyContent BuildTx)
forall a. HasCallStack => [Gen a] -> Gen a
oneof
      [ (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO
utxo, TxBodyContent BuildTx
txbody)
      , do
          Coin
lovelace <- Gen Coin
forall a. Arbitrary a => Gen a
arbitrary
          let redeemer :: HashableScriptData
redeemer = Gen HashableScriptData -> Gen HashableScriptData
forall a. Gen a -> Gen a
hedgehog Gen HashableScriptData
HasCallStack => Gen HashableScriptData
Gen.genHashableScriptData Gen HashableScriptData -> Int -> HashableScriptData
forall a. Gen a -> Int -> a
`generateWith` Int
42
              script :: PlutusScript
script = PlutusScript
dummyRewardingScript
              scriptWitness :: ScriptWitness WitCtxStake Era
scriptWitness = PlutusScript
-> ScriptDatum WitCtxStake
-> HashableScriptData
-> ScriptWitness WitCtxStake Era
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
script ScriptDatum WitCtxStake
NoScriptDatumForStake HashableScriptData
redeemer
              stakeAddress :: StakeAddress
stakeAddress =
                NetworkId -> StakeCredential -> StakeAddress
makeStakeAddress NetworkId
testNetworkId (StakeCredential -> StakeAddress)
-> (Script -> StakeCredential) -> Script -> StakeAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> StakeCredential
StakeCredentialByScript (ScriptHash -> StakeCredential)
-> (Script -> ScriptHash) -> Script -> StakeCredential
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> ScriptHash
forall lang. Script lang -> ScriptHash
hashScript (Script -> StakeAddress) -> Script -> StakeAddress
forall a b. (a -> b) -> a -> b
$
                  PlutusScript -> Script
PlutusScript PlutusScript
script
          (UTxO, TxBodyContent BuildTx) -> Gen (UTxO, TxBodyContent BuildTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( UTxO
utxo
            , TxBodyContent BuildTx
txbody
                TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxWithdrawals BuildTx Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxWithdrawals build era
-> TxBodyContent build era -> TxBodyContent build era
setTxWithdrawals
                  ( ShelleyBasedEra Era
-> [(StakeAddress, Coin,
     BuildTxWith BuildTx (Witness WitCtxStake Era))]
-> TxWithdrawals BuildTx Era
forall era build.
ShelleyBasedEra era
-> [(StakeAddress, Coin,
     BuildTxWith build (Witness WitCtxStake era))]
-> TxWithdrawals build era
TxWithdrawals
                      ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra
                      [
                        ( StakeAddress
stakeAddress
                        , Coin
lovelace
                        , Witness WitCtxStake Era
-> BuildTxWith BuildTx (Witness WitCtxStake Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxStake Era
 -> BuildTxWith BuildTx (Witness WitCtxStake Era))
-> Witness WitCtxStake Era
-> BuildTxWith BuildTx (Witness WitCtxStake Era)
forall a b. (a -> b) -> a -> b
$ ScriptWitnessInCtx WitCtxStake
-> ScriptWitness WitCtxStake Era -> Witness WitCtxStake Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxStake
ScriptWitnessForStakeAddr ScriptWitness WitCtxStake Era
scriptWitness
                        )
                      ]
                  )
            )
      ]

  -- More value in output than input
  sometimesExtractsValue :: (UTxO, TxBodyContent build) -> Gen (UTxO, TxBodyContent build)
sometimesExtractsValue (UTxO
utxo, TxBodyContent build
txbody) =
    [Gen (UTxO, TxBodyContent build)]
-> Gen (UTxO, TxBodyContent build)
forall a. HasCallStack => [Gen a] -> Gen a
oneof
      [ (UTxO, TxBodyContent build) -> Gen (UTxO, TxBodyContent build)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO
utxo, TxBodyContent build
txbody)
      , -- Add an output with more value than the total input value
        do
          TxOut CtxTx Era
out <- (Value -> Value) -> TxOut CtxTx Era -> TxOut CtxTx Era
forall era ctx.
IsMaryBasedEra era =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> UTxO -> TxBodyContent build -> Value
forall build. UTxO -> TxBodyContent build -> Value
txInsTotalValue UTxO
utxo TxBodyContent build
txbody) (TxOut CtxTx Era -> TxOut CtxTx Era)
-> Gen (TxOut CtxTx Era) -> Gen (TxOut CtxTx Era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TxOut CtxTx Era)
forall ctx. Gen (TxOut ctx)
genTxOut
          (UTxO, TxBodyContent build) -> Gen (UTxO, TxBodyContent build)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( UTxO
utxo
            , TxBodyContent build
txbody{txOuts = out : txOuts txbody}
            )
      ]

genMetadata :: Gen TxMetadataInEra
genMetadata :: Gen TxMetadataInEra
genMetadata =
  forall era. Era era => Gen (ShelleyTxAuxData era)
genMetadata' @LedgerEra Gen (ShelleyTxAuxData ConwayEra)
-> (ShelleyTxAuxData ConwayEra -> Gen TxMetadataInEra)
-> Gen TxMetadataInEra
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(ShelleyTxAuxData Map Word64 Metadatum
m) ->
    TxMetadataInEra -> Gen TxMetadataInEra
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxMetadataInEra -> Gen TxMetadataInEra)
-> (Map Word64 TxMetadataValue -> TxMetadataInEra)
-> Map Word64 TxMetadataValue
-> Gen TxMetadataInEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxMetadata -> TxMetadataInEra
TxMetadataInEra (TxMetadata -> TxMetadataInEra)
-> (Map Word64 TxMetadataValue -> TxMetadata)
-> Map Word64 TxMetadataValue
-> TxMetadataInEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Word64 TxMetadataValue -> TxMetadata
TxMetadata (Map Word64 TxMetadataValue -> Gen TxMetadataInEra)
-> Map Word64 TxMetadataValue -> Gen TxMetadataInEra
forall a b. (a -> b) -> a -> b
$ Map Word64 Metadatum -> Map Word64 TxMetadataValue
fromShelleyMetadata Map Word64 Metadatum
m

getAuxMetadata :: Tx -> Map Word64 Metadatum
getAuxMetadata :: Tx -> Map Word64 Metadatum
getAuxMetadata Tx
tx =
  case Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx Tx TopTx ConwayEra
-> Getting
     (StrictMaybe (AlonzoTxAuxData ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictMaybe (AlonzoTxAuxData ConwayEra))
-> StrictMaybe (AlonzoTxAuxData ConwayEra)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (AlonzoTxAuxData ConwayEra))
  (Tx TopTx ConwayEra)
  (StrictMaybe (AlonzoTxAuxData ConwayEra))
(StrictMaybe (TxAuxData ConwayEra)
 -> Const
      (StrictMaybe (AlonzoTxAuxData ConwayEra))
      (StrictMaybe (TxAuxData ConwayEra)))
-> Tx TopTx ConwayEra
-> Const
     (StrictMaybe (AlonzoTxAuxData ConwayEra)) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l ConwayEra) (StrictMaybe (TxAuxData ConwayEra))
auxDataTxL of
    StrictMaybe (AlonzoTxAuxData ConwayEra)
SNothing -> Map Word64 Metadatum
forall a. Monoid a => a
mempty
    SJust (AlonzoTxAuxData Map Word64 Metadatum
m StrictSeq (NativeScript ConwayEra)
_ Map Language (NonEmpty PlutusBinary)
_) -> Map Word64 Metadatum
m

prop_interestingBlueprintTx :: Property
prop_interestingBlueprintTx :: Property
prop_interestingBlueprintTx = Gen (UTxO, Tx) -> ((UTxO, Tx) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (UTxO, Tx)
genBlueprintTxWithUTxO (((UTxO, Tx) -> Property) -> Property)
-> ((UTxO, Tx) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO
utxo, Tx
tx) ->
  Bool -> Property
forall prop. Testable prop => prop -> Property
checkCoverage
    Bool
True
    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
1 ((UTxO, Tx) -> Bool
spendsFromScript (UTxO
utxo, Tx
tx)) String
"blueprint spends script UTxO"
    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
1 ((UTxO, Tx) -> Bool
spendsFromPubKey (UTxO
utxo, Tx
tx)) String
"blueprint spends pub key UTxO"
    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
1 ((UTxO, Tx) -> Bool
spendsFromPubKey (UTxO
utxo, Tx
tx) Bool -> Bool -> Bool
&& (UTxO, Tx) -> Bool
spendsFromScript (UTxO
utxo, Tx
tx)) String
"blueprint spends from script AND pub key"
    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
1 (Tx -> Bool
hasReferenceInputs Tx
tx) String
"blueprint has reference input"
    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
1 (Tx -> Bool
hasRewardRedeemer Tx
tx) String
"blueprint has reward redeemer"
    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
1 ((UTxO, Tx) -> Bool
hasMoreOutputThanInput (UTxO
utxo, Tx
tx)) String
"blueprint tries to extract value"
 where
  hasRewardRedeemer :: Tx -> Bool
hasRewardRedeemer Tx
tx =
    Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx Tx TopTx LedgerEra
-> Getting
     (Redeemers LedgerEra) (Tx TopTx LedgerEra) (Redeemers LedgerEra)
-> Redeemers LedgerEra
forall s a. s -> Getting a s a -> a
^. (TxWits LedgerEra
 -> Const (Redeemers LedgerEra) (TxWits LedgerEra))
-> Tx TopTx LedgerEra
-> Const (Redeemers LedgerEra) (Tx TopTx LedgerEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l LedgerEra) (TxWits LedgerEra)
witsTxL ((TxWits LedgerEra
  -> Const (Redeemers LedgerEra) (TxWits LedgerEra))
 -> Tx TopTx LedgerEra
 -> Const (Redeemers LedgerEra) (Tx TopTx LedgerEra))
-> ((Redeemers LedgerEra
     -> Const (Redeemers LedgerEra) (Redeemers LedgerEra))
    -> TxWits LedgerEra
    -> Const (Redeemers LedgerEra) (TxWits LedgerEra))
-> Getting
     (Redeemers LedgerEra) (Tx TopTx LedgerEra) (Redeemers LedgerEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers LedgerEra
 -> Const (Redeemers LedgerEra) (Redeemers LedgerEra))
-> TxWits LedgerEra
-> Const (Redeemers LedgerEra) (TxWits LedgerEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits LedgerEra) (Redeemers LedgerEra)
rdmrsTxWitsL
      Redeemers LedgerEra
-> (Redeemers LedgerEra
    -> Map
         (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits))
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall a b. a -> (a -> b) -> b
& forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
unRedeemers @LedgerEra
      Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> (Map
      (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
    -> Set (ConwayPlutusPurpose AsIx ConwayEra))
-> Set (ConwayPlutusPurpose AsIx ConwayEra)
forall a b. a -> (a -> b) -> b
& Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Set (ConwayPlutusPurpose AsIx ConwayEra)
forall k a. Map k a -> Set k
Map.keysSet
      Set (ConwayPlutusPurpose AsIx ConwayEra)
-> (Set (ConwayPlutusPurpose AsIx ConwayEra) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& (ConwayPlutusPurpose AsIx ConwayEra -> Bool)
-> Set (ConwayPlutusPurpose AsIx ConwayEra) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
        ( \case
            ConwayRewarding AsIx Word32 AccountAddress
_ -> Bool
True
            ConwayPlutusPurpose AsIx ConwayEra
_ -> Bool
False
        )

  hasReferenceInputs :: Tx -> Bool
  hasReferenceInputs :: Tx -> Bool
hasReferenceInputs Tx
tx =
    Bool -> Bool
not (Bool -> Bool) -> (Set TxIn -> Bool) -> Set TxIn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TxIn -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set TxIn -> Bool) -> Set TxIn -> Bool
forall a b. (a -> b) -> a -> b
$ Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx Tx TopTx ConwayEra
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (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))
-> Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
Cardano.Ledger.Api.referenceInputsTxBodyL

  spendsFromPubKey :: (UTxO, Tx) -> Bool
  spendsFromPubKey :: (UTxO, Tx) -> Bool
spendsFromPubKey (UTxO
utxo, Tx
tx) =
    (TxIn -> Bool) -> Set TxIn -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
      ( \TxIn
txIn -> case TxIn -> UTxO -> Maybe (TxOut CtxUTxO)
forall era. TxIn -> UTxO era -> Maybe (TxOut CtxUTxO era)
UTxO.resolveTxIn (TxIn -> TxIn
fromLedgerTxIn TxIn
txIn) UTxO
utxo of
          Just (TxOut (ShelleyAddressInEra (ShelleyAddress Network
_ (KeyHashObj KeyHash Payment
_) StakeReference
_)) Value
_ TxOutDatum CtxUTxO
_ ReferenceScript
_) -> Bool
True
          Maybe (TxOut CtxUTxO)
_ -> Bool
False
      )
      (Set TxIn -> Bool) -> Set TxIn -> Bool
forall a b. (a -> b) -> a -> b
$ Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx Tx TopTx ConwayEra
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (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))
-> Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL

  -- XXX: We do check both, the utxo and redeemers, because we
  -- don't do phase 1 validation of the resulting transactions
  -- and would not detect if redeemers are missing.
  spendsFromScript :: (UTxO, Tx) -> Bool
  spendsFromScript :: (UTxO, Tx) -> Bool
spendsFromScript (UTxO
utxo, Tx
tx) =
    (TxIn -> Bool) -> Set TxIn -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
      ( \TxIn
txIn -> case TxIn -> UTxO -> Maybe (TxOut CtxUTxO)
forall era. TxIn -> UTxO era -> Maybe (TxOut CtxUTxO era)
UTxO.resolveTxIn (TxIn -> TxIn
fromLedgerTxIn TxIn
txIn) UTxO
utxo of
          Just (TxOut (ShelleyAddressInEra (ShelleyAddress Network
_ (ScriptHashObj ScriptHash
_) StakeReference
_)) Value
_ TxOutDatum CtxUTxO
_ ReferenceScript
_) -> Bool
True
          Maybe (TxOut CtxUTxO)
_ -> Bool
False
      )
      (Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx Tx TopTx ConwayEra
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (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))
-> Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL)
      Bool -> Bool -> Bool
&& (ConwayPlutusPurpose AsIx ConwayEra -> Bool)
-> Set (ConwayPlutusPurpose AsIx ConwayEra) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
        ( \case
            ConwaySpending AsIx Word32 TxIn
_ -> Bool
True
            ConwayPlutusPurpose AsIx ConwayEra
_ -> Bool
False
        )
        ( Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Set (ConwayPlutusPurpose AsIx ConwayEra)
forall k a. Map k a -> Set k
Map.keysSet
            (Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
 -> Set (ConwayPlutusPurpose AsIx ConwayEra))
-> (Redeemers ConwayEra
    -> Map
         (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits))
-> Redeemers ConwayEra
-> Set (ConwayPlutusPurpose AsIx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Redeemers ConwayEra
-> Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Redeemers ConwayEra
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
unRedeemers
            (Redeemers ConwayEra -> Set (ConwayPlutusPurpose AsIx ConwayEra))
-> Redeemers ConwayEra -> Set (ConwayPlutusPurpose AsIx ConwayEra)
forall a b. (a -> b) -> a -> b
$ forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx @Era Tx
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
        )

  hasMoreOutputThanInput :: (UTxO, Tx) -> Bool
hasMoreOutputThanInput (UTxO
utxo, Tx
tx) =
    let inputsValue :: MaryValue
inputsValue = Value -> MaryValue
toMaryValue (Value -> MaryValue)
-> (TxBodyContent ViewTx -> Value)
-> TxBodyContent ViewTx
-> MaryValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> TxBodyContent ViewTx -> Value
forall build. UTxO -> TxBodyContent build -> Value
txInsTotalValue UTxO
utxo (TxBodyContent ViewTx -> MaryValue)
-> TxBodyContent ViewTx -> MaryValue
forall a b. (a -> b) -> a -> b
$ TxBody Era -> TxBodyContent ViewTx
forall era. TxBody era -> TxBodyContent ViewTx era
getTxBodyContent (TxBody Era -> TxBodyContent ViewTx)
-> TxBody Era -> TxBodyContent ViewTx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx
        outputsValue :: MaryValue
outputsValue = Value -> MaryValue
toMaryValue (Value -> MaryValue) -> (UTxO -> Value) -> UTxO -> MaryValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> Value
forall era. UTxO era -> Value
UTxO.totalValue (UTxO -> MaryValue) -> UTxO -> MaryValue
forall a b. (a -> b) -> a -> b
$ Tx -> UTxO
utxoFromTx Tx
tx
     in (Integer -> Integer -> Bool) -> MaryValue -> MaryValue -> Bool
forall t. Val t => (Integer -> Integer -> Bool) -> t -> t -> Bool
pointwise Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>=) MaryValue
outputsValue MaryValue
inputsValue

txInsTotalValue :: UTxO -> TxBodyContent build -> Value
txInsTotalValue :: forall build. UTxO -> TxBodyContent build -> Value
txInsTotalValue UTxO
utxo TxBodyContent build
txbody =
  (TxOut CtxUTxO -> Value) -> [TxOut CtxUTxO] -> Value
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue
    ([TxOut CtxUTxO] -> Value)
-> ([(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))]
    -> [TxOut CtxUTxO])
-> [(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, BuildTxWith build (Witness WitCtxTxIn Era))
 -> Maybe (TxOut CtxUTxO))
-> [(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))]
-> [TxOut CtxUTxO]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((TxIn -> UTxO -> Maybe (TxOut CtxUTxO)
forall era. TxIn -> UTxO era -> Maybe (TxOut CtxUTxO era)
`UTxO.resolveTxIn` UTxO
utxo) (TxIn -> Maybe (TxOut CtxUTxO))
-> ((TxIn, BuildTxWith build (Witness WitCtxTxIn Era)) -> TxIn)
-> (TxIn, BuildTxWith build (Witness WitCtxTxIn Era))
-> Maybe (TxOut CtxUTxO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, BuildTxWith build (Witness WitCtxTxIn Era)) -> TxIn
forall a b. (a, b) -> a
fst)
    ([(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))]
 -> [TxOut CtxUTxO])
-> ([(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))]
    -> [(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))])
-> [(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))]
-> [TxOut CtxUTxO]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))]
-> [(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
    ([(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))] -> Value)
-> [(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))] -> Value
forall a b. (a -> b) -> a -> b
$ TxBodyContent build
-> [(TxIn, BuildTxWith build (Witness WitCtxTxIn Era))]
forall build. TxBodyContent build -> TxIns build
txIns TxBodyContent build
txbody