{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Unit tests for our "hand-rolled" transactions as they are used in the
-- "direct" chain component.
module Hydra.Chain.Direct.TxSpec where

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

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Alonzo.Core (EraTxAuxData (hashTxAuxData))
import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..))
import Cardano.Ledger.Api (
  AlonzoPlutusPurpose (AlonzoSpending),
  Metadatum,
  auxDataHashTxBodyL,
  auxDataTxL,
  bodyTxL,
  inputsTxBodyL,
  outputsTxBodyL,
  ppProtocolVersionL,
  rdmrsTxWitsL,
  referenceInputsTxBodyL,
  reqSignerHashesTxBodyL,
  unRedeemers,
  validateTxAuxData,
  vldtTxBodyL,
  witsTxL,
  pattern ShelleyTxAuxData,
 )
import Cardano.Ledger.Core (EraTx (getMinFeeTx))
import Cardano.Ledger.Credential (Credential (..))
import Control.Lens ((^.))
import Data.Map qualified as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Set qualified as Set
import Data.Text qualified as T
import Hydra.Cardano.Api.Pretty (renderTx, renderTxWithUTxO)
import Hydra.Chain (CommitBlueprintTx (..), HeadParameters (..))
import Hydra.Chain.Direct.Contract.Commit (commitSigningKey, healthyInitialTxIn, healthyInitialTxOut)
import Hydra.Chain.Direct.Fixture (
  epochInfo,
  pparams,
  systemStart,
  testNetworkId,
  testPolicyId,
  testSeedInput,
 )
import Hydra.Chain.Direct.Fixture qualified as Fixture
import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
import Hydra.Chain.Direct.State (ChainContext (..), HasKnownUTxO (getKnownUTxO), genChainStateWithTx)
import Hydra.Chain.Direct.State qualified as Transition
import Hydra.Chain.Direct.Tx (
  HeadObservation (..),
  InitObservation (..),
  abortTx,
  commitTx,
  currencySymbolToHeadId,
  headIdToCurrencySymbol,
  headIdToPolicyId,
  headSeedToTxIn,
  initTx,
  mkCommitDatum,
  mkHeadId,
  observeHeadTx,
  observeInitTx,
  onChainIdToAssetName,
  txInToHeadSeed,
  verificationKeyToOnChainId,
 )
import Hydra.Chain.Direct.Wallet (ErrCoverFee (..), coverFee_)
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.HeadTokens (headPolicyId, mkHeadTokenScript)
import Hydra.Contract.Initial qualified as Initial
import Hydra.Ledger.Cardano (
  adaOnly,
  addInputs,
  addReferenceInputs,
  addVkInputs,
  emptyTxBody,
  genOneUTxOFor,
  genTxOutWithReferenceScript,
  genUTxO1,
  genUTxOAdaOnlyOfSize,
  genValue,
  genVerificationKey,
  unsafeBuildTransaction,
 )
