From 0e49579a550e4601de3dc63899ac9a6a5c000979 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Thu, 18 Apr 2024 14:59:59 +0200 Subject: [PATCH] WIP --- hydra-node/test/Hydra/Chain/Direct/TxSpec.hs | 293 +++++++++++-------- 1 file changed, 174 insertions(+), 119 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs index a48ac7eba2d..ac088b74942 100644 --- a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs @@ -17,8 +17,6 @@ import Cardano.Ledger.Api ( bodyTxL, inputsTxBodyL, mkAlonzoTxAuxData, - mkBasicTx, - mkBasicTxBody, outputsTxBodyL, rdmrsTxWitsL, referenceInputsTxBodyL, @@ -30,7 +28,6 @@ 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 @@ -38,7 +35,7 @@ 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 ( @@ -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, 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, @@ -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 @@ -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 & addInputs (UTxO.pairs $ (\_ -> BuildTxWith $ KeyWitness KeyWitnessForSpending) <$> 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