Skip to content

Commit

Permalink
WIP
Browse files Browse the repository at this point in the history
  • Loading branch information
@ch1bo
Sasha Bogicevic authored and ch1bo committed Apr 18, 2024
1 parent 987e9bc commit a363e08
Showing 1 changed file with 181 additions and 117 deletions.
298 changes: 181 additions & 117 deletions hydra-node/test/Hydra/Chain/Direct/TxSpec.hs
View file
Expand Up @@ -8,6 +8,7 @@ module Hydra.Chain.Direct.TxSpec where
import Hydra.Prelude hiding (label)

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Binary (serialize', unsafeDeserialize')
import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..))
import Cardano.Ledger.Api (
AlonzoPlutusPurpose (AlonzoSpending),
Expand All @@ -29,7 +30,7 @@ import Cardano.Ledger.Api (
)
import Cardano.Ledger.Core (EraTx (getMinFeeTx))
import Cardano.Ledger.Credential (Credential (..))
import Control.Lens ((.~), (^.))
import Control.Lens ((.~), (<>~), (^.))
import Data.List qualified as List
import Data.Map qualified as Map
import Data.Maybe.Strict (StrictMaybe (..), fromSMaybe)
Expand All @@ -38,7 +39,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 (
Expand All @@ -58,12 +59,15 @@ 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, emptyTxBody, genOneUTxOFor, genSigningKey, genTxOutAdaOnly, genUTxO1, genUTxOAdaOnlyOfSize, genUTxOSized, genValue, genVerificationKey, unsafeBuildTransaction)
import Hydra.Ledger.Cardano.Evaluate (EvaluationReport, maxTxExecutionUnits, propTransactionEvaluates)
import Hydra.Model (mkMockTxIn)
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 All @@ -75,6 +79,7 @@ import Test.QuickCheck (
forAllShrinkShow,
getPrintableString,
label,
oneof,
property,
vectorOf,
withMaxSuccess,
Expand Down Expand Up @@ -173,109 +178,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 +302,90 @@ 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, tx) = do
let alwaysSucceedingScript = PlutusScriptSerialised $ Plutus.alwaysSucceedingNAryFunction 3
let genTxOut = do
value <- genValue
datum <- arbitrary
let scriptAddress = mkScriptAddress testNetworkId alwaysSucceedingScript
pure $ TxOut scriptAddress value (TxOutDatumInline datum) ReferenceScriptNone
utxoToSpend <- genUTxO1 genTxOut
pure
( utxo <> utxoToSpend
, tx & addInputs (UTxO.pairs $ (\_ -> BuildTxWith $ ScriptWitness ScriptWitnessForSpending $ mkScriptWitness alwaysSucceedingScript undefined undefined) <$> 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, tx) = pure (utxo, tx)

-- & referenceInputs toReference . spendInputs toSpend
-- (toSpend, toReference) <- splitUTxO

-- where
-- spendInputs spentTxIns tx =
-- tx & bodyTxL . inputsTxBodyL .~ Set.fromList spentTxIns
--
-- referenceInputs refTxIns tx =
-- tx & bodyTxL . referenceInputsTxBodyL .~ Set.fromList refTxIns
--
-- 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)

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 a363e08

Please sign in to comment.