diff --git a/Makefile b/Makefile index 083b2e0..4bb79c5 100644 --- a/Makefile +++ b/Makefile @@ -4,11 +4,12 @@ help: @echo "Usage: make " @echo @echo "Targets:" - @echo " help -- show this help" - @echo " shell -- nix develop" - @echo " build -- cabal build" - @echo " test -- cabal test" - @echo " clean -- cabal clean" + @echo " help -- show this help" + @echo " shell -- nix develop" + @echo " build -- cabal build" + @echo " test -- cabal test" + @echo " clean -- cabal clean" + @echo " format -- format Haskell source files" .PHONY: shell shell: @@ -25,3 +26,8 @@ test: .PHONY: clean clean: cabal clean + +.PHONY: format +format: + fourmolu -i src + fourmolu -i test diff --git a/src/Plutarch/MultiUTxOIndexer.hs b/src/Plutarch/MultiUTxOIndexer.hs index 20b69f0..b39e460 100644 --- a/src/Plutarch/MultiUTxOIndexer.hs +++ b/src/Plutarch/MultiUTxOIndexer.hs @@ -60,7 +60,6 @@ newtype PIndices (s :: S) instance DerivePlutusType PIndices where type DPTStrat _ = PlutusTypeData deriving anyclass instance PTryFrom PData (PAsData PIndices) - instance PUnsafeLiftDecl PIndices where type PLifted PIndices = Indices diff --git a/src/Plutarch/MultiUTxOIndexerOneToMany.hs b/src/Plutarch/MultiUTxOIndexerOneToMany.hs index 0a6d41b..ee8a3d5 100644 --- a/src/Plutarch/MultiUTxOIndexerOneToMany.hs +++ b/src/Plutarch/MultiUTxOIndexerOneToMany.hs @@ -64,10 +64,8 @@ newtype PIndices (s :: S) instance DerivePlutusType PIndices where type DPTStrat _ = PlutusTypeData deriving anyclass instance PTryFrom PData (PAsData PIndices) - instance PUnsafeLiftDecl PIndices where type PLifted PIndices = Indices - deriving via (DerivePConstantViaData Indices PIndices) instance @@ -82,6 +80,12 @@ data PWithdrawRedeemer (s :: S) instance DerivePlutusType PWithdrawRedeemer where type DPTStrat _ = PlutusTypeData deriving anyclass instance PTryFrom PData (PAsData PWithdrawRedeemer) +instance PUnsafeLiftDecl PWithdrawRedeemer where + type PLifted PWithdrawRedeemer = WithdrawRedeemer +deriving via + (DerivePConstantViaData WithdrawRedeemer PWithdrawRedeemer) + instance + PConstantDecl WithdrawRedeemer data PMyInputAgg (s :: S) = PMyInputAgg (Term s (PBuiltinList PTxInInfo)) (Term s PInteger) deriving stock (Generic) diff --git a/src/Plutarch/SingularUTxOIndexer.hs b/src/Plutarch/SingularUTxOIndexer.hs index 96f0607..563c197 100644 --- a/src/Plutarch/SingularUTxOIndexer.hs +++ b/src/Plutarch/SingularUTxOIndexer.hs @@ -12,7 +12,11 @@ import Plutarch.Api.V2 ( PValidator, ) import Plutarch.Builtin (pasInt) -import Plutarch.DataRepr (PDataFields) +import Plutarch.DataRepr ( + DerivePConstantViaData (DerivePConstantViaData), + PDataFields, + ) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) import Plutarch.Prelude import Plutarch.Unsafe (punsafeCoerce) import PlutusTx @@ -38,6 +42,12 @@ newtype PSpendRedeemer (s :: S) instance DerivePlutusType PSpendRedeemer where type DPTStrat _ = PlutusTypeData instance PTryFrom PData PSpendRedeemer +instance PUnsafeLiftDecl PSpendRedeemer where + type PLifted PSpendRedeemer = SpendRedeemer +deriving via + (DerivePConstantViaData SpendRedeemer PSpendRedeemer) + instance + PConstantDecl SpendRedeemer spend :: Term s (PTxOut :--> PTxOut :--> PBool) -> Term s PValidator spend f = diff --git a/src/Plutarch/SingularUTxOIndexerOneToMany.hs b/src/Plutarch/SingularUTxOIndexerOneToMany.hs index ed7a851..3ec4bf7 100644 --- a/src/Plutarch/SingularUTxOIndexerOneToMany.hs +++ b/src/Plutarch/SingularUTxOIndexerOneToMany.hs @@ -14,7 +14,11 @@ import Plutarch.Api.V2 ( PValidator, ) import Plutarch.Builtin (pasInt) -import Plutarch.DataRepr (PDataFields) +import Plutarch.DataRepr ( + DerivePConstantViaData (DerivePConstantViaData), + PDataFields, + ) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) import Plutarch.Prelude import Plutarch.Unsafe (punsafeCoerce) import PlutusTx @@ -40,6 +44,12 @@ newtype PSpendRedeemer (s :: S) instance DerivePlutusType PSpendRedeemer where type DPTStrat _ = PlutusTypeData instance PTryFrom PData PSpendRedeemer +instance PUnsafeLiftDecl PSpendRedeemer where + type PLifted PSpendRedeemer = SpendRedeemer +deriving via + (DerivePConstantViaData SpendRedeemer PSpendRedeemer) + instance + PConstantDecl SpendRedeemer data PMyAggregator (s :: S) = PMyAggregator (Term s PInteger) (Term s (PBuiltinList PTxOut)) (Term s PInteger) deriving stock (Generic) diff --git a/src/Plutarch/Utils.hs b/src/Plutarch/Utils.hs index 728f628..8392b75 100644 --- a/src/Plutarch/Utils.hs +++ b/src/Plutarch/Utils.hs @@ -44,7 +44,7 @@ deriving via (DerivePConstantViaData WrapperRedeemer PWrapperRedeemer) instance ptryOwnInput :: (PIsListLike list PTxInInfo) => Term s (list PTxInInfo :--> PTxOutRef :--> PTxOut) ptryOwnInput = plam $ \inputs ownRef -> - precList (\self x xs -> pletFields @'["outRef", "resolved"] x $ \txInFields -> pif (ptrace "." (ownRef #== txInFields.outRef)) txInFields.resolved (self # xs)) (const perror) # inputs + precList (\self x xs -> pletFields @'["outRef", "resolved"] x $ \txInFields -> pif (ownRef #== txInFields.outRef) txInFields.resolved (self # xs)) (const perror) # inputs pheadSingleton :: (PListLike list, PElemConstraint list a) => Term s (list a :--> a) pheadSingleton = phoistAcyclic $ diff --git a/test/Spec.hs b/test/Spec.hs index 458a0b8..183cca7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -16,12 +16,17 @@ main = do "Tests" [ Spec.MerkelizedValidatorSpec.spendUnitTest , Spec.MerkelizedValidatorSpec.withdrawUnitTest - , Spec.MerkelizedValidatorSpec.propertyTests + , Spec.MerkelizedValidatorSpec.propertyTest , Spec.StakeValidatorSpec.unitTest + , Spec.StakeValidatorSpec.propertyTest , Spec.TxLevelMinterSpec.unitTest + , Spec.TxLevelMinterSpec.propertyTest , Spec.SingularUTxOIndexerSpec.unitTest + , Spec.SingularUTxOIndexerSpec.propertyTest , Spec.SingularUTxOIndexerOneToManySpec.unitTest + , Spec.SingularUTxOIndexerOneToManySpec.propertyTest , Spec.MultiUTxOIndexerSpec.unitTest - , Spec.MultiUTxOIndexerSpec.propertyTests + , Spec.MultiUTxOIndexerSpec.propertyTest , Spec.MultiUTxOIndexerOneToManySpec.unitTest + , Spec.MultiUTxOIndexerOneToManySpec.propertyTest ] diff --git a/test/Spec/MerkelizedValidatorSpec.hs b/test/Spec/MerkelizedValidatorSpec.hs index e8ac184..956ba94 100644 --- a/test/Spec/MerkelizedValidatorSpec.hs +++ b/test/Spec/MerkelizedValidatorSpec.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : Spec.MerkelizedValidatorSpec Description : Test suite for the Merkelized Validator functions in a Plutarch smart contract environment. -} module Spec.MerkelizedValidatorSpec ( - propertyTests, + propertyTest, psumOfSquares, spendUnitTest, withdrawUnitTest, @@ -33,9 +33,9 @@ import PlutusLedgerApi.V2 ( BuiltinByteString, Credential (..), ScriptContext, + ScriptHash (..), ScriptPurpose (..), StakingCredential (..), - ScriptHash (..), ) import PlutusTx qualified import PlutusTx.Builtins (mkI) @@ -47,7 +47,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont ( import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm) import Plutarch.Test.QuickCheck (fromPPartial) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (forAll, Property, testProperty, chooseInteger, listOf) +import Test.Tasty.QuickCheck (Property, chooseInteger, forAll, listOf, testProperty) import Spec.Utils @@ -153,45 +153,53 @@ withdrawUnitTest = tryFromPTerm "Merkelized Validator Withdraw Unit Test" withdr prop_withdrawValidator :: Property prop_withdrawValidator = forAll withdrawInput check - where - withdrawInput = do - xs <- listOf (chooseInteger (-1_000_000_000, 1_000_000_000)) - bs <- genByteString 56 - return (xs, bs) - check (xs, bs) = - let inputState :: ClosedTerm (PBuiltinList PData) - inputState = pmap # (plam $ pforgetData . pdata) # pconstant xs in - let outputState = psumOfSquares # inputState in - let redeemer :: ClosedTerm MerkelizedValidator.PWithdrawRedeemer - redeemer = pcon $ MerkelizedValidator.PWithdrawRedeemer - $ pdcons @"inputState" # pdata inputState - #$ pdcons @"outputState" # pdata outputState - # pdnil in - let cred = StakingHash (ScriptCredential (ScriptHash bs)) in - let context :: ClosedTerm PScriptContext - context = pconstant (withdrawCtxWithCred cred) in - fromPPartial $ withdraw # pforgetData (pdata redeemer) # context + where + withdrawInput = do + xs <- listOf (chooseInteger (-1_000_000_000, 1_000_000_000)) + bs <- genByteString 56 + return (xs, bs) + check (xs, bs) = + let inputState :: ClosedTerm (PBuiltinList PData) + inputState = pmap # (plam $ pforgetData . pdata) # pconstant xs + outputState = psumOfSquares # inputState + redeemer :: ClosedTerm MerkelizedValidator.PWithdrawRedeemer + redeemer = + pcon $ + MerkelizedValidator.PWithdrawRedeemer $ + pdcons @"inputState" + # pdata inputState + #$ pdcons @"outputState" + # pdata outputState + # pdnil + cred = StakingHash (ScriptCredential (ScriptHash bs)) + context :: ClosedTerm PScriptContext + context = pconstant (withdrawCtxWithCred cred) + in fromPPartial $ withdraw # pforgetData (pdata redeemer) # context prop_spendValidator :: Property prop_spendValidator = forAll spendInput check - where - spendInput = do - x <- chooseInteger (-4, 4) - y <- chooseInteger (-4, 4) - bs <- genByteString 56 - return (x, y, bs) - check (x :: Integer, y :: Integer, bs :: BuiltinByteString) = - let cred = StakingHash (ScriptCredential (ScriptHash bs)) in - let redeemer = MerkelizedValidator.WithdrawRedeemer - { inputState = [ PlutusTx.toBuiltinData x, PlutusTx.toBuiltinData y ] - , outputState = [ PlutusTx.toBuiltinData (x * x + y * y) ] - } in - let context :: ClosedTerm PScriptContext - context = pconstant (spendCtxWithCred cred redeemer) in - let asData = pforgetData . pdata . pconstant in - fromPPartial $ spend (pconstant cred) # asData x # asData y # context - -propertyTests :: TestTree -propertyTests = testGroup "Property tests for MerkelizedValidator" [ testProperty "withdraw" prop_withdrawValidator - , testProperty "spend" prop_spendValidator - ] + where + spendInput = do + x <- chooseInteger (-4, 4) + y <- chooseInteger (-4, 4) + bs <- genByteString 56 + return (x, y, bs) + check (x :: Integer, y :: Integer, bs :: BuiltinByteString) = + let cred = StakingHash (ScriptCredential (ScriptHash bs)) + redeemer = + MerkelizedValidator.WithdrawRedeemer + { inputState = [PlutusTx.toBuiltinData x, PlutusTx.toBuiltinData y] + , outputState = [PlutusTx.toBuiltinData (x * x + y * y)] + } + context :: ClosedTerm PScriptContext + context = pconstant (spendCtxWithCred cred redeemer) + asData = pforgetData . pdata . pconstant + in fromPPartial $ spend (pconstant cred) # asData x # asData y # context + +propertyTest :: TestTree +propertyTest = + testGroup + "Property tests for MerkelizedValidator" + [ testProperty "withdraw" prop_withdrawValidator + , testProperty "spend" prop_spendValidator + ] diff --git a/test/Spec/MultiUTxOIndexerOneToManySpec.hs b/test/Spec/MultiUTxOIndexerOneToManySpec.hs index 69f106c..53417c3 100644 --- a/test/Spec/MultiUTxOIndexerOneToManySpec.hs +++ b/test/Spec/MultiUTxOIndexerOneToManySpec.hs @@ -5,9 +5,10 @@ Description : Test suite for validating UTxO indexation in a multi-validator set module Spec.MultiUTxOIndexerOneToManySpec ( validator, unitTest, + propertyTest, ) where -import Plutarch.Api.V2 (PStakeValidator, PValidator) +import Plutarch.Api.V2 (PScriptContext, PStakeValidator, PValidator) import Plutarch.Context ( UTXO, address, @@ -15,30 +16,46 @@ import Plutarch.Context ( buildSpending', input, output, + withRef, withRefIndex, withRefTxId, withRewarding, + withSpendingOutRef, withSpendingOutRefId, withValue, withdrawal, ) -import Plutarch.MultiUTxOIndexerOneToMany qualified as MultiUTxOIndexerOneToMany -import Plutarch.Multivalidator qualified as Multivalidator -import Plutarch.Prelude -import Plutarch.StakeValidator qualified as StakeValidator -import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm) + import PlutusLedgerApi.V2 ( Address (..), + BuiltinByteString, Credential (..), + CurrencySymbol (..), ScriptContext, ScriptHash, StakingCredential (..), + TokenName (..), + TxId (..), + TxOutRef (..), singleton, ) import PlutusTx qualified import PlutusTx.Builtins (mkI) + +import Plutarch.MultiUTxOIndexerOneToMany qualified as MultiUTxOIndexerOneToMany +import Plutarch.Multivalidator qualified as Multivalidator + +import Plutarch.Builtin (pforgetData) +import Plutarch.Prelude +import Plutarch.StakeValidator qualified as StakeValidator +import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm) + +import Plutarch.Test.QuickCheck (fromPPartial) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Property, chooseInt, chooseInteger, forAll, testProperty) + +import Spec.Utils (genByteString, mkAddressFromByteString, mkStakingHashFromByteString) import Spec.Utils qualified as Utils -import Test.Tasty (TestTree) -- | Handles the spend logic using the basic Stake Validator. spend :: Term s PValidator @@ -146,3 +163,97 @@ unitTest = tryFromPTerm "Multi UTxO Indexer One To Many Unit Test" validator $ d [ PlutusTx.toData badRedeemer , PlutusTx.toData withdrawCtx ] + +mkInputUTXO :: TxOutRef -> BuiltinByteString -> UTXO +mkInputUTXO outRef valHash = + mconcat + [ address (mkAddressFromByteString valHash) + , withValue (singleton "" "" 0) + , withRef outRef + ] + +mkSpendCtx :: BuiltinByteString -> BuiltinByteString -> Integer -> ScriptContext +mkSpendCtx txId valHash withdrawalAmount = + let outRef = TxOutRef (TxId txId) 0 + in buildSpending' $ + mconcat + [ input (mkInputUTXO outRef valHash) + , withSpendingOutRef outRef + , withdrawal (mkStakingHashFromByteString valHash) withdrawalAmount + ] + +prop_spendValidator :: Property +prop_spendValidator = forAll spendInput check + where + spendInput = do + txId <- genByteString 64 + valHash <- genByteString 56 + withdrawAmount <- chooseInteger (1, 1_000_000_000) + return (txId, valHash, withdrawAmount) + check (txId, valHash, withdrawAmount) = + let context :: ClosedTerm PScriptContext + context = pconstant (mkSpendCtx txId valHash withdrawAmount) + emptyByteString :: ClosedTerm PData + emptyByteString = (pforgetData . pdata . phexByteStr) "" + in fromPPartial $ spend # emptyByteString # emptyByteString # context + +mkInputs :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> Integer -> [UTXO] +mkInputs txId valHash stateTokenSymbol tokenName numPairs = mkInput <$> [0 .. (numPairs - 1)] + where + mkInput i = + mconcat + [ address (mkAddressFromByteString valHash) + , withValue ((singleton "" "" (i * 2_000_000)) <> (singleton (CurrencySymbol stateTokenSymbol) (TokenName tokenName) 1)) + , withRefTxId (TxId txId) + , withRefIndex i + ] + +mkOutputs :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> Integer -> [UTXO] +mkOutputs valHash stateTokenSymbol tokenName numPairs = mkOutput <$> [0 .. (numPairs - 1)] + where + mkOutput i = + mconcat + [ address (mkAddressFromByteString valHash) + , withValue ((singleton "" "" (i * 2_000_000)) <> (singleton (CurrencySymbol stateTokenSymbol) (TokenName tokenName) 1)) + ] + +mkRedeemer :: Integer -> MultiUTxOIndexerOneToMany.WithdrawRedeemer +mkRedeemer n = + MultiUTxOIndexerOneToMany.WithdrawRedeemer $ (\i -> MultiUTxOIndexerOneToMany.Indices (mkI i) [(mkI i)]) <$> [0 .. (n - 1)] + +mkWithdrawCtx :: BuiltinByteString -> [UTXO] -> [UTXO] -> ScriptContext +mkWithdrawCtx valHash inputUTxOs outputUTxOs = + buildRewarding' $ + mconcat + [ mconcat $ input <$> inputUTxOs + , mconcat $ output <$> outputUTxOs + , withRewarding (mkStakingHashFromByteString valHash) + ] + +prop_withdrawValidator :: Property +prop_withdrawValidator = forAll withdrawInput check + where + withdrawInput = do + stateTokenSymbol <- genByteString 56 + txId <- genByteString 64 + valHash <- genByteString 56 + tokenNameLength <- chooseInt (0, 32) + tokenName <- genByteString tokenNameLength + numPairs <- chooseInteger (1, 10) + return (stateTokenSymbol, txId, valHash, tokenName, numPairs) + check (stateTokenSymbol, txId, valHash, tokenName, numPairs) = + let inputs = mkInputs txId valHash stateTokenSymbol tokenName numPairs + outputs = mkOutputs valHash stateTokenSymbol tokenName numPairs + redeemer :: ClosedTerm MultiUTxOIndexerOneToMany.PWithdrawRedeemer + redeemer = pconstant (mkRedeemer numPairs) + context :: ClosedTerm PScriptContext + context = pconstant (mkWithdrawCtx valHash inputs outputs) + in fromPPartial $ withdraw # pforgetData (pdata redeemer) # context + +propertyTest :: TestTree +propertyTest = + testGroup + "Property tests for MultiUTxOIndexerOneToMany" + [ testProperty "spend" prop_spendValidator + , testProperty "withdraw" prop_withdrawValidator + ] diff --git a/test/Spec/MultiUTxOIndexerSpec.hs b/test/Spec/MultiUTxOIndexerSpec.hs index afdad67..2779e27 100644 --- a/test/Spec/MultiUTxOIndexerSpec.hs +++ b/test/Spec/MultiUTxOIndexerSpec.hs @@ -3,7 +3,7 @@ Module : Spec.MultiUTxOIndexerSpec Description : Test suite for MultiUTxO Indexer validation in a Plutarch-based smart contract setting. -} module Spec.MultiUTxOIndexerSpec ( - propertyTests, + propertyTest, unitTest, validator, ) where @@ -16,17 +16,18 @@ import Plutarch.Context ( buildSpending', input, output, - withdrawal, withRefIndex, withRefTxId, withRewarding, - withSpendingUTXO, withSpendingOutRefId, + withSpendingUTXO, withValue, + withdrawal, ) -import Plutarch.Prelude import Plutarch.Api.V2.Contexts (PScriptContext) +import Plutarch.Builtin (pforgetData) +import Plutarch.Prelude import Plutarch.StakeValidator qualified as StakeValidator import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm) import PlutusLedgerApi.V2 ( @@ -37,11 +38,10 @@ import PlutusLedgerApi.V2 ( ScriptContext, ScriptHash (..), StakingCredential (..), - singleton, TokenName (..), TxId (..), + singleton, ) -import Plutarch.Builtin (pforgetData) import PlutusTx qualified import PlutusTx.Builtins (mkI) @@ -50,9 +50,10 @@ import Plutarch.Multivalidator qualified as Multivalidator import Plutarch.Test.QuickCheck (fromPPartial) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (Property, chooseInteger, forAll, testProperty, chooseInt) +import Test.Tasty.QuickCheck (Property, chooseInt, chooseInteger, forAll, testProperty) + +import Spec.Utils (genByteString, mkAddressFromByteString, mkStakingHashFromByteString) import Spec.Utils qualified as Utils -import Spec.Utils (genByteString, mkAddressFromByteString) spend :: Term s PValidator spend = StakeValidator.spend @@ -169,83 +170,86 @@ mkInputUTxO txId valHash = mkSpendCtx :: BuiltinByteString -> BuiltinByteString -> Integer -> ScriptContext mkSpendCtx txId valHash withdrawAmount = - let spendingUTxO = mkInputUTxO txId valHash in - buildSpending' $ - mconcat - [ input spendingUTxO - , withSpendingUTXO spendingUTxO - , withdrawal (StakingHash (ScriptCredential (ScriptHash valHash))) withdrawAmount - ] + let spendingUTxO = mkInputUTxO txId valHash + in buildSpending' $ + mconcat + [ input spendingUTxO + , withSpendingUTXO spendingUTxO + , withdrawal (mkStakingHashFromByteString valHash) withdrawAmount + ] prop_spendValidator :: Property prop_spendValidator = forAll spendInput check - where - spendInput = do - txId <- genByteString 64 - valHash <- genByteString 56 - withdrawAmount <- chooseInteger (1, 1_000_000_000) - return (txId, valHash, withdrawAmount) - check (txId, valHash, withdrawAmount) = - let context :: ClosedTerm PScriptContext - context = pconstant (mkSpendCtx txId valHash withdrawAmount) in - let emptyByteString :: ClosedTerm PData - emptyByteString = (pforgetData . pdata . phexByteStr) "" in - fromPPartial $ spend # emptyByteString # emptyByteString # context + where + spendInput = do + txId <- genByteString 64 + valHash <- genByteString 56 + withdrawAmount <- chooseInteger (1, 1_000_000_000) + return (txId, valHash, withdrawAmount) + check (txId, valHash, withdrawAmount) = + let context :: ClosedTerm PScriptContext + context = pconstant (mkSpendCtx txId valHash withdrawAmount) + emptyByteString :: ClosedTerm PData + emptyByteString = (pforgetData . pdata . phexByteStr) "" + in fromPPartial $ spend # emptyByteString # emptyByteString # context mkInputs :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> Integer -> [UTXO] -mkInputs txId valHash stateTokenSymbol tokenName numPairs = mkInput <$> [0..(numPairs - 1)] - where - mkInput i = - mconcat - [ address (mkAddressFromByteString valHash) - , withValue ((singleton "" "" (i * 2_000_000)) <> (singleton (CurrencySymbol stateTokenSymbol) (TokenName tokenName) 1)) - , withRefTxId (TxId txId) - , withRefIndex i - ] +mkInputs txId valHash stateTokenSymbol tokenName numPairs = mkInput <$> [0 .. (numPairs - 1)] + where + mkInput i = + mconcat + [ address (mkAddressFromByteString valHash) + , withValue ((singleton "" "" (i * 2_000_000)) <> (singleton (CurrencySymbol stateTokenSymbol) (TokenName tokenName) 1)) + , withRefTxId (TxId txId) + , withRefIndex i + ] mkOutputs :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> Integer -> [UTXO] -mkOutputs valHash stateTokenSymbol tokenName numPairs = mkOutput <$> [0..(numPairs - 1)] - where - mkOutput i = - mconcat - [ address (mkAddressFromByteString valHash) - , withValue ((singleton "" "" (i * 2_000_000)) <> (singleton (CurrencySymbol stateTokenSymbol) (TokenName tokenName) 1)) - ] +mkOutputs valHash stateTokenSymbol tokenName numPairs = mkOutput <$> [0 .. (numPairs - 1)] + where + mkOutput i = + mconcat + [ address (mkAddressFromByteString valHash) + , withValue ((singleton "" "" (i * 2_000_000)) <> (singleton (CurrencySymbol stateTokenSymbol) (TokenName tokenName) 1)) + ] mkRedeemer :: Integer -> MultiUTxOIndexer.WithdrawRedeemer mkRedeemer n = - MultiUTxOIndexer.WithdrawRedeemer $ (\i-> MultiUTxOIndexer.Indices (mkI i) (mkI i)) <$> [0..(n - 1)] + MultiUTxOIndexer.WithdrawRedeemer $ (\i -> MultiUTxOIndexer.Indices (mkI i) (mkI i)) <$> [0 .. (n - 1)] mkWithdrawCtx :: BuiltinByteString -> [UTXO] -> [UTXO] -> ScriptContext mkWithdrawCtx valHash inputUTxOs outputUTxOs = buildRewarding' $ mconcat - [ mconcat $ input <$> inputUTxOs + [ mconcat $ input <$> inputUTxOs , mconcat $ output <$> outputUTxOs - , withRewarding (StakingHash (ScriptCredential (ScriptHash valHash))) + , withRewarding (mkStakingHashFromByteString valHash) ] prop_withdrawValidator :: Property prop_withdrawValidator = forAll withdrawInput check - where - withdrawInput = do - stateTokenSymbol <- genByteString 56 - txId <- genByteString 64 - valHash <- genByteString 56 - tokenNameLength <- chooseInt (0, 32) - tokenName <- genByteString tokenNameLength - numPairs <- chooseInteger (1, 10) - return (stateTokenSymbol, txId, valHash, tokenName, numPairs) - check (stateTokenSymbol, txId, valHash, tokenName, numPairs) = - let inputs = mkInputs txId valHash stateTokenSymbol tokenName numPairs in - let outputs = mkOutputs valHash stateTokenSymbol tokenName numPairs in - let redeemer :: ClosedTerm MultiUTxOIndexer.PWithdrawRedeemer - redeemer = pconstant (mkRedeemer numPairs) in - let context :: ClosedTerm PScriptContext - context = pconstant (mkWithdrawCtx valHash inputs outputs) in - fromPPartial $ withdraw # pforgetData (pdata redeemer) # context - -propertyTests :: TestTree -propertyTests = testGroup "Property tests for MultiUTxOIndexer" [ testProperty "spend" prop_spendValidator - , testProperty "withdraw" prop_withdrawValidator - ] + where + withdrawInput = do + stateTokenSymbol <- genByteString 56 + txId <- genByteString 64 + valHash <- genByteString 56 + tokenNameLength <- chooseInt (0, 32) + tokenName <- genByteString tokenNameLength + numPairs <- chooseInteger (1, 10) + return (stateTokenSymbol, txId, valHash, tokenName, numPairs) + check (stateTokenSymbol, txId, valHash, tokenName, numPairs) = + let inputs = mkInputs txId valHash stateTokenSymbol tokenName numPairs + outputs = mkOutputs valHash stateTokenSymbol tokenName numPairs + redeemer :: ClosedTerm MultiUTxOIndexer.PWithdrawRedeemer + redeemer = pconstant (mkRedeemer numPairs) + context :: ClosedTerm PScriptContext + context = pconstant (mkWithdrawCtx valHash inputs outputs) + in fromPPartial $ withdraw # pforgetData (pdata redeemer) # context + +propertyTest :: TestTree +propertyTest = + testGroup + "Property tests for MultiUTxOIndexer" + [ testProperty "spend" prop_spendValidator + , testProperty "withdraw" prop_withdrawValidator + ] diff --git a/test/Spec/SingularUTxOIndexerOneToManySpec.hs b/test/Spec/SingularUTxOIndexerOneToManySpec.hs index 4f6c970..ffc7373 100644 --- a/test/Spec/SingularUTxOIndexerOneToManySpec.hs +++ b/test/Spec/SingularUTxOIndexerOneToManySpec.hs @@ -5,17 +5,21 @@ Description : Test suite for Singular UTxO Indexer in a one-to-many configuratio module Spec.SingularUTxOIndexerOneToManySpec ( spend, unitTest, + propertyTest, ) where -import Plutarch.Api.V2 (PValidator) +import Plutarch.Api.V2 (PScriptContext, PValidator) +import Plutarch.Builtin (pforgetData) import Plutarch.Context ( UTXO, address, buildSpending', input, output, + withRef, withRefIndex, withRefTxId, + withSpendingOutRef, withSpendingOutRefId, withValue, withdrawal, @@ -23,18 +27,26 @@ import Plutarch.Context ( import Plutarch.Prelude import Plutarch.SingularUTxOIndexerOneToMany qualified as SingularUTxOIndexerOneToMany import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm) +import Plutarch.Test.QuickCheck (fromPPartial) import PlutusLedgerApi.V2 ( Address (..), + BuiltinByteString, Credential (..), + CurrencySymbol (..), ScriptContext, ScriptHash, StakingCredential (..), + TokenName (..), + TxId (..), + TxOutRef (..), singleton, ) import PlutusTx qualified import PlutusTx.Builtins (mkI) +import Spec.Utils (genByteString, mkAddressFromByteString) import Spec.Utils qualified as Utils -import Test.Tasty (TestTree) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Property, chooseInt, forAll, testProperty) -- | A validator that enforces one-to-many UTxO indexing rules for spend transactions. spend :: Term s PValidator @@ -109,3 +121,54 @@ unitTest = tryFromPTerm "Singular UTxO Indexer One To Many Unit Test" spend $ do , PlutusTx.toData badRedeemer , PlutusTx.toData spendCtx ] + +mkInputUTXO :: TxOutRef -> BuiltinByteString -> CurrencySymbol -> TokenName -> UTXO +mkInputUTXO outRef valHash stateTokenSymbol tokenName = + mconcat + [ address (mkAddressFromByteString valHash) + , withValue ((singleton "" "" 2_000_000) <> (singleton stateTokenSymbol tokenName 1)) + , withRef outRef + ] + +mkOutputUTXO :: BuiltinByteString -> CurrencySymbol -> TokenName -> UTXO +mkOutputUTXO valHash stateTokenSymbol tokenName = + mconcat + [ address (mkAddressFromByteString valHash) + , withValue ((singleton "" "" 2_000_000) <> (singleton stateTokenSymbol tokenName 1)) + ] + +mkSpendCtx :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> ScriptContext +mkSpendCtx txId valHash stateTokenSymbol tokenName = + let txOutRef = TxOutRef (TxId txId) 0 + cs = CurrencySymbol stateTokenSymbol + tn = TokenName tokenName + in buildSpending' $ + mconcat + [ input (mkInputUTXO txOutRef valHash cs tn) + , output (mkOutputUTXO valHash cs tn) + , withSpendingOutRef txOutRef + , withdrawal rewardingCred 1 + ] + +prop_spendValidator :: Property +prop_spendValidator = forAll spendInput check + where + spendInput = do + stateTokenSymbol <- genByteString 56 + txId <- genByteString 64 + valHash <- genByteString 56 + tokenNameLength <- chooseInt (0, 32) + tokenName <- genByteString tokenNameLength + return (stateTokenSymbol, txId, valHash, tokenName) + check (stateTokenSymbol, txId, valHash, tokenName) = + let context :: ClosedTerm PScriptContext + context = pconstant $ mkSpendCtx txId valHash stateTokenSymbol tokenName + redeemer :: ClosedTerm SingularUTxOIndexerOneToMany.PSpendRedeemer + redeemer = pconstant $ SingularUTxOIndexerOneToMany.SpendRedeemer (mkI 0) [mkI 0] + in fromPPartial $ spend # (pforgetData . pdata . pconstant) (0 :: Integer) # (pforgetData . pdata) redeemer # context + +propertyTest :: TestTree +propertyTest = + testGroup + "Property tests for SingularUTxOIndexerOneToMany" + [testProperty "spend" prop_spendValidator] diff --git a/test/Spec/SingularUTxOIndexerSpec.hs b/test/Spec/SingularUTxOIndexerSpec.hs index 701e445..e2aa51f 100644 --- a/test/Spec/SingularUTxOIndexerSpec.hs +++ b/test/Spec/SingularUTxOIndexerSpec.hs @@ -5,17 +5,20 @@ Description : Test suite for Singular UTxO Indexer validation in Plutarch, focus module Spec.SingularUTxOIndexerSpec ( spend, unitTest, + propertyTest, ) where -import Plutarch.Api.V2 (PValidator) +import Plutarch.Api.V2 (PScriptContext, PValidator) import Plutarch.Context ( UTXO, address, buildSpending', input, output, + withRef, withRefIndex, withRefTxId, + withSpendingOutRef, withSpendingOutRefId, withValue, withdrawal, @@ -25,16 +28,27 @@ import Plutarch.SingularUTxOIndexer qualified as SingularUTxOIndexer import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm) import PlutusLedgerApi.V2 ( Address (..), + BuiltinByteString, Credential (..), + CurrencySymbol (..), ScriptContext, ScriptHash, StakingCredential (..), + TokenName (..), + TxId (..), + TxOutRef (..), singleton, ) import PlutusTx qualified import PlutusTx.Builtins (mkI) + +import Plutarch.Test.QuickCheck (fromPPartial) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Property, chooseInt, forAll, testProperty) + +import Plutarch.Builtin (pforgetData) +import Spec.Utils (genByteString, mkAddressFromByteString) import Spec.Utils qualified as Utils -import Test.Tasty (TestTree) -- | Implements a validator that enforces specific UTxO spending rules using input-output pair indexing. spend :: Term s PValidator @@ -111,3 +125,54 @@ unitTest = tryFromPTerm "Singular UTxO Indexer Unit Test" spend $ do , PlutusTx.toData badRedeemer , PlutusTx.toData spendCtx ] + +mkInputUTXO :: TxOutRef -> BuiltinByteString -> CurrencySymbol -> TokenName -> UTXO +mkInputUTXO outRef valHash stateTokenSymbol tokenName = + mconcat + [ address (mkAddressFromByteString valHash) + , withValue ((singleton "" "" 2_000_000) <> (singleton stateTokenSymbol tokenName 1)) + , withRef outRef + ] + +mkOutputUTXO :: BuiltinByteString -> CurrencySymbol -> TokenName -> UTXO +mkOutputUTXO valHash stateTokenSymbol tokenName = + mconcat + [ address (mkAddressFromByteString valHash) + , withValue ((singleton "" "" 2_000_000) <> (singleton stateTokenSymbol tokenName 1)) + ] + +mkSpendCtx :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> ScriptContext +mkSpendCtx txId valHash stateTokenSymbol tokenName = + let txOutRef = TxOutRef (TxId txId) 0 + cs = CurrencySymbol stateTokenSymbol + tn = TokenName tokenName + in buildSpending' $ + mconcat + [ input (mkInputUTXO txOutRef valHash cs tn) + , output (mkOutputUTXO valHash cs tn) + , withSpendingOutRef txOutRef + , withdrawal rewardingCred 1 + ] + +prop_spendValidator :: Property +prop_spendValidator = forAll spendInput check + where + spendInput = do + stateTokenSymbol <- genByteString 56 + txId <- genByteString 64 + valHash <- genByteString 56 + tokenNameLength <- chooseInt (0, 32) + tokenName <- genByteString tokenNameLength + return (stateTokenSymbol, txId, valHash, tokenName) + check (stateTokenSymbol, txId, valHash, tokenName) = + let context :: ClosedTerm PScriptContext + context = pconstant $ mkSpendCtx txId valHash stateTokenSymbol tokenName + redeemer :: ClosedTerm SingularUTxOIndexer.PSpendRedeemer + redeemer = pconstant $ SingularUTxOIndexer.SpendRedeemer (mkI 0) (mkI 0) + in fromPPartial $ spend # (pforgetData . pdata . pconstant) (0 :: Integer) # (pforgetData . pdata) redeemer # context + +propertyTest :: TestTree +propertyTest = + testGroup + "Property tests for SingularUTxOIndexer" + [testProperty "spend" prop_spendValidator] diff --git a/test/Spec/StakeValidatorSpec.hs b/test/Spec/StakeValidatorSpec.hs index c245f19..c457b5a 100644 --- a/test/Spec/StakeValidatorSpec.hs +++ b/test/Spec/StakeValidatorSpec.hs @@ -5,19 +5,23 @@ Description : Test suite for the Stake Validator in a Plutarch smart contract en module Spec.StakeValidatorSpec ( validator, unitTest, + propertyTest, ) where -import Plutarch.Api.V2 (PStakeValidator, PStakingCredential, PValidator) +import Plutarch.Api.V2 (PScriptContext, PStakeValidator, PStakingCredential, PValidator) import Plutarch.Api.V2.Contexts (PTxInfo) +import Plutarch.Builtin (pforgetData) import Plutarch.Context ( UTXO, address, buildRewarding', buildSpending', input, + withRef, withRefIndex, withRefTxId, withRewarding, + withSpendingOutRef, withSpendingOutRefId, withValue, withdrawal, @@ -26,17 +30,23 @@ import Plutarch.Multivalidator qualified as Multivalidator import Plutarch.Prelude import Plutarch.StakeValidator qualified as StakeValidator import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm) +import Plutarch.Test.QuickCheck (fromPPartial) import Plutarch.Utils (WrapperRedeemer (..)) import PlutusLedgerApi.V2 ( Address (..), + BuiltinByteString, Credential (..), ScriptContext, ScriptHash, StakingCredential (..), + TxId (..), + TxOutRef (..), singleton, ) import PlutusTx qualified -import Test.Tasty (TestTree) +import Spec.Utils (genByteString, mkAddressFromByteString, mkStakingHashFromByteString) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Property, chooseInteger, forAll, testProperty) -- | Implements the spending logic. spend :: Term s PValidator @@ -136,3 +146,41 @@ unitTest = tryFromPTerm "Stake Validator Unit Test" validator $ do , PlutusTx.toData (WrapperRedeemer 0) , PlutusTx.toData spendIncorrectOutRefCtx ] + +mkInputUTxO :: TxOutRef -> BuiltinByteString -> UTXO +mkInputUTxO txOutRef valHash = + mconcat + [ address (mkAddressFromByteString valHash) + , withRef txOutRef + ] + +mkSpendCtx :: BuiltinByteString -> BuiltinByteString -> Integer -> ScriptContext +mkSpendCtx txId valHash withdrawAmount = + let txOutRef = TxOutRef (TxId txId) 0 + in buildSpending' $ + mconcat + [ input (mkInputUTxO txOutRef valHash) + , withSpendingOutRef txOutRef + , withdrawal (mkStakingHashFromByteString valHash) withdrawAmount + ] + +prop_spendValidator :: Property +prop_spendValidator = forAll spendInput check + where + spendInput = do + txId <- genByteString 64 + valHash <- genByteString 56 + withdrawAmount <- chooseInteger (1, 1_000_000_000) + return (txId, valHash, withdrawAmount) + check (txId, valHash, withdrawAmount) = + let context :: ClosedTerm PScriptContext + context = pconstant $ mkSpendCtx txId valHash withdrawAmount + emptyData :: ClosedTerm PData + emptyData = (pforgetData . pconstantData) (0 :: Integer) + in fromPPartial $ spend # emptyData # emptyData # context + +propertyTest :: TestTree +propertyTest = + testGroup + "Property tests for StakeValidator" + [testProperty "spend" prop_spendValidator] diff --git a/test/Spec/TxLevelMinterSpec.hs b/test/Spec/TxLevelMinterSpec.hs index 95414df..cdf4a13 100644 --- a/test/Spec/TxLevelMinterSpec.hs +++ b/test/Spec/TxLevelMinterSpec.hs @@ -5,10 +5,12 @@ Description : Test suite for a transaction-level minter validator in a Plutarch module Spec.TxLevelMinterSpec ( validator, unitTest, + propertyTest, ) where -import Plutarch.Api.V2 (PCurrencySymbol, PMintingPolicy, PValidator) +import Plutarch.Api.V2 (PCurrencySymbol, PMintingPolicy, PScriptContext, PValidator) import Plutarch.Api.V2.Contexts (PTxInfo) +import Plutarch.Builtin (pforgetData) import Plutarch.Context ( UTXO, address, @@ -16,8 +18,10 @@ import Plutarch.Context ( buildSpending', input, mint, + withRef, withRefIndex, withRefTxId, + withSpendingOutRef, withSpendingOutRefId, withValue, withdrawal, @@ -25,19 +29,26 @@ import Plutarch.Context ( import Plutarch.Multivalidator qualified as Multivalidator import Plutarch.Prelude import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm) +import Plutarch.Test.QuickCheck (fromPPartial) import Plutarch.TxLevelMinter qualified as TxLevelMinter import Plutarch.Utils (WrapperRedeemer (..)) import PlutusLedgerApi.V2 ( Address (..), + BuiltinByteString, Credential (..), + CurrencySymbol (..), ScriptContext, ScriptHash, StakingCredential (..), + TxId (..), + TxOutRef (..), Value, singleton, ) import PlutusTx qualified -import Test.Tasty (TestTree) +import Spec.Utils (genByteString, mkAddressFromByteString) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Property, chooseInteger, forAll, testProperty) -- | Implements the spending logic, including validation of the custom token 'BEACON'. spend :: Term s PValidator @@ -124,3 +135,41 @@ unitTest = tryFromPTerm "Tx Level Minter Unit Test" validator $ do [ PlutusTx.toData () , PlutusTx.toData mintCtx ] + +mkInputUTxO :: TxOutRef -> BuiltinByteString -> UTXO +mkInputUTxO txOutRef valHash = + mconcat + [ address (mkAddressFromByteString valHash) + , withRef txOutRef + ] + +mkSpendCtx :: BuiltinByteString -> BuiltinByteString -> Integer -> ScriptContext +mkSpendCtx txId valHash mintAmount = + let txOutRef = TxOutRef (TxId txId) 0 + in buildSpending' $ + mconcat + [ input (mkInputUTxO txOutRef valHash) + , withSpendingOutRef txOutRef + , mint (singleton (CurrencySymbol valHash) "BEACON" mintAmount) + ] + +prop_spendValidator :: Property +prop_spendValidator = forAll spendInput check + where + spendInput = do + txId <- genByteString 64 + valHash <- genByteString 56 + mintAmount <- chooseInteger (1, 1_000_000_000) + return (txId, valHash, mintAmount) + check (txId, valHash, mintAmount) = + let context :: ClosedTerm PScriptContext + context = pconstant $ mkSpendCtx txId valHash mintAmount + emptyData :: ClosedTerm PData + emptyData = (pforgetData . pconstantData) (0 :: Integer) + in fromPPartial $ validator # emptyData # (pforgetData . pconstantData . WrapperRedeemer) 0 # context + +propertyTest :: TestTree +propertyTest = + testGroup + "Property tests for TxLevelMinter" + [testProperty "spend" prop_spendValidator] diff --git a/test/Spec/Utils.hs b/test/Spec/Utils.hs index 5ec2a00..9e4a35c 100644 --- a/test/Spec/Utils.hs +++ b/test/Spec/Utils.hs @@ -4,14 +4,15 @@ module Spec.Utils ( collectiveOutputValidator, genByteString, mkAddressFromByteString, + mkStakingHashFromByteString, ) where import Plutarch.Api.V2 (PTxInInfo, PTxOut) import Plutarch.Prelude -import PlutusLedgerApi.V2 (BuiltinByteString, Address (..), Credential (..), ScriptHash (..)) +import PlutusLedgerApi.V2 (Address (..), BuiltinByteString, Credential (..), ScriptHash (..), StakingCredential (..)) import PlutusTx.Builtins.Class (stringToBuiltinByteString) -import Test.Tasty.QuickCheck (Gen, vectorOf, elements) +import Test.Tasty.QuickCheck (Gen, elements, vectorOf) inputValidator :: Term s (PTxInInfo :--> PBool) inputValidator = phoistAcyclic $ @@ -35,3 +36,6 @@ genByteString n = do mkAddressFromByteString :: BuiltinByteString -> Address mkAddressFromByteString = (flip Address) Nothing . ScriptCredential . ScriptHash + +mkStakingHashFromByteString :: BuiltinByteString -> StakingCredential +mkStakingHashFromByteString = StakingHash . ScriptCredential . ScriptHash