Skip to content

Commit

Permalink
Make sure to generate interesting transactions in genBlueprintTx
Browse files Browse the repository at this point in the history
  • Loading branch information
Sasha Bogicevic committed Apr 18, 2024
1 parent 987e9bc commit 16d17c8
Showing 1 changed file with 174 additions and 119 deletions.
293 changes: 174 additions & 119 deletions hydra-node/test/Hydra/Chain/Direct/TxSpec.hs
View file
Expand Up @@ -17,8 +17,6 @@ import Cardano.Ledger.Api (
bodyTxL,
inputsTxBodyL,
mkAlonzoTxAuxData,
mkBasicTx,
mkBasicTxBody,
outputsTxBodyL,
rdmrsTxWitsL,
referenceInputsTxBodyL,
Expand All @@ -30,15 +28,14 @@ import Cardano.Ledger.Api (
import Cardano.Ledger.Core (EraTx (getMinFeeTx))
import Cardano.Ledger.Credential (Credential (..))
import Control.Lens ((.~), (^.))
import Data.List qualified as List
import Data.Map qualified as Map
import Data.Maybe.Strict (StrictMaybe (..), fromSMaybe)
import Data.Set qualified as Set
import Data.Text (pack)
import Data.Text qualified as T
import Hydra.Cardano.Api
import Hydra.Cardano.Api.Prelude (toShelleyMetadata)
import Hydra.Cardano.Api.Pretty (renderTx)
import Hydra.Cardano.Api.Pretty (renderTx, renderTxWithUTxO)
import Hydra.Chain (CommitTxDraft (..), HeadParameters (..))
import Hydra.Chain.Direct.Contract.Commit (commitSigningKey, healthyInitialTxIn, healthyInitialTxOut)
import Hydra.Chain.Direct.Fixture (
Expand All @@ -58,12 +55,14 @@ 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, genOneUTxOFor, genUTxOSized, genVerificationKey)
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.Hydra.Fixture (genForParty)
import Test.Hydra.Prelude
import Test.QuickCheck (
Positive (getPositive),
Property,
choose,
conjoin,
Expand Down Expand Up @@ -173,109 +172,103 @@ spec =
& counterexample (show e)

describe "commitTx" $ do
prop "genBlueprintTx generates interesting txs" prop_interestingBlueprintTx

prop "Validate blueprint and commit transactions" $ do
forAllBlind arbitrary $ \chainContext -> do
let ChainContext{networkId, ownVerificationKey, ownParty, scriptRegistry} =
chainContext{ownVerificationKey = getVerificationKey commitSigningKey, networkId = testNetworkId}
forAll (choose (1, 6)) $ \noOfOutputs ->
forAllBlind (genUTxOSized noOfOutputs) $ \lookupUTxO ->
forAllShrinkShow (genBlueprintTx lookupUTxO) shrink (\tx -> "Blueprint: " <> renderTx tx) $ \draftTx' -> do
-- let blueprintTx' =
-- -- Alter the _blueprint_ tx to add interesting transaction
-- -- data we expect to see preserved in the commit tx
-- addRequiredSignatures vks $
-- addValidityRange startAndEndValidity $
-- addRandomMetadata labelAndMetadata (txSpendingUTxO lookupUTxO)
let commitTx' =
commitTx
networkId
scriptRegistry
(mkHeadId Fixture.testPolicyId)
ownParty
CommitTxDraft{lookupUTxO, draftTx = draftTx'}
(healthyInitialTxIn, toUTxOContext healthyInitialTxOut, verificationKeyHash ownVerificationKey)
let blueprintTx = toLedgerTx draftTx'
let blueprintBody = blueprintTx ^. bodyTxL
let tx = toLedgerTx commitTx'
let commitTxBody = tx ^. bodyTxL

let spendsFromPubKey =
any
( \txIn -> case UTxO.resolve (fromLedgerTxIn txIn) lookupUTxO of
Just (TxOut (ShelleyAddressInEra (ShelleyAddress _ (KeyHashObj _) _)) _ _ _) -> True
_ -> False
)
$ blueprintTx ^. bodyTxL . 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.
let spendsFromScript =
any
( \txIn -> case UTxO.resolve (fromLedgerTxIn txIn) lookupUTxO of
Just (TxOut (ShelleyAddressInEra (ShelleyAddress _ (ScriptHashObj _) _)) _ _ _) -> True
_ -> False
forAllShrinkShow genBlueprintTxWithUTxO shrink (\(utxo, tx) -> "Blueprint: " <> renderTxWithUTxO utxo tx) $ \(lookupUTxO, draftTx') -> do
let commitTx' =
commitTx
networkId
scriptRegistry
(mkHeadId Fixture.testPolicyId)
ownParty
CommitTxDraft{lookupUTxO, draftTx = draftTx'}
(healthyInitialTxIn, toUTxOContext healthyInitialTxOut, verificationKeyHash ownVerificationKey)
let blueprintTx = toLedgerTx draftTx'
let blueprintBody = blueprintTx ^. bodyTxL
let tx = toLedgerTx commitTx'
let commitTxBody = tx ^. bodyTxL

let spendsFromPubKey =
any
( \txIn -> case UTxO.resolve (fromLedgerTxIn txIn) lookupUTxO of
Just (TxOut (ShelleyAddressInEra (ShelleyAddress _ (KeyHashObj _) _)) _ _ _) -> True
_ -> False
)
$ blueprintTx ^. bodyTxL . 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.
let spendsFromScript =
any
( \txIn -> case UTxO.resolve (fromLedgerTxIn txIn) lookupUTxO of
Just (TxOut (ShelleyAddressInEra (ShelleyAddress _ (ScriptHashObj _) _)) _ _ _) -> True
_ -> False
)
(blueprintTx ^. bodyTxL . inputsTxBodyL)
&& any
( \case
AlonzoSpending _ -> True
_ -> False
)
( Map.keysSet
. unRedeemers
$ blueprintTx ^. witsTxL . rdmrsTxWitsL
)

let spendableUTxO =
UTxO.singleton (healthyInitialTxIn, toUTxOContext healthyInitialTxOut)
<> lookupUTxO
<> registryUTxO scriptRegistry

checkCoverage $
conjoin
[ propTransactionEvaluates (draftTx', lookupUTxO)
& counterexample "Blueprint transaction failed to evaluate"
, propTransactionEvaluates (commitTx', spendableUTxO)
& counterexample "Commit transaction failed to evaluate"
, let blueprintMetadata = fromSMaybe mempty $ getAuxMetadata <$> blueprintTx ^. auxDataTxL
commitMetadata = fromSMaybe mempty $ getAuxMetadata <$> tx ^. auxDataTxL
in blueprintMetadata `Map.isSubmapOf` commitMetadata
& counterexample ("blueprint metadata: " <> show blueprintMetadata)
& counterexample ("commit metadata: " <> show commitMetadata)
, let blueprintValidity = blueprintBody ^. vldtTxBodyL
commitValidity = commitTxBody ^. vldtTxBodyL
in blueprintValidity === commitValidity
& counterexample ("blueprint validity: " <> show blueprintValidity)
& counterexample ("commit validity: " <> show commitValidity)
, let blueprintInputs = blueprintBody ^. inputsTxBodyL
commitInputs = commitTxBody ^. inputsTxBodyL
in property (blueprintInputs `Set.isSubsetOf` commitInputs)
& counterexample ("blueprint inputs: " <> show blueprintInputs)
& counterexample ("commit inputs: " <> show commitInputs)
, let blueprintOutputs = toList $ blueprintBody ^. outputsTxBodyL
commitOutputs = toList $ commitTxBody ^. outputsTxBodyL
in property
( all
(`notElem` blueprintOutputs)
commitOutputs
)
(blueprintTx ^. bodyTxL . inputsTxBodyL)
&& any
( \case
AlonzoSpending _ -> True
_ -> False
)
( Map.keysSet
. unRedeemers
$ blueprintTx ^. witsTxL . rdmrsTxWitsL
)

let spendableUTxO =
UTxO.singleton (healthyInitialTxIn, toUTxOContext healthyInitialTxOut)
<> lookupUTxO
<> registryUTxO scriptRegistry

checkCoverage $
conjoin
[ propTransactionEvaluates (draftTx', lookupUTxO)
& counterexample "Blueprint transaction failed to evaluate"
, propTransactionEvaluates (commitTx', spendableUTxO)
& counterexample "Commit transaction failed to evaluate"
, let blueprintMetadata = fromSMaybe mempty $ getAuxMetadata <$> blueprintTx ^. auxDataTxL
commitMetadata = fromSMaybe mempty $ getAuxMetadata <$> tx ^. auxDataTxL
in blueprintMetadata `Map.isSubmapOf` commitMetadata
& counterexample ("blueprint metadata: " <> show blueprintMetadata)
& counterexample ("commit metadata: " <> show commitMetadata)
, let blueprintValidity = blueprintBody ^. vldtTxBodyL
commitValidity = commitTxBody ^. vldtTxBodyL
in blueprintValidity === commitValidity
& counterexample ("blueprint validity: " <> show blueprintValidity)
& counterexample ("commit validity: " <> show commitValidity)
, let blueprintInputs = blueprintBody ^. inputsTxBodyL
commitInputs = commitTxBody ^. inputsTxBodyL
in property (blueprintInputs `Set.isSubsetOf` commitInputs)
& counterexample ("blueprint inputs: " <> show blueprintInputs)
& counterexample ("commit inputs: " <> show commitInputs)
, let blueprintOutputs = toList $ blueprintBody ^. outputsTxBodyL
commitOutputs = toList $ commitTxBody ^. outputsTxBodyL
in property
( all
(`notElem` blueprintOutputs)
commitOutputs
)
& counterexample ("blueprint outputs: " <> show blueprintOutputs)
& counterexample ("commit outputs: " <> show commitOutputs)
, let blueprintSigs = blueprintBody ^. reqSignerHashesTxBodyL
commitSigs = commitTxBody ^. reqSignerHashesTxBodyL
in property (blueprintSigs `Set.isSubsetOf` commitSigs)
& counterexample ("blueprint signatures: " <> show blueprintSigs)
& counterexample ("commit signatures: " <> show commitSigs)
, let blueprintRefInputs = blueprintBody ^. referenceInputsTxBodyL
commitRefInputs = commitTxBody ^. referenceInputsTxBodyL
in property (blueprintRefInputs `Set.isSubsetOf` commitRefInputs)
& counterexample ("blueprint reference inputs: " <> show blueprintRefInputs)
& counterexample ("commit reference inputs: " <> show commitRefInputs)
]
& cover 1 spendsFromScript "blueprint spends script UTxO"
& cover 1 spendsFromPubKey "blueprint spends pub key UTxO"
& cover 1 (not . null $ blueprintTx ^. bodyTxL . referenceInputsTxBodyL) "blueprint has reference input"
& counterexample ("blueprint outputs: " <> show blueprintOutputs)
& counterexample ("commit outputs: " <> show commitOutputs)
, let blueprintSigs = blueprintBody ^. reqSignerHashesTxBodyL
commitSigs = commitTxBody ^. reqSignerHashesTxBodyL
in property (blueprintSigs `Set.isSubsetOf` commitSigs)
& counterexample ("blueprint signatures: " <> show blueprintSigs)
& counterexample ("commit signatures: " <> show commitSigs)
, let blueprintRefInputs = blueprintBody ^. referenceInputsTxBodyL
commitRefInputs = commitTxBody ^. referenceInputsTxBodyL
in property (blueprintRefInputs `Set.isSubsetOf` commitRefInputs)
& counterexample ("blueprint reference inputs: " <> show blueprintRefInputs)
& counterexample ("commit reference inputs: " <> show commitRefInputs)
]
& cover 1 spendsFromScript "blueprint spends script UTxO"
& cover 1 spendsFromPubKey "blueprint spends pub key UTxO"
& cover 1 (not . null $ blueprintTx ^. bodyTxL . referenceInputsTxBodyL) "blueprint has reference input"

getAuxMetadata :: AlonzoTxAuxData LedgerEra -> Map Word64 Metadatum
getAuxMetadata (AlonzoTxAuxData metadata _ _) = metadata
Expand Down Expand Up @@ -303,25 +296,87 @@ addRandomMetadata (l, metadata) tx =
toLedgerTx tx
& auxDataTxL .~ SJust (mkAlonzoTxAuxData @[] @LedgerEra (toShelleyMetadata metadataMap) [])

-- | Given the lookupUTxO assemble a blueprint tx (not always committing
-- all inputs + exercising using the reference inputs)
genBlueprintTx :: UTxO -> Gen Tx
genBlueprintTx utxo = do
(toSpend, toReference) <- splitUTxO
let tx = mkBasicTx mkBasicTxBody & referenceInputs toReference . spendInputs toSpend
pure $ fromLedgerTx tx
genBlueprintTxWithUTxO :: Gen (UTxO, Tx)
genBlueprintTxWithUTxO =
fmap (second unsafeBuildTransaction) $
spendingPubKeyOutput (mempty, emptyTxBody)
>>= spendSomeScriptInputs
>>= addSomeReferenceInputs
where
spendInputs spentTxIns tx =
tx & bodyTxL . inputsTxBodyL .~ Set.fromList spentTxIns
spendingPubKeyOutput (utxo, tx) = do
utxoToSpend <- genUTxOAdaOnlyOfSize . getPositive =<< arbitrary
pure
( utxo <> utxoToSpend
, tx & addVkInputs (toList $ UTxO.inputSet utxoToSpend)
)

referenceInputs refTxIns tx =
tx & bodyTxL . referenceInputsTxBodyL .~ Set.fromList refTxIns
spendSomeScriptInputs (utxo, txbody) = do
let alwaysSucceedingScript = PlutusScriptSerialised $ Plutus.alwaysSucceedingNAryFunction 3
datum <- arbitrary
redeemer <- arbitrary
let genTxOut = do
value <- genValue
let scriptAddress = mkScriptAddress testNetworkId alwaysSucceedingScript
pure $ TxOut scriptAddress value (TxOutDatumInline datum) ReferenceScriptNone
utxoToSpend <- genUTxO1 genTxOut
pure
( utxo <> utxoToSpend
, txbody
& addInputs
( UTxO.pairs $
( \_ ->
BuildTxWith $
ScriptWitness ScriptWitnessForSpending $
mkScriptWitness alwaysSucceedingScript (ScriptDatumForTxIn datum) redeemer
)
<$> utxoToSpend
)
)

splitUTxO = do
let pairs = UTxO.pairs utxo
n <- choose (0, length pairs)
let (spentInputs, refInputs) = List.splitAt n pairs
pure (toLedgerTxIn . fst <$> spentInputs, toLedgerTxIn . fst <$> refInputs)
addSomeReferenceInputs (utxo, txbody) = do
txout <- genTxOutWithReferenceScript
txin <- arbitrary
pure (utxo <> UTxO.singleton (txin, txout), txbody & addReferenceInputs [txin])

prop_interestingBlueprintTx :: Property
prop_interestingBlueprintTx = do
forAll genBlueprintTxWithUTxO $ \(utxo, tx) ->
checkCoverage
True
& cover 1 (spendsFromScript (utxo, tx)) "blueprint spends script UTxO"
& cover 1 (spendsFromPubKey (utxo, tx)) "blueprint spends pub key UTxO"
& cover 1 (hasReferenceInputs tx) "blueprint has reference input"
where
hasReferenceInputs tx =
not . null $ toLedgerTx tx ^. bodyTxL . referenceInputsTxBodyL

spendsFromPubKey (utxo, tx) =
any
( \txIn -> case UTxO.resolve (fromLedgerTxIn txIn) utxo of
Just (TxOut (ShelleyAddressInEra (ShelleyAddress _ (KeyHashObj _) _)) _ _ _) -> True
_ -> False
)
$ toLedgerTx tx ^. bodyTxL . inputsTxBodyL

-- XXX: We do check both, the utxo and redeemers, because we
-- don't do phase 1 validation of the resulting transactions
-- and would not detect if redeemers are missing.
spendsFromScript (utxo, tx) =
any
( \txIn -> case UTxO.resolve (fromLedgerTxIn txIn) utxo of
Just (TxOut (ShelleyAddressInEra (ShelleyAddress _ (ScriptHashObj _) _)) _ _ _) -> True
_ -> False
)
(toLedgerTx tx ^. bodyTxL . inputsTxBodyL)
&& any
( \case
AlonzoSpending _ -> True
_ -> False
)
( Map.keysSet
. unRedeemers
$ toLedgerTx @Era tx ^. witsTxL . rdmrsTxWitsL
)

genLabelAndMetadata :: Gen (Word64, Text)
genLabelAndMetadata = do
Expand Down

0 comments on commit 16d17c8

Please sign in to comment.