import Hydra.Ledger.Cardano.Evaluate (EvaluationReport, maxTxExecutionUnits, propTransactionEvaluates)
import Hydra.Party (Party)
import PlutusLedgerApi.Test.Examples qualified as Plutus
import Test.Cardano.Ledger.Shelley.Arbitrary (genMetadata')
import Test.Hydra.Fixture (genForParty)
import Test.Hydra.Prelude
import Test.QuickCheck (
  Property,
  checkCoverage,
  choose,
  conjoin,
  counterexample,
  cover,
  elements,
  forAll,
  forAllBlind,
  label,
  property,
  vectorOf,
  withMaxSuccess,
  (.&&.),
  (===),
 )
import Test.QuickCheck.Instances.Semigroup ()
import Test.QuickCheck.Monadic (monadicIO)

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
"HeadSeed (cardano)" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
      String -> (TxIn -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"headSeedToTxIn . txInToHeadSeed === id" ((TxIn -> Property) -> Spec) -> (TxIn -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxIn
txIn -> do
        let headSeed :: HeadSeed
headSeed = TxIn -> HeadSeed
txInToHeadSeed TxIn
txIn
        HeadSeed -> Maybe TxIn
forall (m :: * -> *). MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn HeadSeed
headSeed Maybe TxIn -> Maybe TxIn -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxIn -> Maybe TxIn
forall a. a -> Maybe a
Just TxIn
txIn
          Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (HeadSeed -> String
forall b a. (Show a, IsString b) => a -> b
show HeadSeed
headSeed)

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"HeadId (cardano)" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> (PolicyId -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"headIdToPolicyId . mkHeadId === id" ((PolicyId -> Property) -> Spec) -> (PolicyId -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \PolicyId
pid -> do
        let headId :: HeadId
headId = PolicyId -> HeadId
mkHeadId PolicyId
pid
        HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId -> Maybe PolicyId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PolicyId -> Maybe PolicyId
forall a. a -> Maybe a
Just PolicyId
pid
          Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (HeadId -> String
forall b a. (Show a, IsString b) => a -> b
show HeadId
headId)

      String -> (TxIn -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"curencySymbolToHeadId . headIdToCurrencySymbol === id" ((TxIn -> Property) -> Spec) -> (TxIn -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxIn
txIn -> PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Property)
-> PropertyM IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
        let headId :: HeadId
headId = PolicyId -> HeadId
mkHeadId (PolicyId -> HeadId) -> PolicyId -> HeadId
forall a b. (a -> b) -> a -> b
$ TxIn -> PolicyId
headPolicyId TxIn
txIn
        let cs :: CurrencySymbol
cs = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
        HeadId
headId' <- CurrencySymbol -> PropertyM IO HeadId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m HeadId
currencySymbolToHeadId CurrencySymbol
cs
        Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> PropertyM IO Property)
-> Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$ HeadId
headId' HeadId -> HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== HeadId
headId

    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
"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, Tx, ChainTransition)
-> ((ChainContext, ChainState, Tx, ChainTransition) -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (ChainContext, ChainState, Tx, ChainTransition)
genChainStateWithTx (((ChainContext, ChainState, Tx, ChainTransition) -> Property)
 -> Property)
-> ((ChainContext, ChainState, Tx, ChainTransition) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
_ctx, ChainState
st, 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
                 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
                      Abort{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Abort
                      Commit{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Commit
                      CollectCom{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Collect
                      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
                      Fanout{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Fanout

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"collectComTx" (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
"cover fee correctly handles redeemers" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Int
-> (TxIn
    -> ContestationPeriod
    -> NonEmpty Party
    -> Map
         (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
60 ((TxIn
  -> ContestationPeriod
  -> NonEmpty Party
  -> Map
       (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
  -> Property)
 -> Property)
-> (TxIn
    -> ContestationPeriod
    -> NonEmpty Party
    -> Map
         (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TxIn
txIn ContestationPeriod
cperiod (Party
party :| [Party]
parties) Map
  (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
walletUTxO -> do
          let allParties :: [Party]
allParties = Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
parties
              cardanoKeys :: [VerificationKey PaymentKey]
cardanoKeys = Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
genForParty Gen (VerificationKey PaymentKey)
genVerificationKey (Party -> VerificationKey PaymentKey)
-> [Party] -> [VerificationKey PaymentKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
allParties
          Gen (VerificationKey PaymentKey)
-> (VerificationKey PaymentKey -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll ([VerificationKey PaymentKey] -> Gen (VerificationKey PaymentKey)
forall a. [a] -> Gen a
elements [VerificationKey PaymentKey]
cardanoKeys) ((VerificationKey PaymentKey -> Property) -> Property)
-> (VerificationKey PaymentKey -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \VerificationKey PaymentKey
signer ->
            Gen ScriptRegistry -> (ScriptRegistry -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen ScriptRegistry
genScriptRegistry ((ScriptRegistry -> Property) -> Property)
-> (ScriptRegistry -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ScriptRegistry
scriptRegistry ->
              let params :: HeadParameters
params = ContestationPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
cperiod [Party]
allParties
                  participants :: [OnChainId]
participants = VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId (VerificationKey PaymentKey -> OnChainId)
-> [VerificationKey PaymentKey] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VerificationKey PaymentKey]
cardanoKeys
                  tx :: Tx
tx = NetworkId -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initTx NetworkId
testNetworkId TxIn
txIn [OnChainId]
participants HeadParameters
params
               in case Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
tx of
                    Right InitObservation{[(TxIn, TxOut CtxUTxO)]
initials :: [(TxIn, TxOut CtxUTxO)]
$sel:initials:InitObservation :: InitObservation -> [(TxIn, TxOut CtxUTxO)]
initials, (TxIn, TxOut CtxUTxO)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO)
$sel:initialThreadUTxO:InitObservation :: InitObservation -> (TxIn, TxOut CtxUTxO)
initialThreadUTxO} -> do
                      let lookupUTxO :: Map
  (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
lookupUTxO =
                            [Map TxIn (TxOut CtxUTxO)] -> Map TxIn (TxOut CtxUTxO)
forall a. Monoid a => [a] -> a
mconcat
                              [ [(TxIn, TxOut CtxUTxO)] -> Map TxIn (TxOut CtxUTxO)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((TxIn, TxOut CtxUTxO)
initialThreadUTxO (TxIn, TxOut CtxUTxO)
-> [(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)]
forall a. a -> [a] -> [a]
: [(TxIn, TxOut CtxUTxO)]
initials)
                              , UTxO -> Map TxIn (TxOut CtxUTxO)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap (ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry)
                              ]
                              Map TxIn (TxOut CtxUTxO)
-> (Map TxIn (TxOut CtxUTxO)
    -> Map (TxIn StandardCrypto) (TxOut CtxUTxO))
-> Map (TxIn StandardCrypto) (TxOut CtxUTxO)
forall a b. a -> (a -> b) -> b
& (TxIn -> TxIn StandardCrypto)
-> Map TxIn (TxOut CtxUTxO)
-> Map (TxIn StandardCrypto) (TxOut CtxUTxO)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys TxIn -> TxIn StandardCrypto
toLedgerTxIn
                              Map (TxIn StandardCrypto) (TxOut CtxUTxO)
-> (Map (TxIn StandardCrypto) (TxOut CtxUTxO)
    -> Map
         (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto)))
-> Map
     (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
forall a b. a -> (a -> b) -> b
& (TxOut CtxUTxO -> BabbageTxOut (BabbageEra StandardCrypto))
-> Map (TxIn StandardCrypto) (TxOut CtxUTxO)
-> Map
     (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map TxOut CtxUTxO -> BabbageTxOut (BabbageEra StandardCrypto)
TxOut CtxUTxO -> TxOut LedgerEra
toLedgerTxOut
                       in case UTxO
-> ScriptRegistry
-> VerificationKey PaymentKey
-> (TxIn, TxOut CtxUTxO)
-> PlutusScript
-> Map TxIn (TxOut CtxUTxO)
-> Map TxIn (TxOut CtxUTxO)
-> Either AbortTxError Tx
abortTx UTxO
forall a. Monoid a => a
mempty ScriptRegistry
scriptRegistry VerificationKey PaymentKey
signer (TxIn, TxOut CtxUTxO)
initialThreadUTxO (TxIn -> PlutusScript
mkHeadTokenScript TxIn
testSeedInput) ([(TxIn, TxOut CtxUTxO)] -> Map TxIn (TxOut CtxUTxO)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxIn, TxOut CtxUTxO)]
initials) Map TxIn (TxOut CtxUTxO)
forall a. Monoid a => a
mempty of
                            Left AbortTxError
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
"AbortTx construction failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AbortTxError -> String
forall b a. (Show a, IsString b) => a -> b
show AbortTxError
err)
                            Right (Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx -> Tx LedgerEra
txAbort) ->
                              case PParams LedgerEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map (TxIn StandardCrypto) (TxOut LedgerEra)
-> Map (TxIn StandardCrypto) (TxOut LedgerEra)
-> AlonzoTx LedgerEra
-> Either ErrCoverFee (AlonzoTx LedgerEra)
coverFee_ PParams LedgerEra
pparams SystemStart
systemStart EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
epochInfo Map
  (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
Map (TxIn StandardCrypto) (TxOut LedgerEra)
lookupUTxO Map
  (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
Map (TxIn StandardCrypto) (TxOut LedgerEra)
walletUTxO AlonzoTx LedgerEra
Tx LedgerEra
txAbort of
                                Left ErrCoverFee
err ->
                                  Bool
True
                                    Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
label
                                      ( case ErrCoverFee
err of
                                          ErrNoFuelUTxOFound{} -> String
"No fuel UTxO found"
                                          ErrNotEnoughFunds{} -> String
"Not enough funds"
                                          ErrUnknownInput{} -> String
"Unknown input"
                                          ErrScriptExecutionFailed{} -> String
"Script(s) execution failed"
                                          ErrTranslationError{} -> String
"Transaction context translation error"
                                      )
                                Right AlonzoTx LedgerEra
ledgerTx ->
                                  let actualExecutionCost :: Coin
actualExecutionCost = PParams (BabbageEra StandardCrypto)
-> Tx (BabbageEra StandardCrypto) -> Coin
forall era. EraTx era => PParams era -> Tx era -> Coin
getMinFeeTx PParams LedgerEra
PParams (BabbageEra StandardCrypto)
pparams AlonzoTx LedgerEra
Tx (BabbageEra StandardCrypto)
ledgerTx
                                      fee :: Coin
fee = Tx -> Coin
forall era. Tx era -> Coin
txFee' Tx
apiTx
                                      apiTx :: Tx
apiTx = Tx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx AlonzoTx LedgerEra
Tx LedgerEra
ledgerTx
                                   in Coin
actualExecutionCost Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> Coin
Coin Integer
0 Bool -> Bool -> Bool
&& Coin
fee Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
actualExecutionCost
                                        Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"Ok"
                                        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Execution cost: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
actualExecutionCost)
                                        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> 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
"Tx: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx -> String
forall b a. (Show a, IsString b) => a -> b
show Tx
apiTx)
                                        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Input utxo: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map
  (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> String
forall b a. (Show a, IsString b) => a -> b
show (Map
  (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
walletUTxO Map
  (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> Map
     (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> Map
     (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
forall a. Semigroup a => a -> a -> a
<> Map
  (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
lookupUTxO))
                    Left NotAnInitReason
e ->
                      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
"Failed to construct and observe init tx."
                        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Tx -> String
renderTx Tx
tx)
                        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (NotAnInitReason -> String
forall b a. (Show a, IsString b) => a -> b
show NotAnInitReason
e)

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"commitTx" (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
"Validate blueprint and commit transactions" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$ do
        Gen ChainContext -> (ChainContext -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen ChainContext
forall a. Arbitrary a => Gen a
arbitrary ((ChainContext -> Property) -> Property)
-> (ChainContext -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainContext
chainContext -> do
          let ChainContext{NetworkId
networkId :: NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId, VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey, Party
ownParty :: Party
$sel:ownParty:ChainContext :: ChainContext -> Party
ownParty, ScriptRegistry
scriptRegistry :: ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry} =
                ChainContext
chainContext{ownVerificationKey = getVerificationKey commitSigningKey, networkId = testNetworkId}
          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) ->
            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 =
                    NetworkId
-> ScriptRegistry
-> HeadId
-> Party
-> CommitBlueprintTx Tx
-> (TxIn, TxOut CtxUTxO, Hash PaymentKey)
-> Tx
commitTx
                      NetworkId
networkId
                      ScriptRegistry
scriptRegistry
                      (PolicyId -> HeadId
mkHeadId PolicyId
Fixture.testPolicyId)
                      Party
ownParty
                      CommitBlueprintTx{UTxO
UTxOType Tx
lookupUTxO :: UTxO
$sel:lookupUTxO:CommitBlueprintTx :: UTxOType Tx
lookupUTxO, Tx
blueprintTx :: Tx
$sel:blueprintTx:CommitBlueprintTx :: Tx
blueprintTx}
                      (TxIn
healthyInitialTxIn, TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext TxOut CtxTx Era
healthyInitialTxOut, VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
ownVerificationKey)
              String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"\n\n\nCommit 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 (BabbageEra StandardCrypto)
blueprintBody = Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx AlonzoTx (BabbageEra StandardCrypto)
-> Getting
     (TxBody (BabbageEra StandardCrypto))
     (AlonzoTx (BabbageEra StandardCrypto))
     (TxBody (BabbageEra StandardCrypto))
-> TxBody (BabbageEra StandardCrypto)
forall s a. s -> Getting a s a -> a
^. Getting
  (TxBody (BabbageEra StandardCrypto))
  (AlonzoTx (BabbageEra StandardCrypto))
  (TxBody (BabbageEra StandardCrypto))
(TxBody (BabbageEra StandardCrypto)
 -> Const
      (TxBody (BabbageEra StandardCrypto))
      (TxBody (BabbageEra StandardCrypto)))
-> Tx (BabbageEra StandardCrypto)
-> Const
     (TxBody (BabbageEra StandardCrypto))
     (Tx (BabbageEra StandardCrypto))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens'
  (Tx (BabbageEra StandardCrypto))
  (TxBody (BabbageEra StandardCrypto))
bodyTxL
                let commitTxBody :: TxBody (BabbageEra StandardCrypto)
commitTxBody = Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
createdTx AlonzoTx (BabbageEra StandardCrypto)
-> Getting
     (TxBody (BabbageEra StandardCrypto))
     (AlonzoTx (BabbageEra StandardCrypto))
     (TxBody (BabbageEra StandardCrypto))
-> TxBody (BabbageEra StandardCrypto)
forall s a. s -> Getting a s a -> a
^. Getting
  (TxBody (BabbageEra StandardCrypto))
  (AlonzoTx (BabbageEra StandardCrypto))
  (TxBody (BabbageEra StandardCrypto))
(TxBody (BabbageEra StandardCrypto)
 -> Const
      (TxBody (BabbageEra StandardCrypto))
      (TxBody (BabbageEra StandardCrypto)))
-> Tx (BabbageEra StandardCrypto)
-> Const
     (TxBody (BabbageEra StandardCrypto))
     (Tx (BabbageEra StandardCrypto))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens'
  (Tx (BabbageEra StandardCrypto))
  (TxBody (BabbageEra StandardCrypto))
bodyTxL
                let spendableUTxO :: UTxO
spendableUTxO =
                      (TxIn, TxOut CtxUTxO) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn
healthyInitialTxIn, TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext TxOut CtxTx Era
healthyInitialTxOut)
                        UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
lookupUTxO
                        UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry

                [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
"Commit 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
"Commit tx has invalid aux data"
                      ]
                  , TxBody (BabbageEra StandardCrypto)
blueprintBody TxBody (BabbageEra StandardCrypto)
-> Getting
     ValidityInterval
     (TxBody (BabbageEra StandardCrypto))
     ValidityInterval
-> ValidityInterval
forall s a. s -> Getting a s a -> a
^. Getting
  ValidityInterval
  (TxBody (BabbageEra StandardCrypto))
  ValidityInterval
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody (BabbageEra StandardCrypto)) ValidityInterval
vldtTxBodyL ValidityInterval -> ValidityInterval -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxBody (BabbageEra StandardCrypto)
commitTxBody TxBody (BabbageEra StandardCrypto)
-> Getting
     ValidityInterval
     (TxBody (BabbageEra StandardCrypto))
     ValidityInterval
-> ValidityInterval
forall s a. s -> Getting a s a -> a
^. Getting
  ValidityInterval
  (TxBody (BabbageEra StandardCrypto))
  ValidityInterval
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody (BabbageEra StandardCrypto)) ValidityInterval
vldtTxBodyL
                      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 mismatch"
                  , (TxBody (BabbageEra StandardCrypto)
blueprintBody TxBody (BabbageEra StandardCrypto)
-> Getting
     (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
     (TxBody (BabbageEra StandardCrypto))
     (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
-> Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
inputsTxBodyL) Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
-> Set (TxIn (EraCrypto (BabbageEra StandardCrypto))) -> Property
forall a. (Show a, Ord a) => Set a -> Set a -> Property
`propIsSubsetOf` (TxBody (BabbageEra StandardCrypto)
commitTxBody TxBody (BabbageEra StandardCrypto)
-> Getting
     (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
     (TxBody (BabbageEra StandardCrypto))
     (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
-> Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
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"
                  , Bool -> Property
forall prop. Testable prop => prop -> Property
property
                      (((TxOut (BabbageEra StandardCrypto) -> Bool)
-> StrictSeq (TxOut (BabbageEra StandardCrypto)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`all` (TxBody (BabbageEra StandardCrypto)
blueprintBody TxBody (BabbageEra StandardCrypto)
-> Getting
     (StrictSeq (TxOut (BabbageEra StandardCrypto)))
     (TxBody (BabbageEra StandardCrypto))
     (StrictSeq (TxOut (BabbageEra StandardCrypto)))
-> StrictSeq (TxOut (BabbageEra StandardCrypto))
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
  (TxBody (BabbageEra StandardCrypto))
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
outputsTxBodyL)) (TxOut (BabbageEra StandardCrypto)
-> StrictSeq (TxOut (BabbageEra StandardCrypto)) -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` (TxBody (BabbageEra StandardCrypto)
commitTxBody TxBody (BabbageEra StandardCrypto)
-> Getting
     (StrictSeq (TxOut (BabbageEra StandardCrypto)))
     (TxBody (BabbageEra StandardCrypto))
     (StrictSeq (TxOut (BabbageEra StandardCrypto)))
-> StrictSeq (TxOut (BabbageEra StandardCrypto))
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
  (TxBody (BabbageEra StandardCrypto))
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
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 (BabbageEra StandardCrypto)
blueprintBody TxBody (BabbageEra StandardCrypto)
-> Getting
     (Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto))))
     (TxBody (BabbageEra StandardCrypto))
     (Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto))))
-> Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto)))
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto))))
  (TxBody (BabbageEra StandardCrypto))
  (Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto))))
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (KeyHash 'Witness (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto))))
reqSignerHashesTxBodyL) Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto)))
-> Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto)))
-> Property
forall a. (Show a, Ord a) => Set a -> Set a -> Property
`propIsSubsetOf` (TxBody (BabbageEra StandardCrypto)
commitTxBody TxBody (BabbageEra StandardCrypto)
-> Getting
     (Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto))))
     (TxBody (BabbageEra StandardCrypto))
     (Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto))))
-> Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto)))
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto))))
  (TxBody (BabbageEra StandardCrypto))
  (Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto))))
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (KeyHash 'Witness (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (KeyHash 'Witness (EraCrypto (BabbageEra StandardCrypto))))
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 (BabbageEra StandardCrypto)
blueprintBody TxBody (BabbageEra StandardCrypto)
-> Getting
     (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
     (TxBody (BabbageEra StandardCrypto))
     (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
-> Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
referenceInputsTxBodyL) Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
-> Set (TxIn (EraCrypto (BabbageEra StandardCrypto))) -> Property
forall a. (Show a, Ord a) => Set a -> Set a -> Property
`propIsSubsetOf` (TxBody (BabbageEra StandardCrypto)
commitTxBody TxBody (BabbageEra StandardCrypto)
-> Getting
     (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
     (TxBody (BabbageEra StandardCrypto))
     (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
-> Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
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"
                  ]

-- | 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 LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx AlonzoTx (BabbageEra StandardCrypto)
-> Getting
     (StrictMaybe (TxAuxData (BabbageEra StandardCrypto)))
     (AlonzoTx (BabbageEra StandardCrypto))
     (StrictMaybe (TxAuxData (BabbageEra StandardCrypto)))
-> StrictMaybe (TxAuxData (BabbageEra StandardCrypto))
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (TxAuxData (BabbageEra StandardCrypto)))
  (AlonzoTx (BabbageEra StandardCrypto))
  (StrictMaybe (TxAuxData (BabbageEra StandardCrypto)))
(StrictMaybe (TxAuxData (BabbageEra StandardCrypto))
 -> Const
      (StrictMaybe (TxAuxData (BabbageEra StandardCrypto)))
      (StrictMaybe (TxAuxData (BabbageEra StandardCrypto))))
-> Tx (BabbageEra StandardCrypto)
-> Const
     (StrictMaybe (TxAuxData (BabbageEra StandardCrypto)))
     (Tx (BabbageEra StandardCrypto))
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (AuxiliaryData era))
Lens'
  (Tx (BabbageEra StandardCrypto))
  (StrictMaybe (TxAuxData (BabbageEra StandardCrypto)))
auxDataTxL of
    StrictMaybe (TxAuxData (BabbageEra StandardCrypto))
SNothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    SJust TxAuxData (BabbageEra StandardCrypto)
auxData ->
      TxAuxData (BabbageEra StandardCrypto) -> Property
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxAuxData era) =>
TxAuxData era -> Property
isValid TxAuxData (BabbageEra StandardCrypto)
auxData Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. TxAuxData (BabbageEra StandardCrypto) -> Property
hashConsistent TxAuxData (BabbageEra StandardCrypto)
auxData
 where
  isValid :: TxAuxData era -> Property
isValid TxAuxData era
auxData =
    ProtVer -> TxAuxData era -> Bool
forall era. EraTxAuxData era => ProtVer -> TxAuxData era -> Bool
validateTxAuxData (PParams LedgerEra
PParams (BabbageEra StandardCrypto)
pparams PParams (BabbageEra StandardCrypto)
-> Getting ProtVer (PParams (BabbageEra StandardCrypto)) ProtVer
-> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams (BabbageEra StandardCrypto)) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams (BabbageEra StandardCrypto)) ProtVer
ppProtocolVersionL) TxAuxData era
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 (BabbageEra StandardCrypto) -> Property
hashConsistent TxAuxData (BabbageEra StandardCrypto)
auxData =
    Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx AlonzoTx (BabbageEra StandardCrypto)
-> Getting
     (StrictMaybe
        (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
     (AlonzoTx (BabbageEra StandardCrypto))
     (StrictMaybe
        (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
-> StrictMaybe
     (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto)))
forall s a. s -> Getting a s a -> a
^. (TxBody (BabbageEra StandardCrypto)
 -> Const
      (StrictMaybe
         (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
      (TxBody (BabbageEra StandardCrypto)))
-> AlonzoTx (BabbageEra StandardCrypto)
-> Const
     (StrictMaybe
        (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
     (AlonzoTx (BabbageEra StandardCrypto))
(TxBody (BabbageEra StandardCrypto)
 -> Const
      (StrictMaybe
         (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
      (TxBody (BabbageEra StandardCrypto)))
-> Tx (BabbageEra StandardCrypto)
-> Const
     (StrictMaybe
        (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
     (Tx (BabbageEra StandardCrypto))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens'
  (Tx (BabbageEra StandardCrypto))
  (TxBody (BabbageEra StandardCrypto))
bodyTxL ((TxBody (BabbageEra StandardCrypto)
  -> Const
       (StrictMaybe
          (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
       (TxBody (BabbageEra StandardCrypto)))
 -> AlonzoTx (BabbageEra StandardCrypto)
 -> Const
      (StrictMaybe
         (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
      (AlonzoTx (BabbageEra StandardCrypto)))
-> ((StrictMaybe
       (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto)))
     -> Const
          (StrictMaybe
             (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
          (StrictMaybe
             (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto)))))
    -> TxBody (BabbageEra StandardCrypto)
    -> Const
         (StrictMaybe
            (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
         (TxBody (BabbageEra StandardCrypto)))
-> Getting
     (StrictMaybe
        (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
     (AlonzoTx (BabbageEra StandardCrypto))
     (StrictMaybe
        (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe
   (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto)))
 -> Const
      (StrictMaybe
         (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
      (StrictMaybe
         (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto)))))
-> TxBody (BabbageEra StandardCrypto)
-> Const
     (StrictMaybe
        (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
     (TxBody (BabbageEra StandardCrypto))
forall era.
EraTxBody era =>
Lens'
  (TxBody era) (StrictMaybe (AuxiliaryDataHash (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (StrictMaybe
     (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))))
auxDataHashTxBodyL StrictMaybe
  (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto)))
-> StrictMaybe
     (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto)))
-> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))
-> StrictMaybe
     (AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto)))
forall a. a -> StrictMaybe a
SJust (TxAuxData (BabbageEra StandardCrypto)
-> AuxiliaryDataHash (EraCrypto (BabbageEra StandardCrypto))
forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData TxAuxData (BabbageEra StandardCrypto)
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
emptyTxBody)
      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)
forall {ctx}.
(UTxO' (TxOut ctx), TxBodyContent BuildTx)
-> Gen (UTxO' (TxOut ctx), 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)
forall {a} {buidl}.
(a, TxBodyContent buidl) -> Gen (a, TxBodyContent buidl)
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)
forall {a} {buidl}.
(a, TxBodyContent buidl) -> Gen (a, TxBodyContent buidl)
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)
forall {buidl}.
(UTxO, TxBodyContent buidl) -> Gen (UTxO, TxBodyContent buidl)
addCollateralInput
 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
addVkInputs (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 out. UTxO' out -> 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 = ShortByteString -> PlutusScript
PlutusScriptSerialised (ShortByteString -> PlutusScript)
-> ShortByteString -> PlutusScript
forall a b. (a -> b) -> a -> b
$ Natural -> ShortByteString
Plutus.alwaysSucceedingNAryFunction Natural
3
    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 genTxOut :: Gen (TxOut CtxUTxO)
genTxOut = do
          Value
value <- Gen Value
genValue
          let scriptAddress :: AddressInEra Era
scriptAddress = NetworkId -> PlutusScript -> AddressInEra Era
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 Era
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra Era
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)
genTxOut
    (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 -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs
            ( UTxO' (BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> TxIns BuildTx
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs (UTxO' (BuildTxWith BuildTx (Witness WitCtxTxIn Era))
 -> TxIns BuildTx)
-> UTxO' (BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> TxIns BuildTx
forall a b. (a -> b) -> a -> b
$
                ( \TxOut CtxUTxO
_ ->
                    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 (HashableScriptData -> ScriptDatum WitCtxTxIn
ScriptDatumForTxIn HashableScriptData
datum) HashableScriptData
redeemer
                )
                  (TxOut CtxUTxO -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> UTxO -> UTxO' (BuildTxWith BuildTx (Witness WitCtxTxIn Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO
utxoToSpend
            )
      )

  addSomeReferenceInputs :: (UTxO' (TxOut ctx), TxBodyContent BuildTx)
-> Gen (UTxO' (TxOut ctx), TxBodyContent BuildTx)
addSomeReferenceInputs (UTxO' (TxOut ctx)
utxo, TxBodyContent BuildTx
txbody) = do
    TxOut ctx
txout <- Gen (TxOut ctx)
forall ctx. Gen (TxOut ctx)
genTxOutWithReferenceScript
    TxIn
txin <- Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
    (UTxO' (TxOut ctx), TxBodyContent BuildTx)
-> Gen (UTxO' (TxOut ctx), TxBodyContent BuildTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO' (TxOut ctx)
utxo UTxO' (TxOut ctx) -> UTxO' (TxOut ctx) -> UTxO' (TxOut ctx)
forall a. Semigroup a => a -> a -> a
<> (TxIn, TxOut ctx) -> UTxO' (TxOut ctx)
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn
txin, TxOut ctx
txout), TxBodyContent BuildTx
txbody TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [TxIn
txin])

  addValidityRange :: (a, TxBodyContent buidl) -> Gen (a, TxBodyContent buidl)
addValidityRange (a
utxo, TxBodyContent buidl
txbody) = do
    (TxValidityLowerBound
start, TxValidityUpperBound
end) <- Gen (TxValidityLowerBound, TxValidityUpperBound)
forall a. Arbitrary a => Gen a
arbitrary
    (a, TxBodyContent buidl) -> Gen (a, TxBodyContent buidl)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( a
utxo
      , TxBodyContent buidl
txbody{txValidityLowerBound = start, txValidityUpperBound = end}
      )

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

  addCollateralInput :: (UTxO, TxBodyContent buidl) -> Gen (UTxO, TxBodyContent buidl)
addCollateralInput (UTxO
utxo, TxBodyContent buidl
txbody) = do
    UTxO
utxoToSpend <- Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
1
    (UTxO, TxBodyContent buidl) -> Gen (UTxO, TxBodyContent buidl)
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 buidl
txbody{txInsCollateral = TxInsCollateral $ toList (UTxO.inputSet utxoToSpend)}
      )

genMetadata :: Gen TxMetadataInEra
genMetadata :: Gen TxMetadataInEra
genMetadata = do
  forall era. Era era => Gen (ShelleyTxAuxData era)
genMetadata' @LedgerEra Gen (ShelleyTxAuxData (BabbageEra StandardCrypto))
-> (ShelleyTxAuxData (BabbageEra StandardCrypto)
    -> 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 LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx AlonzoTx (BabbageEra StandardCrypto)
-> Getting
     (StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto)))
     (AlonzoTx (BabbageEra StandardCrypto))
     (StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto)))
-> StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto))
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto)))
  (AlonzoTx (BabbageEra StandardCrypto))
  (StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto)))
(StrictMaybe (TxAuxData (BabbageEra StandardCrypto))
 -> Const
      (StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto)))
      (StrictMaybe (TxAuxData (BabbageEra StandardCrypto))))
-> Tx (BabbageEra StandardCrypto)
-> Const
     (StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto)))
     (Tx (BabbageEra StandardCrypto))
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (AuxiliaryData era))
Lens'
  (Tx (BabbageEra StandardCrypto))
  (StrictMaybe (TxAuxData (BabbageEra StandardCrypto)))
auxDataTxL of
    StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto))
SNothing -> Map Word64 Metadatum
forall a. Monoid a => a
mempty
    SJust (AlonzoTxAuxData Map Word64 Metadatum
m StrictSeq (Timelock (BabbageEra StandardCrypto))
_ Map Language (NonEmpty PlutusBinary)
_) -> Map Word64 Metadatum
m

prop_interestingBlueprintTx :: Property
prop_interestingBlueprintTx :: Property
prop_interestingBlueprintTx = do
  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
forall {ctx}. (UTxO' (TxOut ctx), 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
forall {era} {ctx}.
(Share (TxOut (ShelleyLedgerEra era))
 ~ Interns (Credential 'Staking StandardCrypto),
 EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto,
 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),
 HashAnnotated
   (TxBody (ShelleyLedgerEra era))
   EraIndependentTxBody
   StandardCrypto,
 HashAnnotated
   (TxAuxData (ShelleyLedgerEra era))
   EraIndependentTxAuxData
   StandardCrypto) =>
(UTxO' (TxOut ctx), Tx era) -> 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
forall {era} {ctx}.
(Share (TxOut (ShelleyLedgerEra era))
 ~ Interns (Credential 'Staking StandardCrypto),
 EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto,
 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),
 HashAnnotated
   (TxBody (ShelleyLedgerEra era))
   EraIndependentTxBody
   StandardCrypto,
 HashAnnotated
   (TxAuxData (ShelleyLedgerEra era))
   EraIndependentTxAuxData
   StandardCrypto) =>
(UTxO' (TxOut ctx), Tx era) -> Bool
spendsFromPubKey (UTxO
utxo, Tx
tx) Bool -> Bool -> Bool
&& (UTxO, Tx) -> Bool
forall {ctx}. (UTxO' (TxOut ctx), 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
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),
 BabbageEraTxBody (ShelleyLedgerEra era)) =>
Tx era -> Bool
hasReferenceInputs Tx
tx) String
"blueprint has reference input"
 where
  hasReferenceInputs :: Tx era -> Bool
hasReferenceInputs Tx era
tx =
    Bool -> Bool
not (Bool -> Bool)
-> (Set (TxIn (EraCrypto (ShelleyLedgerEra era))) -> Bool)
-> Set (TxIn (EraCrypto (ShelleyLedgerEra era)))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (TxIn (EraCrypto (ShelleyLedgerEra era))) -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set (TxIn (EraCrypto (ShelleyLedgerEra era))) -> Bool)
-> Set (TxIn (EraCrypto (ShelleyLedgerEra era))) -> Bool
forall a b. (a -> b) -> a -> b
$ Tx era -> Tx (ShelleyLedgerEra era)
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx era
tx Tx (ShelleyLedgerEra era)
-> Getting
     (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
     (Tx (ShelleyLedgerEra era))
     (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
-> Set (TxIn (EraCrypto (ShelleyLedgerEra era)))
forall s a. s -> Getting a s a -> a
^. (TxBody (ShelleyLedgerEra era)
 -> Const
      (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
      (TxBody (ShelleyLedgerEra era)))
-> Tx (ShelleyLedgerEra era)
-> Const
     (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
     (Tx (ShelleyLedgerEra era))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx (ShelleyLedgerEra era)) (TxBody (ShelleyLedgerEra era))
bodyTxL ((TxBody (ShelleyLedgerEra era)
  -> Const
       (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
       (TxBody (ShelleyLedgerEra era)))
 -> Tx (ShelleyLedgerEra era)
 -> Const
      (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
      (Tx (ShelleyLedgerEra era)))
-> ((Set (TxIn (EraCrypto (ShelleyLedgerEra era)))
     -> Const
          (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
          (Set (TxIn (EraCrypto (ShelleyLedgerEra era)))))
    -> TxBody (ShelleyLedgerEra era)
    -> Const
         (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
         (TxBody (ShelleyLedgerEra era)))
-> Getting
     (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
     (Tx (ShelleyLedgerEra era))
     (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (TxIn (EraCrypto (ShelleyLedgerEra era)))
 -> Const
      (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
      (Set (TxIn (EraCrypto (ShelleyLedgerEra era)))))
-> TxBody (ShelleyLedgerEra era)
-> Const
     (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
     (TxBody (ShelleyLedgerEra era))
forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (ShelleyLedgerEra era))
  (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
referenceInputsTxBodyL

  spendsFromPubKey :: (UTxO' (TxOut ctx), Tx era) -> Bool
spendsFromPubKey (UTxO' (TxOut ctx)
utxo, Tx era
tx) =
    (TxIn StandardCrypto -> Bool) -> Set (TxIn StandardCrypto) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
      ( \TxIn StandardCrypto
txIn -> case TxIn -> UTxO' (TxOut ctx) -> Maybe (TxOut ctx)
forall out. TxIn -> UTxO' out -> Maybe out
UTxO.resolve (TxIn StandardCrypto -> TxIn
fromLedgerTxIn TxIn StandardCrypto
txIn) UTxO' (TxOut ctx)
utxo of
          Just (TxOut (ShelleyAddressInEra (ShelleyAddress Network
_ (KeyHashObj KeyHash 'Payment StandardCrypto
_) StakeReference StandardCrypto
_)) Value
_ TxOutDatum ctx
_ ReferenceScript
_) -> Bool
True
          Maybe (TxOut ctx)
_ -> Bool
False
      )
      (Set (TxIn StandardCrypto) -> Bool)
-> Set (TxIn StandardCrypto) -> Bool
forall a b. (a -> b) -> a -> b
$ Tx era -> Tx (ShelleyLedgerEra era)
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx era
tx Tx (ShelleyLedgerEra era)
-> Getting
     (Set (TxIn StandardCrypto))
     (Tx (ShelleyLedgerEra era))
     (Set (TxIn StandardCrypto))
-> Set (TxIn StandardCrypto)
forall s a. s -> Getting a s a -> a
^. (TxBody (ShelleyLedgerEra era)
 -> Const
      (Set (TxIn StandardCrypto)) (TxBody (ShelleyLedgerEra era)))
-> Tx (ShelleyLedgerEra era)
-> Const (Set (TxIn StandardCrypto)) (Tx (ShelleyLedgerEra era))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx (ShelleyLedgerEra era)) (TxBody (ShelleyLedgerEra era))
bodyTxL ((TxBody (ShelleyLedgerEra era)
  -> Const
       (Set (TxIn StandardCrypto)) (TxBody (ShelleyLedgerEra era)))
 -> Tx (ShelleyLedgerEra era)
 -> Const (Set (TxIn StandardCrypto)) (Tx (ShelleyLedgerEra era)))
-> ((Set (TxIn StandardCrypto)
     -> Const (Set (TxIn StandardCrypto)) (Set (TxIn StandardCrypto)))
    -> TxBody (ShelleyLedgerEra era)
    -> Const
         (Set (TxIn StandardCrypto)) (TxBody (ShelleyLedgerEra era)))
-> Getting
     (Set (TxIn StandardCrypto))
     (Tx (ShelleyLedgerEra era))
     (Set (TxIn StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (TxIn StandardCrypto)
 -> Const (Set (TxIn StandardCrypto)) (Set (TxIn StandardCrypto)))
-> TxBody (ShelleyLedgerEra era)
-> Const
     (Set (TxIn StandardCrypto)) (TxBody (ShelleyLedgerEra era))
(Set (TxIn (EraCrypto (ShelleyLedgerEra era)))
 -> Const
      (Set (TxIn StandardCrypto))
      (Set (TxIn (EraCrypto (ShelleyLedgerEra era)))))
-> TxBody (ShelleyLedgerEra era)
-> Const
     (Set (TxIn StandardCrypto)) (TxBody (ShelleyLedgerEra era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (ShelleyLedgerEra era))
  (Set (TxIn (EraCrypto (ShelleyLedgerEra era))))
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' (TxOut ctx), Tx) -> Bool
spendsFromScript (UTxO' (TxOut ctx)
utxo, Tx
tx) =
    (TxIn StandardCrypto -> Bool) -> Set (TxIn StandardCrypto) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
      ( \TxIn StandardCrypto
txIn -> case TxIn -> UTxO' (TxOut ctx) -> Maybe (TxOut ctx)
forall out. TxIn -> UTxO' out -> Maybe out
UTxO.resolve (TxIn StandardCrypto -> TxIn
fromLedgerTxIn TxIn StandardCrypto
txIn) UTxO' (TxOut ctx)
utxo of
          Just (TxOut (ShelleyAddressInEra (ShelleyAddress Network
_ (ScriptHashObj ScriptHash StandardCrypto
_) StakeReference StandardCrypto
_)) Value
_ TxOutDatum ctx
_ ReferenceScript
_) -> Bool
True
          Maybe (TxOut ctx)
_ -> Bool
False
      )
      (Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx AlonzoTx (BabbageEra StandardCrypto)
-> Getting
     (Set (TxIn StandardCrypto))
     (AlonzoTx (BabbageEra StandardCrypto))
     (Set (TxIn StandardCrypto))
-> Set (TxIn StandardCrypto)
forall s a. s -> Getting a s a -> a
^. (TxBody (BabbageEra StandardCrypto)
 -> Const
      (Set (TxIn StandardCrypto)) (TxBody (BabbageEra StandardCrypto)))
-> AlonzoTx (BabbageEra StandardCrypto)
-> Const
     (Set (TxIn StandardCrypto)) (AlonzoTx (BabbageEra StandardCrypto))
(TxBody (BabbageEra StandardCrypto)
 -> Const
      (Set (TxIn StandardCrypto)) (TxBody (BabbageEra StandardCrypto)))
-> Tx (BabbageEra StandardCrypto)
-> Const
     (Set (TxIn StandardCrypto)) (Tx (BabbageEra StandardCrypto))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens'
  (Tx (BabbageEra StandardCrypto))
  (TxBody (BabbageEra StandardCrypto))
bodyTxL ((TxBody (BabbageEra StandardCrypto)
  -> Const
       (Set (TxIn StandardCrypto)) (TxBody (BabbageEra StandardCrypto)))
 -> AlonzoTx (BabbageEra StandardCrypto)
 -> Const
      (Set (TxIn StandardCrypto)) (AlonzoTx (BabbageEra StandardCrypto)))
-> ((Set (TxIn StandardCrypto)
     -> Const (Set (TxIn StandardCrypto)) (Set (TxIn StandardCrypto)))
    -> TxBody (BabbageEra StandardCrypto)
    -> Const
         (Set (TxIn StandardCrypto)) (TxBody (BabbageEra StandardCrypto)))
-> Getting
     (Set (TxIn StandardCrypto))
     (AlonzoTx (BabbageEra StandardCrypto))
     (Set (TxIn StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (TxIn StandardCrypto)
 -> Const (Set (TxIn StandardCrypto)) (Set (TxIn StandardCrypto)))
-> TxBody (BabbageEra StandardCrypto)
-> Const
     (Set (TxIn StandardCrypto)) (TxBody (BabbageEra StandardCrypto))
(Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
 -> Const
      (Set (TxIn StandardCrypto))
      (Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))))
-> TxBody (BabbageEra StandardCrypto)
-> Const
     (Set (TxIn StandardCrypto)) (TxBody (BabbageEra StandardCrypto))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
inputsTxBodyL)
      Bool -> Bool -> Bool
&& (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto) -> Bool)
-> Set (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto))
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
        ( \case
            AlonzoSpending AsIndex Word32 (TxIn (EraCrypto (BabbageEra StandardCrypto)))
_ -> Bool
True
            AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto)
_ -> Bool
False
        )
        ( Map
  (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto))
  (Data (BabbageEra StandardCrypto), ExUnits)
-> Set (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto))
forall k a. Map k a -> Set k
Map.keysSet
            (Map
   (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto))
   (Data (BabbageEra StandardCrypto), ExUnits)
 -> Set (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto)))
-> (Redeemers (BabbageEra StandardCrypto)
    -> Map
         (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto))
         (Data (BabbageEra StandardCrypto), ExUnits))
-> Redeemers (BabbageEra StandardCrypto)
-> Set (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Redeemers (BabbageEra StandardCrypto)
-> Map
     (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto))
     (Data (BabbageEra StandardCrypto), ExUnits)
Redeemers (BabbageEra StandardCrypto)
-> Map
     (PlutusPurpose AsIndex (BabbageEra StandardCrypto))
     (Data (BabbageEra StandardCrypto), ExUnits)
forall era.
Redeemers era
-> Map (PlutusPurpose AsIndex era) (Data era, ExUnits)
unRedeemers
            (Redeemers (BabbageEra StandardCrypto)
 -> Set (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto)))
-> Redeemers (BabbageEra StandardCrypto)
-> Set (AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$ forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx @Era Tx
tx AlonzoTx (BabbageEra StandardCrypto)
-> Getting
     (Redeemers (BabbageEra StandardCrypto))
     (AlonzoTx (BabbageEra StandardCrypto))
     (Redeemers (BabbageEra StandardCrypto))
-> Redeemers (BabbageEra StandardCrypto)
forall s a. s -> Getting a s a -> a
^. (TxWits (BabbageEra StandardCrypto)
 -> Const
      (Redeemers (BabbageEra StandardCrypto))
      (TxWits (BabbageEra StandardCrypto)))
-> AlonzoTx (BabbageEra StandardCrypto)
-> Const
     (Redeemers (BabbageEra StandardCrypto))
     (AlonzoTx (BabbageEra StandardCrypto))
(TxWits (BabbageEra StandardCrypto)
 -> Const
      (Redeemers (BabbageEra StandardCrypto))
      (TxWits (BabbageEra StandardCrypto)))
-> Tx (BabbageEra StandardCrypto)
-> Const
     (Redeemers (BabbageEra StandardCrypto))
     (Tx (BabbageEra StandardCrypto))
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens'
  (Tx (BabbageEra StandardCrypto))
  (TxWits (BabbageEra StandardCrypto))
witsTxL ((TxWits (BabbageEra StandardCrypto)
  -> Const
       (Redeemers (BabbageEra StandardCrypto))
       (TxWits (BabbageEra StandardCrypto)))
 -> AlonzoTx (BabbageEra StandardCrypto)
 -> Const
      (Redeemers (BabbageEra StandardCrypto))
      (AlonzoTx (BabbageEra StandardCrypto)))
-> ((Redeemers (BabbageEra StandardCrypto)
     -> Const
          (Redeemers (BabbageEra StandardCrypto))
          (Redeemers (BabbageEra StandardCrypto)))
    -> TxWits (BabbageEra StandardCrypto)
    -> Const
         (Redeemers (BabbageEra StandardCrypto))
         (TxWits (BabbageEra StandardCrypto)))
-> Getting
     (Redeemers (BabbageEra StandardCrypto))
     (AlonzoTx (BabbageEra StandardCrypto))
     (Redeemers (BabbageEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers (BabbageEra StandardCrypto)
 -> Const
      (Redeemers (BabbageEra StandardCrypto))
      (Redeemers (BabbageEra StandardCrypto)))
-> TxWits (BabbageEra StandardCrypto)
-> Const
     (Redeemers (BabbageEra StandardCrypto))
     (TxWits (BabbageEra StandardCrypto))
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens'
  (TxWits (BabbageEra StandardCrypto))
  (Redeemers (BabbageEra StandardCrypto))
rdmrsTxWitsL
        )

withinTxExecutionBudget :: EvaluationReport -> Property
withinTxExecutionBudget :: EvaluationReport -> Property
withinTxExecutionBudget EvaluationReport
report =
  (Natural
totalMem Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxMem Bool -> Bool -> Bool
&& Natural
totalCpu Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxCpu)
    Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      ( String
"Ex. Cost Limits exceeded, mem: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (Show a, IsString b) => a -> b
show Natural
totalMem
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (Show a, IsString b) => a -> b
show Natural
maxMem
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", cpu: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (Show a, IsString b) => a -> b
show Natural
totalCpu
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (Show a, IsString b) => a -> b
show Natural
maxCpu
      )
 where
  budgets :: [ExecutionUnits]
budgets = [Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits]
forall a b. [Either a b] -> [b]
rights ([Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits])
-> [Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits]
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems EvaluationReport
report
  totalMem :: Natural
totalMem = [Natural] -> Natural
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ ExecutionUnits -> Natural
executionMemory (ExecutionUnits -> Natural) -> [ExecutionUnits] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExecutionUnits]
budgets
  totalCpu :: Natural
totalCpu = [Natural] -> Natural
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ ExecutionUnits -> Natural
executionSteps (ExecutionUnits -> Natural) -> [ExecutionUnits] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExecutionUnits]
budgets
  ExecutionUnits
    { executionMemory :: ExecutionUnits -> Natural
executionMemory = Natural
maxMem
    , executionSteps :: ExecutionUnits -> Natural
executionSteps = Natural
maxCpu
    } = ExecutionUnits
maxTxExecutionUnits

-- | Generate a UTXO representing /commit/ outputs for a given list of `Party`.
-- NOTE: Uses 'testPolicyId' for the datum.
-- NOTE: We don't generate empty commits and it is used only at one place so perhaps move it?
-- FIXME: This function is very complicated and it's hard to understand it after a while
generateCommitUTxOs :: [Party] -> Gen (Map.Map TxIn (TxOut CtxUTxO, UTxO))
generateCommitUTxOs :: [Party] -> Gen (Map TxIn (TxOut CtxUTxO, UTxO))
generateCommitUTxOs [Party]
parties = do
  [TxIn]
txins <- Int -> Gen TxIn -> Gen [TxIn]
forall a. Int -> Gen a -> Gen [a]
vectorOf ([Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
parties) (forall a. Arbitrary a => Gen a
arbitrary @TxIn)
  let vks :: [(VerificationKey PaymentKey, Party)]
vks = (\Party
p -> (Gen (VerificationKey PaymentKey)
genVerificationKey Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
`genForParty` Party
p, Party
p)) (Party -> (VerificationKey PaymentKey, Party))
-> [Party] -> [(VerificationKey PaymentKey, Party)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
  [UTxO]
committedUTxO <-
    Int -> Gen UTxO -> Gen [UTxO]
forall a. Int -> Gen a -> Gen [a]
vectorOf ([Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
parties) (Gen UTxO -> Gen [UTxO]) -> Gen UTxO -> Gen [UTxO]
forall a b. (a -> b) -> a -> b
$
      (TxOut CtxUTxO -> TxOut CtxUTxO) -> UTxO -> UTxO
forall a b. (a -> b) -> UTxO' a -> UTxO' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut CtxUTxO -> TxOut CtxUTxO
adaOnly (UTxO -> UTxO) -> Gen UTxO -> Gen UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor (VerificationKey PaymentKey -> Gen UTxO)
-> Gen (VerificationKey PaymentKey) -> Gen UTxO
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary)
  let commitUTxO :: [(TxIn, (TxOut CtxUTxO, UTxO))]
commitUTxO =
        [TxIn]
-> [(TxOut CtxUTxO, UTxO)] -> [(TxIn, (TxOut CtxUTxO, UTxO))]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxIn]
txins ([(TxOut CtxUTxO, UTxO)] -> [(TxIn, (TxOut CtxUTxO, UTxO))])
-> [(TxOut CtxUTxO, UTxO)] -> [(TxIn, (TxOut CtxUTxO, UTxO))]
forall a b. (a -> b) -> a -> b
$
          ((VerificationKey PaymentKey, Party)
 -> UTxO -> (TxOut CtxUTxO, UTxO))
-> ((VerificationKey PaymentKey, Party), UTxO)
-> (TxOut CtxUTxO, UTxO)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (VerificationKey PaymentKey, Party)
-> UTxO -> (TxOut CtxUTxO, UTxO)
mkCommitUTxO (((VerificationKey PaymentKey, Party), UTxO)
 -> (TxOut CtxUTxO, UTxO))
-> [((VerificationKey PaymentKey, Party), UTxO)]
-> [(TxOut CtxUTxO, UTxO)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(VerificationKey PaymentKey, Party)]
-> [UTxO] -> [((VerificationKey PaymentKey, Party), UTxO)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(VerificationKey PaymentKey, Party)]
vks [UTxO]
committedUTxO
  Map TxIn (TxOut CtxUTxO, UTxO)
-> Gen (Map TxIn (TxOut CtxUTxO, UTxO))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (TxOut CtxUTxO, UTxO)
 -> Gen (Map TxIn (TxOut CtxUTxO, UTxO)))
-> Map TxIn (TxOut CtxUTxO, UTxO)
-> Gen (Map TxIn (TxOut CtxUTxO, UTxO))
forall a b. (a -> b) -> a -> b
$ [(TxIn, (TxOut CtxUTxO, UTxO))] -> Map TxIn (TxOut CtxUTxO, UTxO)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxIn, (TxOut CtxUTxO, UTxO))]
commitUTxO
 where
  mkCommitUTxO :: (VerificationKey PaymentKey, Party) -> UTxO -> (TxOut CtxUTxO, UTxO)
  mkCommitUTxO :: (VerificationKey PaymentKey, Party)
-> UTxO -> (TxOut CtxUTxO, UTxO)
mkCommitUTxO (VerificationKey PaymentKey
vk, Party
party) UTxO
utxo =
    ( TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext (TxOut CtxTx Era -> TxOut CtxUTxO)
-> TxOut CtxTx Era -> TxOut CtxUTxO
forall a b. (a -> b) -> a -> b
$
        AddressInEra Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
          (forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
testNetworkId PlutusScript
forall {lang}. PlutusScript lang
commitScript)
          Value
commitValue
          (Datum -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline Datum
commitDatum)
          ReferenceScript
ReferenceScriptNone
    , UTxO
utxo
    )
   where
    commitValue :: Value
commitValue =
      [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat
        [ Coin -> Value
lovelaceToValue (Integer -> Coin
Coin Integer
2000000)
        , (TxOut CtxUTxO -> Value) -> UTxO -> Value
forall m a. Monoid m => (a -> m) -> UTxO' 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 UTxO
utxo
        , [(AssetId, Quantity)] -> Value
valueFromList
            [ (PolicyId -> AssetName -> AssetId
AssetId PolicyId
testPolicyId (VerificationKey PaymentKey -> AssetName
assetNameFromVerificationKey VerificationKey PaymentKey
vk), Quantity
1)
            ]
        ]

    commitScript :: PlutusScript lang
commitScript = ShortByteString -> PlutusScript lang
forall lang. ShortByteString -> PlutusScript lang
fromPlutusScript ShortByteString
Commit.validatorScript

    commitDatum :: Datum
commitDatum = Party -> UTxO -> CurrencySymbol -> Datum
mkCommitDatum Party
party UTxO
utxo (PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
testPolicyId)

prettyEvaluationReport :: EvaluationReport -> String
prettyEvaluationReport :: EvaluationReport -> String
prettyEvaluationReport (EvaluationReport
-> [(ScriptWitnessIndex,
     Either ScriptExecutionError ExecutionUnits)]
forall k a. Map k a -> [(k, a)]
Map.toList -> [(ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)]
xs) =
  String
"Script Evaluation(s):\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)
-> String
prettyKeyValue ((ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)
 -> String)
-> [(ScriptWitnessIndex,
     Either ScriptExecutionError ExecutionUnits)]
-> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)]
xs)
 where
  prettyKeyValue :: (ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)
-> String
prettyKeyValue (ScriptWitnessIndex
ptr, Either ScriptExecutionError ExecutionUnits
result) =
    Text -> String
forall a. ToString a => a -> String
toString (Text
"  - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptWitnessIndex -> Text
forall b a. (Show a, IsString b) => a -> b
show ScriptWitnessIndex
ptr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Either ScriptExecutionError ExecutionUnits -> Text
prettyResult Either ScriptExecutionError ExecutionUnits
result)
  prettyResult :: Either ScriptExecutionError ExecutionUnits -> Text
prettyResult =
    (ScriptExecutionError -> Text)
-> (ExecutionUnits -> Text)
-> Either ScriptExecutionError ExecutionUnits
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\n" Text
" " (Text -> Text)
-> (ScriptExecutionError -> Text) -> ScriptExecutionError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptExecutionError -> Text
forall b a. (Show a, IsString b) => a -> b
show) ExecutionUnits -> Text
forall b a. (Show a, IsString b) => a -> b
show

-- NOTE: Uses 'testPolicyId' for the datum.
genAbortableOutputs :: [Party] -> Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
genAbortableOutputs :: [Party]
-> Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
genAbortableOutputs [Party]
parties =
  Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
go
 where
  go :: Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
go = do
    ([Party]
initParties, [Party]
commitParties) <- (Int -> [Party] -> ([Party], [Party])
forall a. Int -> [a] -> ([a], [a])
`splitAt` [Party]
parties) (Int -> ([Party], [Party])) -> Gen Int -> Gen ([Party], [Party])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, [Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
parties)
    [(TxIn, TxOut CtxUTxO)]
initials <- (Party -> Gen (TxIn, TxOut CtxUTxO))
-> [Party] -> Gen [(TxIn, TxOut CtxUTxO)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Party -> Gen (TxIn, TxOut CtxUTxO)
genInitial [Party]
initParties
    [(TxIn, TxOut CtxUTxO, UTxO)]
commits <- ((TxIn, (TxOut CtxUTxO, UTxO)) -> (TxIn, TxOut CtxUTxO, UTxO))
-> [(TxIn, (TxOut CtxUTxO, UTxO))] -> [(TxIn, TxOut CtxUTxO, UTxO)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TxIn
a, (TxOut CtxUTxO
b, UTxO
c)) -> (TxIn
a, TxOut CtxUTxO
b, UTxO
c)) ([(TxIn, (TxOut CtxUTxO, UTxO))] -> [(TxIn, TxOut CtxUTxO, UTxO)])
-> (Map TxIn (TxOut CtxUTxO, UTxO)
    -> [(TxIn, (TxOut CtxUTxO, UTxO))])
-> Map TxIn (TxOut CtxUTxO, UTxO)
-> [(TxIn, TxOut CtxUTxO, UTxO)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (TxOut CtxUTxO, UTxO) -> [(TxIn, (TxOut CtxUTxO, UTxO))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map TxIn (TxOut CtxUTxO, UTxO) -> [(TxIn, TxOut CtxUTxO, UTxO)])
-> Gen (Map TxIn (TxOut CtxUTxO, UTxO))
-> Gen [(TxIn, TxOut CtxUTxO, UTxO)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party] -> Gen (Map TxIn (TxOut CtxUTxO, UTxO))
generateCommitUTxOs [Party]
commitParties
    ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
-> Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(TxIn, TxOut CtxUTxO)]
initials, [(TxIn, TxOut CtxUTxO, UTxO)]
commits)

  genInitial :: Party -> Gen (TxIn, TxOut CtxUTxO)
genInitial Party
p =
    VerificationKey PaymentKey -> TxIn -> (TxIn, TxOut CtxUTxO)
mkInitial (Gen (VerificationKey PaymentKey)
genVerificationKey Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
`genForParty` Party
p) (TxIn -> (TxIn, TxOut CtxUTxO))
-> Gen TxIn -> Gen (TxIn, TxOut CtxUTxO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary

  mkInitial ::
    VerificationKey PaymentKey ->
    TxIn ->
    (TxIn, TxOut CtxUTxO)
  mkInitial :: VerificationKey PaymentKey -> TxIn -> (TxIn, TxOut CtxUTxO)
mkInitial VerificationKey PaymentKey
vk TxIn
txin =
    ( TxIn
txin
    , VerificationKey PaymentKey -> TxOut CtxUTxO
initialTxOut VerificationKey PaymentKey
vk
    )

  initialTxOut :: VerificationKey PaymentKey -> TxOut CtxUTxO
  initialTxOut :: VerificationKey PaymentKey -> TxOut CtxUTxO
initialTxOut VerificationKey PaymentKey
vk =
    TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext (TxOut CtxTx Era -> TxOut CtxUTxO)
-> TxOut CtxTx Era -> TxOut CtxUTxO
forall a b. (a -> b) -> a -> b
$
      AddressInEra Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
        (forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
testNetworkId PlutusScript
forall {lang}. PlutusScript lang
initialScript)
        ([(AssetId, Quantity)] -> Value
valueFromList [(PolicyId -> AssetName -> AssetId
AssetId PolicyId
testPolicyId (VerificationKey PaymentKey -> AssetName
assetNameFromVerificationKey VerificationKey PaymentKey
vk), Quantity
1)])
        (Datum -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline Datum
initialDatum)
        ReferenceScript
ReferenceScriptNone

  initialScript :: PlutusScript lang
initialScript = ShortByteString -> PlutusScript lang
forall lang. ShortByteString -> PlutusScript lang
fromPlutusScript ShortByteString
Initial.validatorScript

  initialDatum :: Datum
initialDatum = CurrencySymbol -> Datum
Initial.datum (PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
testPolicyId)

assetNameFromVerificationKey :: VerificationKey PaymentKey -> AssetName
assetNameFromVerificationKey :: VerificationKey PaymentKey -> AssetName
assetNameFromVerificationKey =
  OnChainId -> AssetName
onChainIdToAssetName (OnChainId -> AssetName)
-> (VerificationKey PaymentKey -> OnChainId)
-> VerificationKey PaymentKey
-> AssetName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId

fst3 :: (a, b, c) -> a
fst3 :: forall a b c. (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a

third :: (a, b, c) -> c
third :: forall a b c. (a, b, c) -> c
third (a
_, b
_, c
c) = c
c

drop2nd :: (a, b, c) -> (a, c)
drop2nd :: forall a b c. (a, b, c) -> (a, c)
drop2nd (a
a, b
_, c
c) = (a
a, c
c)

drop3rd :: (a, b, c) -> (a, b)
drop3rd :: forall a b c. (a, b, c) -> (a, b)
drop3rd (a
a, b
b, c
_) = (a
a, b
b)

tripleToPair :: (a, b, c) -> (a, (b, c))
tripleToPair :: forall a b c. (a, b, c) -> (a, (b, c))
tripleToPair (a
a, b
b, c
c) = (a
a, (b
b, c
c))