From 60656274cbe0eef8e3082e3703549c35787cfa1f Mon Sep 17 00:00:00 2001 From: hade Date: Wed, 24 Apr 2024 18:16:54 +0700 Subject: [PATCH 1/3] feat: add singular utxo indexer one to many --- plutarch-design-pattern.cabal | 1 + src/Plutarch/MerkelizedValidator.hs | 2 + src/Plutarch/SingularUTxOIndexer.hs | 3 + src/Plutarch/SingularUTxOIndexerOneToMany.hs | 68 ++++++++++++++++++++ 4 files changed, 74 insertions(+) create mode 100644 src/Plutarch/SingularUTxOIndexerOneToMany.hs diff --git a/plutarch-design-pattern.cabal b/plutarch-design-pattern.cabal index 86f2217..cf4eb8a 100644 --- a/plutarch-design-pattern.cabal +++ b/plutarch-design-pattern.cabal @@ -123,6 +123,7 @@ library Plutarch.TxLevelMinter Plutarch.Utils Plutarch.ValidityRangeNormalization + Plutarch.SingularUTxOIndexerOneToMany build-depends: , aeson diff --git a/src/Plutarch/MerkelizedValidator.hs b/src/Plutarch/MerkelizedValidator.hs index 794ad5e..3090234 100644 --- a/src/Plutarch/MerkelizedValidator.hs +++ b/src/Plutarch/MerkelizedValidator.hs @@ -5,6 +5,8 @@ module Plutarch.MerkelizedValidator ( spend, withdraw, + WithdrawRedeemer (..), + PWithdrawRedeemer (..), ) where import Plutarch.Api.V1 qualified as V1 diff --git a/src/Plutarch/SingularUTxOIndexer.hs b/src/Plutarch/SingularUTxOIndexer.hs index 44fd0fb..77a4437 100644 --- a/src/Plutarch/SingularUTxOIndexer.hs +++ b/src/Plutarch/SingularUTxOIndexer.hs @@ -1,5 +1,7 @@ module Plutarch.SingularUTxOIndexer ( spend, + SpendRedeemer (..), + PSpendRedeemer (..), ) where import Plutarch.Api.V2 ( @@ -31,6 +33,7 @@ newtype PSpendRedeemer (s :: S) instance DerivePlutusType PSpendRedeemer where type DPTStrat _ = PlutusTypeData instance PTryFrom PData PSpendRedeemer + spend :: Term s (PTxOut :--> PTxOut :--> PBool) -> Term s PValidator spend f = plam $ \_datum redeemer ctx -> unTermCont $ do diff --git a/src/Plutarch/SingularUTxOIndexerOneToMany.hs b/src/Plutarch/SingularUTxOIndexerOneToMany.hs new file mode 100644 index 0000000..928c32c --- /dev/null +++ b/src/Plutarch/SingularUTxOIndexerOneToMany.hs @@ -0,0 +1,68 @@ +module Plutarch.SingularUTxOIndexerOneToMany ( + spend, + SpendRedeemer (..), + PSpendRedeemer (..), +) where + +import Plutarch.Api.V2 ( + PScriptPurpose (..), + PTxOut, + PValidator, + ) +import Plutarch.Builtin (pasInt) +import Plutarch.DataRepr (PDataFields) +import Plutarch.Prelude +import Plutarch.Unsafe (punsafeCoerce) +import PlutusTx (BuiltinData) +import "liqwid-plutarch-extra" Plutarch.Extra.TermCont ( + pletC, + pletFieldsC, + pmatchC, + ) + +data SpendRedeemer = SpendRedeemer + { inIx :: BuiltinData + , outIxs :: [BuiltinData] + } + deriving stock (Generic, Eq, Show) + +newtype PSpendRedeemer (s :: S) + = PSpendRedeemer (Term s (PDataRecord '["inIx" ':= PData, "outIxs" ':= PBuiltinList PData])) + deriving stock (Generic) + deriving anyclass (PlutusType, PIsData, PDataFields, PShow) + +instance DerivePlutusType PSpendRedeemer where type DPTStrat _ = PlutusTypeData +instance PTryFrom PData PSpendRedeemer + +spend :: Term s (PTxOut :--> PBool) + -> Term s (PTxOut :--> PTxOut :--> PBool) + -> Term s (PBuiltinList PTxOut :--> PInteger :--> PBool) + -> Term s PValidator +spend inputValidator inputOutputValidator collectiveOutputValidator = + plam $ \_datum redeemer ctx -> unTermCont $ do + let red = punsafeCoerce @_ @_ @PSpendRedeemer redeemer + redF <- pletFieldsC @'["indx", "outIxs"] red + ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx + PSpending ownRef' <- pmatchC ctxF.purpose + ownRef <- pletC $ pfield @"_0" # ownRef' + txInfoF <- pletFieldsC @'["inputs", "outputs"] ctxF.txInfo + let inIx = pasInt # redF.inIx + outIxs = pmap # pasInt # redF.outIxs + (_, outTxOuts, outputCount) = + pfoldr # + plan (\(curIdx (prevIdx, acc, count) -> pif + (curIdx #< prevIdx) + (curIdx, pconcat # acc # psingleton (pelemAt @PBuiltinList # curIdx # txInfoF.outputs), count + 1)) + perror + ) # + (P.length # outputs, [], 0) # + outIxs + + outOutput = pelemAt @PBuiltinList # outIdx # txInfoF.outputs + inInputF <- pletFieldsC @'["outRef", "resolved"] (pelemAt @PBuiltinList # inIx # txInfoF.inputs) + return $ + popaque $ + pif + (ptraceIfFalse "Indicated input must match the spending one" (ownRef #== inInputF.outRef)) + (inputOutputValidator # inInputF.resolved # outOutput) + perror From 305be8b58ee3086b6cfee6fbacee67574f7b2110 Mon Sep 17 00:00:00 2001 From: Mark Petruska Date: Thu, 25 Apr 2024 14:47:39 +0200 Subject: [PATCH 2/3] fix: Add some build fixes --- src/Plutarch/SingularUTxOIndexerOneToMany.hs | 48 ++++++++++++-------- 1 file changed, 30 insertions(+), 18 deletions(-) diff --git a/src/Plutarch/SingularUTxOIndexerOneToMany.hs b/src/Plutarch/SingularUTxOIndexerOneToMany.hs index 928c32c..2e3c9a0 100644 --- a/src/Plutarch/SingularUTxOIndexerOneToMany.hs +++ b/src/Plutarch/SingularUTxOIndexerOneToMany.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedRecordDot #-} + module Plutarch.SingularUTxOIndexerOneToMany ( spend, SpendRedeemer (..), @@ -34,35 +36,45 @@ newtype PSpendRedeemer (s :: S) instance DerivePlutusType PSpendRedeemer where type DPTStrat _ = PlutusTypeData instance PTryFrom PData PSpendRedeemer -spend :: Term s (PTxOut :--> PBool) +data PMyAggregator (s :: S) = PMyAggregator (Term s PInteger) (Term s (PList PTxOut)) (Term s PInteger) + deriving stock (Generic) + deriving anyclass (PlutusType, PEq, PShow) + +instance DerivePlutusType PMyAggregator where type DPTStrat _ = PlutusTypeScott + +spend :: Term s (PTxOut :--> PBool) -> Term s (PTxOut :--> PTxOut :--> PBool) -> Term s (PBuiltinList PTxOut :--> PInteger :--> PBool) -> Term s PValidator spend inputValidator inputOutputValidator collectiveOutputValidator = plam $ \_datum redeemer ctx -> unTermCont $ do let red = punsafeCoerce @_ @_ @PSpendRedeemer redeemer - redF <- pletFieldsC @'["indx", "outIxs"] red + redF <- pletFieldsC @'["inIx", "outIxs"] red ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx PSpending ownRef' <- pmatchC ctxF.purpose ownRef <- pletC $ pfield @"_0" # ownRef' txInfoF <- pletFieldsC @'["inputs", "outputs"] ctxF.txInfo let inIx = pasInt # redF.inIx outIxs = pmap # pasInt # redF.outIxs - (_, outTxOuts, outputCount) = + aggregated = pfoldr # - plan (\(curIdx (prevIdx, acc, count) -> pif - (curIdx #< prevIdx) - (curIdx, pconcat # acc # psingleton (pelemAt @PBuiltinList # curIdx # txInfoF.outputs), count + 1)) - perror - ) # - (P.length # outputs, [], 0) # - outIxs + (plam $ \curIdx p -> + pmatch p $ \case + PMyAggregator prevIdx acc count -> + pif + (curIdx #< prevIdx) + (pcon (PMyAggregator curIdx (pconcat # acc #$ psingleton # (pelemAt @PBuiltinList # curIdx # txInfoF.outputs)) (count + 1))) + perror + ) + # pcon (PMyAggregator (plength # txInfoF.outputs) pnil 0) # outIxs - outOutput = pelemAt @PBuiltinList # outIdx # txInfoF.outputs - inInputF <- pletFieldsC @'["outRef", "resolved"] (pelemAt @PBuiltinList # inIx # txInfoF.inputs) - return $ - popaque $ - pif - (ptraceIfFalse "Indicated input must match the spending one" (ownRef #== inInputF.outRef)) - (inputOutputValidator # inInputF.resolved # outOutput) - perror + return $ pmatch aggregated $ \case + PMyAggregator _ outTxOuts outputCount -> unTermCont $ do + let outOutput = pelemAt @PBuiltinList # outIxs # txInfoF.outputs + inInputF <- pletFieldsC @'["outRef", "resolved"] (pelemAt @PBuiltinList # inIx # txInfoF.inputs) + return $ + popaque $ + pif + (ptraceIfFalse "Indicated input must match the spending one" (ownRef #== inInputF.outRef)) + (inputOutputValidator # inInputF.resolved # outOutput) + perror From 6a8e6408ac852a598b72158d49e1b5cdddd25e51 Mon Sep 17 00:00:00 2001 From: hade Date: Thu, 25 Apr 2024 21:09:37 +0700 Subject: [PATCH 3/3] fix: more build fixes --- plutarch-design-pattern.cabal | 2 +- src/Plutarch/SingularUTxOIndexerOneToMany.hs | 67 ++++++++++++-------- 2 files changed, 41 insertions(+), 28 deletions(-) diff --git a/plutarch-design-pattern.cabal b/plutarch-design-pattern.cabal index cf4eb8a..4b5dbd9 100644 --- a/plutarch-design-pattern.cabal +++ b/plutarch-design-pattern.cabal @@ -119,11 +119,11 @@ library exposed-modules: Plutarch.MerkelizedValidator Plutarch.SingularUTxOIndexer + Plutarch.SingularUTxOIndexerOneToMany Plutarch.StakeValidator Plutarch.TxLevelMinter Plutarch.Utils Plutarch.ValidityRangeNormalization - Plutarch.SingularUTxOIndexerOneToMany build-depends: , aeson diff --git a/src/Plutarch/SingularUTxOIndexerOneToMany.hs b/src/Plutarch/SingularUTxOIndexerOneToMany.hs index 2e3c9a0..e67abaa 100644 --- a/src/Plutarch/SingularUTxOIndexerOneToMany.hs +++ b/src/Plutarch/SingularUTxOIndexerOneToMany.hs @@ -8,6 +8,7 @@ module Plutarch.SingularUTxOIndexerOneToMany ( import Plutarch.Api.V2 ( PScriptPurpose (..), + PTxInInfo, PTxOut, PValidator, ) @@ -42,39 +43,51 @@ data PMyAggregator (s :: S) = PMyAggregator (Term s PInteger) (Term s (PList PTx instance DerivePlutusType PMyAggregator where type DPTStrat _ = PlutusTypeScott -spend :: Term s (PTxOut :--> PBool) - -> Term s (PTxOut :--> PTxOut :--> PBool) - -> Term s (PBuiltinList PTxOut :--> PInteger :--> PBool) - -> Term s PValidator +spend :: + Term s (PTxInInfo :--> PBool) -> + Term s (PTxOut :--> PTxOut :--> PBool) -> + Term s (PList PTxOut :--> PInteger :--> PBool) -> + Term s PValidator spend inputValidator inputOutputValidator collectiveOutputValidator = plam $ \_datum redeemer ctx -> unTermCont $ do - let red = punsafeCoerce @_ @_ @PSpendRedeemer redeemer + red <- pletC $ punsafeCoerce @_ @_ @PSpendRedeemer redeemer redF <- pletFieldsC @'["inIx", "outIxs"] red ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx PSpending ownRef' <- pmatchC ctxF.purpose ownRef <- pletC $ pfield @"_0" # ownRef' txInfoF <- pletFieldsC @'["inputs", "outputs"] ctxF.txInfo - let inIx = pasInt # redF.inIx - outIxs = pmap # pasInt # redF.outIxs - aggregated = - pfoldr # - (plam $ \curIdx p -> - pmatch p $ \case - PMyAggregator prevIdx acc count -> - pif - (curIdx #< prevIdx) - (pcon (PMyAggregator curIdx (pconcat # acc #$ psingleton # (pelemAt @PBuiltinList # curIdx # txInfoF.outputs)) (count + 1))) - perror - ) - # pcon (PMyAggregator (plength # txInfoF.outputs) pnil 0) # outIxs + input <- pletC $ pelemAt @PBuiltinList # (pasInt # redF.inIx) # txInfoF.inputs + outIxs <- pletC $ pmap # pasInt # redF.outIxs + inInputF <- pletFieldsC @'["outRef", "resolved"] input + aggregated <- + pletC $ + pfoldr + # (matchAgg inputOutputValidator # inInputF.resolved # txInfoF.outputs) + # pcon (PMyAggregator (plength # pfromData txInfoF.outputs) pnil 0) + # outIxs return $ pmatch aggregated $ \case - PMyAggregator _ outTxOuts outputCount -> unTermCont $ do - let outOutput = pelemAt @PBuiltinList # outIxs # txInfoF.outputs - inInputF <- pletFieldsC @'["outRef", "resolved"] (pelemAt @PBuiltinList # inIx # txInfoF.inputs) - return $ - popaque $ - pif - (ptraceIfFalse "Indicated input must match the spending one" (ownRef #== inInputF.outRef)) - (inputOutputValidator # inInputF.resolved # outOutput) - perror + PMyAggregator _ outTxOuts outputCount -> unTermCont $ do + return $ + popaque $ + pif + ( ptraceIfFalse "Indicated input must match the spending one" (ownRef #== inInputF.outRef) + #&& ptraceIfFalse "Input Validator Fails" (inputValidator # input) + ) + (collectiveOutputValidator # outTxOuts # outputCount) + perror + +matchAgg :: Term s (PTxOut :--> PTxOut :--> PBool) -> Term s (PTxOut :--> PBuiltinList PTxOut :--> PInteger :--> PMyAggregator :--> PMyAggregator) +matchAgg inputOutputValidator = plam $ \input outputs curIdx p -> unTermCont $ do + PMyAggregator prevIdx acc count <- pmatchC p + return $ + pif + (curIdx #== prevIdx) + ( P.do + let outOutput = pelemAt @PBuiltinList # curIdx # outputs + pif + (ptraceIfFalse "Input Output Validator Fails" (inputOutputValidator # input # outOutput)) + (pcon (PMyAggregator curIdx (pconcat # acc #$ psingleton # (pelemAt @PBuiltinList # curIdx # outputs)) (count + 1))) + perror + ) + perror