From f9d7db93232c345a41c6c672bbcb2b1af75468c3 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 11 Apr 2022 18:25:39 -0500 Subject: [PATCH 01/29] Rebase master to Treasury Withdrawal Effect Liqwid-Labs/agora#46 --- agora.cabal | 1 + agora/Agora/Effect/TreasuryWithdrawal.hs | 51 ++++++++++++++++++++++++ 2 files changed, 52 insertions(+) create mode 100644 agora/Agora/Effect/TreasuryWithdrawal.hs diff --git a/agora.cabal b/agora.cabal index 041af40..aae5776 100644 --- a/agora.cabal +++ b/agora.cabal @@ -123,6 +123,7 @@ library exposed-modules: Agora.AuthorityToken Agora.Effect + Agora.Effect.TreasuryWithdrawal Agora.Governor Agora.MultiSig Agora.Proposal diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs new file mode 100644 index 0000000..9a32143 --- /dev/null +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -0,0 +1,51 @@ +{- | +Module : Agora.Effect.TreasuryWithdrawal +Maintainer : seungheon.ooh@gmail.com +Description: An Effect that withdraws treasury deposit +-} +module Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalDatum) where + +import GHC.Generics qualified as GHC +import Generics.SOP + +import Agora.Effect +import Agora.Utils +import Plutus.V1.Ledger.Value +import Plutarch +import qualified Plutarch.Monadic as P +import Plutarch.Api.V1 +import Plutarch.DataRepr + +data PTreasuryWithdrawalDatum (s :: S) + = PTreasuryWithdrawalDatum + ( Term + s + (PDataRecord + '[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue)) ] + ) + ) + deriving stock (GHC.Generic) + deriving anyclass (Generic, PIsDataRepr) + deriving + (PlutusType, PIsData, PDataFields) + via PIsDataReprInstances PTreasuryWithdrawalDatum + +treasuryWithdrawalDatum :: forall {s :: S}. CurrencySymbol -> Term s PValidator +treasuryWithdrawalDatum currSymbol = makeEffect currSymbol $ + \_cs (_datum :: Term _ PTreasuryWithdrawalDatum) _txOutRef _txInfo -> P.do + let outputs = pmap # + plam (\_out -> P.do + out <- pletFields @'["address", "value"] $ pfromData _out + cred <- pletFields @'["credential"] $ pfromData out.address + pdata $ ptuple # cred.credential # out.value + ) #$ + pfield @"outputs" # _txInfo + recivers = pfromData (pfield @"receivers" # _datum) + checkOutputs = pall # plam id #$ pmap # + plam (\_out -> P.do + pelem # _out # outputs + ) #$ + recivers + passert "Transaction output does not match receivers" checkOutputs + popaque $ pconstant () + From fecbf6678282732aff01c21ea6de62630df1fb2b Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 11 Apr 2022 18:43:50 -0500 Subject: [PATCH 02/29] formatted Treasury Withdrawal Effect --- agora/Agora/Effect/TreasuryWithdrawal.hs | 68 ++++++++++++++---------- 1 file changed, 39 insertions(+), 29 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 9a32143..f56391c 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -3,25 +3,31 @@ Module : Agora.Effect.TreasuryWithdrawal Maintainer : seungheon.ooh@gmail.com Description: An Effect that withdraws treasury deposit -} -module Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalDatum) where +module Agora.Effect.TreasuryWithdrawal (PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where import GHC.Generics qualified as GHC -import Generics.SOP +import Generics.SOP (Generic, I (I)) -import Agora.Effect -import Agora.Utils -import Plutus.V1.Ledger.Value -import Plutarch -import qualified Plutarch.Monadic as P -import Plutarch.Api.V1 -import Plutarch.DataRepr +import Agora.Effect (makeEffect) +import Agora.Utils (passert) +import Plutarch (popaque) +import Plutarch.Api.V1 ( + PCredential, + PTuple, + PValidator, + PValue, + ptuple, + ) +import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..)) +import Plutarch.Monadic qualified as P +import Plutus.V1.Ledger.Value (CurrencySymbol) data PTreasuryWithdrawalDatum (s :: S) = PTreasuryWithdrawalDatum ( Term s - (PDataRecord - '[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue)) ] + ( PDataRecord + '["receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))] ) ) deriving stock (GHC.Generic) @@ -30,22 +36,26 @@ data PTreasuryWithdrawalDatum (s :: S) (PlutusType, PIsData, PDataFields) via PIsDataReprInstances PTreasuryWithdrawalDatum -treasuryWithdrawalDatum :: forall {s :: S}. CurrencySymbol -> Term s PValidator -treasuryWithdrawalDatum currSymbol = makeEffect currSymbol $ +treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator +treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ \_cs (_datum :: Term _ PTreasuryWithdrawalDatum) _txOutRef _txInfo -> P.do - let outputs = pmap # - plam (\_out -> P.do - out <- pletFields @'["address", "value"] $ pfromData _out - cred <- pletFields @'["credential"] $ pfromData out.address - pdata $ ptuple # cred.credential # out.value - ) #$ - pfield @"outputs" # _txInfo - recivers = pfromData (pfield @"receivers" # _datum) - checkOutputs = pall # plam id #$ pmap # - plam (\_out -> P.do - pelem # _out # outputs - ) #$ - recivers - passert "Transaction output does not match receivers" checkOutputs - popaque $ pconstant () - + let outputs = + pmap + # plam + ( \_out -> P.do + out <- pletFields @'["address", "value"] $ pfromData _out + cred <- pletFields @'["credential"] $ pfromData out.address + pdata $ ptuple # cred.credential # out.value + ) + #$ pfield @"outputs" + # _txInfo + recivers = pfromData $ pfield @"receivers" # _datum + checkOutputs = + pall # plam id #$ pmap + # plam + ( \_out -> P.do + pelem # _out # outputs + ) + #$ recivers + passert "Transaction output does not match receivers" checkOutputs + popaque $ pconstant () From 2fc54b3fc5cfd26c6b70983502a7063303625e7c Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Tue, 12 Apr 2022 19:38:33 -0500 Subject: [PATCH 03/29] Treasury Withdrawal Effect ensures exact number of outputs, Haskell-level datum --- agora/Agora/Effect/TreasuryWithdrawal.hs | 56 +++++++++++++++++------- 1 file changed, 41 insertions(+), 15 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index f56391c..567a13a 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -1,12 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} + {- | Module : Agora.Effect.TreasuryWithdrawal Maintainer : seungheon.ooh@gmail.com Description: An Effect that withdraws treasury deposit -} -module Agora.Effect.TreasuryWithdrawal (PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where +module Agora.Effect.TreasuryWithdrawal (TreasuryWithdrawalDatum, PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where import GHC.Generics qualified as GHC -import Generics.SOP (Generic, I (I)) +import Generics.SOP ( I(I), Generic ) import Agora.Effect (makeEffect) import Agora.Utils (passert) @@ -18,9 +20,22 @@ import Plutarch.Api.V1 ( PValue, ptuple, ) -import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..)) +import Plutarch.DataRepr + ( PDataFields, + PIsDataReprInstances(..), + DerivePConstantViaData(..) ) +import Plutarch.Lift ( PUnsafeLiftDecl(..) ) import Plutarch.Monadic qualified as P -import Plutus.V1.Ledger.Value (CurrencySymbol) +import Plutus.V1.Ledger.Credential ( Credential ) +import Plutus.V1.Ledger.Value ( CurrencySymbol, Value ) +import PlutusTx qualified + +data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]} + deriving stock (Show, GHC.Generic) + deriving anyclass (Generic) + +PlutusTx.makeLift ''TreasuryWithdrawalDatum +PlutusTx.unstableMakeIsData ''TreasuryWithdrawalDatum data PTreasuryWithdrawalDatum (s :: S) = PTreasuryWithdrawalDatum @@ -36,10 +51,19 @@ data PTreasuryWithdrawalDatum (s :: S) (PlutusType, PIsData, PDataFields) via PIsDataReprInstances PTreasuryWithdrawalDatum +instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where + type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum +deriving via + (DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum) + instance + (PConstant TreasuryWithdrawalDatum) + treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ \_cs (_datum :: Term _ PTreasuryWithdrawalDatum) _txOutRef _txInfo -> P.do - let outputs = + receivers <- plet $ pfromData $ pfield @"receivers" # _datum + txInfo <- pletFields @'["outputs"] _txInfo + let outputValues = pmap # plam ( \_out -> P.do @@ -47,15 +71,17 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ cred <- pletFields @'["credential"] $ pfromData out.address pdata $ ptuple # cred.credential # out.value ) - #$ pfield @"outputs" - # _txInfo - recivers = pfromData $ pfield @"receivers" # _datum - checkOutputs = + #$ txInfo.outputs + outputContentMatchesRecivers = pall # plam id #$ pmap - # plam - ( \_out -> P.do - pelem # _out # outputs - ) - #$ recivers - passert "Transaction output does not match receivers" checkOutputs + # plam (\_out -> pelem # _out # outputValues) + #$ receivers + outputNumberMatchesRecivers = plength # receivers #== plength # (pfromData txInfo.outputs) + outputIsNotPayingToEffect = pconstant True -- How to check if it's not paying to effect itself? + + passert "Transaction output does not match receivers" + $ outputContentMatchesRecivers + #&& outputNumberMatchesRecivers + #&& outputIsNotPayingToEffect + popaque $ pconstant () From 1f6d8573a0a6750f16c42c0b4c837c4a73d98fe7 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Wed, 13 Apr 2022 11:52:14 -0400 Subject: [PATCH 04/29] Treasury Withdrawal Effect Constraint It checks for output that pays to effect itself. --- agora/Agora/Effect/TreasuryWithdrawal.hs | 63 +++++++++++++++++------- 1 file changed, 45 insertions(+), 18 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 567a13a..7aa7646 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -8,26 +8,30 @@ Description: An Effect that withdraws treasury deposit module Agora.Effect.TreasuryWithdrawal (TreasuryWithdrawalDatum, PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where import GHC.Generics qualified as GHC -import Generics.SOP ( I(I), Generic ) +import Generics.SOP (Generic, I (I)) import Agora.Effect (makeEffect) -import Agora.Utils (passert) +import Agora.Utils ( passert, passetClassValueOf' ) import Plutarch (popaque) -import Plutarch.Api.V1 ( - PCredential, - PTuple, - PValidator, - PValue, - ptuple, +import Plutarch.Api.V1 + ( PTxInfo, + PTxOutRef, + PValidator, + PTuple, + PValue, + PCredential, + ptuple, + PTxInInfo, + PTxOut ) +import Plutarch.DataRepr ( + DerivePConstantViaData (..), + PDataFields, + PIsDataReprInstances (..), ) -import Plutarch.DataRepr - ( PDataFields, - PIsDataReprInstances(..), - DerivePConstantViaData(..) ) -import Plutarch.Lift ( PUnsafeLiftDecl(..) ) +import Plutarch.Lift (PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P -import Plutus.V1.Ledger.Credential ( Credential ) -import Plutus.V1.Ledger.Value ( CurrencySymbol, Value ) +import Plutus.V1.Ledger.Credential (Credential) +import Plutus.V1.Ledger.Value (AssetClass (..), CurrencySymbol, Value) import PlutusTx qualified data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]} @@ -58,6 +62,19 @@ deriving via instance (PConstant TreasuryWithdrawalDatum) +findOwnInput :: Term s (PTxInfo :--> PTxOutRef :--> PTxInInfo) +findOwnInput = phoistAcyclic $ + plam $ \txInfo spending' -> P.do + input <- plet $ pfromData $ pfield @"inputs" # txInfo + spending <- plet $ pdata spending' + PJust result <- pmatch $ pfind # plam (\x -> pfield @"outRef" # x #== spending) # input + pfromData result + +findOwnAddress :: Term s (PTxInfo :--> PTxOutRef :--> PTxOut) +findOwnAddress = phoistAcyclic $ + plam $ \txInfo spending -> P.do + pfromData $ pfield @"resolved" #$ findOwnInput # txInfo # spending + treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ \_cs (_datum :: Term _ PTreasuryWithdrawalDatum) _txOutRef _txInfo -> P.do @@ -77,10 +94,20 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ # plam (\_out -> pelem # _out # outputValues) #$ receivers outputNumberMatchesRecivers = plength # receivers #== plength # (pfromData txInfo.outputs) - outputIsNotPayingToEffect = pconstant True -- How to check if it's not paying to effect itself? + outputIsNotPayingToEffect = P.do + input <- pletFields @'["address", "value"] $ findOwnAddress # pfromData _txInfo # _txOutRef + let correctMinimum = passetClassValueOf' (AssetClass ("", "")) # input.value #== 2000000 + notPayingToEffect = + pnot #$ pany + # plam + ( \x -> + input.address #== pfield @"address" # pfromData x + ) + # pfromData txInfo.outputs + correctMinimum #&& notPayingToEffect - passert "Transaction output does not match receivers" - $ outputContentMatchesRecivers + passert "Transaction output does not match receivers" $ + outputContentMatchesRecivers #&& outputNumberMatchesRecivers #&& outputIsNotPayingToEffect From 81dccdb858f35e64e8c9661b8a25378d76801209 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Thu, 14 Apr 2022 11:20:16 -0400 Subject: [PATCH 05/29] Simple fixes for Treasury Withdrawal Effect Some simple fixes: naming convention, proper comment for haddoc --- agora/Agora/Effect/TreasuryWithdrawal.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 7aa7646..6ba6375 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -4,6 +4,8 @@ Module : Agora.Effect.TreasuryWithdrawal Maintainer : seungheon.ooh@gmail.com Description: An Effect that withdraws treasury deposit + +An Effect that withdraws treasury deposit -} module Agora.Effect.TreasuryWithdrawal (TreasuryWithdrawalDatum, PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where @@ -77,25 +79,25 @@ findOwnAddress = phoistAcyclic $ treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ - \_cs (_datum :: Term _ PTreasuryWithdrawalDatum) _txOutRef _txInfo -> P.do - receivers <- plet $ pfromData $ pfield @"receivers" # _datum - txInfo <- pletFields @'["outputs"] _txInfo + \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do + receivers <- plet $ pfromData $ pfield @"receivers" # datum' + txInfo <- pletFields @'["outputs"] txInfo' let outputValues = pmap # plam - ( \_out -> P.do - out <- pletFields @'["address", "value"] $ pfromData _out + ( \out' -> P.do + out <- pletFields @'["address", "value"] $ pfromData out' cred <- pletFields @'["credential"] $ pfromData out.address pdata $ ptuple # cred.credential # out.value ) #$ txInfo.outputs outputContentMatchesRecivers = pall # plam id #$ pmap - # plam (\_out -> pelem # _out # outputValues) + # plam (\out -> pelem # out # outputValues) #$ receivers outputNumberMatchesRecivers = plength # receivers #== plength # (pfromData txInfo.outputs) outputIsNotPayingToEffect = P.do - input <- pletFields @'["address", "value"] $ findOwnAddress # pfromData _txInfo # _txOutRef + input <- pletFields @'["address", "value"] $ findOwnAddress # pfromData txInfo' # txOutRef' let correctMinimum = passetClassValueOf' (AssetClass ("", "")) # input.value #== 2000000 notPayingToEffect = pnot #$ pany From a3a76a2461974c61dc8072da3f1065ae0aa224de Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Fri, 15 Apr 2022 08:43:47 -0500 Subject: [PATCH 06/29] small fixes for Treasury Withdrawal Effect --- agora/Agora/Effect/TreasuryWithdrawal.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 6ba6375..8f475f6 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -64,6 +64,7 @@ deriving via instance (PConstant TreasuryWithdrawalDatum) +-- These functions can be replaced with ones on Utils.hs once seungheonoh/util branch get merged. findOwnInput :: Term s (PTxInfo :--> PTxOutRef :--> PTxInInfo) findOwnInput = phoistAcyclic $ plam $ \txInfo spending' -> P.do @@ -95,7 +96,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ pall # plam id #$ pmap # plam (\out -> pelem # out # outputValues) #$ receivers - outputNumberMatchesRecivers = plength # receivers #== plength # (pfromData txInfo.outputs) + outputNumberMatchesReceivers = plength # receivers #== plength # (pfromData txInfo.outputs) outputIsNotPayingToEffect = P.do input <- pletFields @'["address", "value"] $ findOwnAddress # pfromData txInfo' # txOutRef' let correctMinimum = passetClassValueOf' (AssetClass ("", "")) # input.value #== 2000000 @@ -108,9 +109,8 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ # pfromData txInfo.outputs correctMinimum #&& notPayingToEffect - passert "Transaction output does not match receivers" $ - outputContentMatchesRecivers - #&& outputNumberMatchesRecivers - #&& outputIsNotPayingToEffect + passert "Transaction output does not match receivers" outputContentMatchesRecivers + passert "" outputNumberMatchesReceivers + passert "" outputIsNotPayingToEffect popaque $ pconstant () From 4d2c3af2bafe9094274903a450014bf8659a64a0 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Sat, 16 Apr 2022 00:07:32 -0500 Subject: [PATCH 07/29] Minor fixes Using Utils.hs, fixing fusioning issue, fixing CI build --- agora/Agora/Effect/TreasuryWithdrawal.hs | 51 ++++++++---------------- 1 file changed, 17 insertions(+), 34 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 8f475f6..66724be 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -13,18 +13,16 @@ import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) import Agora.Effect (makeEffect) -import Agora.Utils ( passert, passetClassValueOf' ) +import Agora.Utils (findTxOutByTxOutRef, passert) import Plutarch (popaque) -import Plutarch.Api.V1 - ( PTxInfo, - PTxOutRef, - PValidator, - PTuple, - PValue, - PCredential, - ptuple, - PTxInInfo, - PTxOut ) +import Plutarch.Api.V1 ( + PCredential, + PTuple, + PValidator, + PValue, + ptuple, + ) + import Plutarch.DataRepr ( DerivePConstantViaData (..), PDataFields, @@ -33,17 +31,17 @@ import Plutarch.DataRepr ( import Plutarch.Lift (PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P import Plutus.V1.Ledger.Credential (Credential) -import Plutus.V1.Ledger.Value (AssetClass (..), CurrencySymbol, Value) +import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified -data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]} +newtype TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]} deriving stock (Show, GHC.Generic) deriving anyclass (Generic) PlutusTx.makeLift ''TreasuryWithdrawalDatum PlutusTx.unstableMakeIsData ''TreasuryWithdrawalDatum -data PTreasuryWithdrawalDatum (s :: S) +newtype PTreasuryWithdrawalDatum (s :: S) = PTreasuryWithdrawalDatum ( Term s @@ -64,20 +62,6 @@ deriving via instance (PConstant TreasuryWithdrawalDatum) --- These functions can be replaced with ones on Utils.hs once seungheonoh/util branch get merged. -findOwnInput :: Term s (PTxInfo :--> PTxOutRef :--> PTxInInfo) -findOwnInput = phoistAcyclic $ - plam $ \txInfo spending' -> P.do - input <- plet $ pfromData $ pfield @"inputs" # txInfo - spending <- plet $ pdata spending' - PJust result <- pmatch $ pfind # plam (\x -> pfield @"outRef" # x #== spending) # input - pfromData result - -findOwnAddress :: Term s (PTxInfo :--> PTxOutRef :--> PTxOut) -findOwnAddress = phoistAcyclic $ - plam $ \txInfo spending -> P.do - pfromData $ pfield @"resolved" #$ findOwnInput # txInfo # spending - treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do @@ -93,21 +77,20 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ ) #$ txInfo.outputs outputContentMatchesRecivers = - pall # plam id #$ pmap - # plam (\out -> pelem # out # outputValues) + pall # plam (\out -> pelem # out # outputValues) #$ receivers outputNumberMatchesReceivers = plength # receivers #== plength # (pfromData txInfo.outputs) outputIsNotPayingToEffect = P.do - input <- pletFields @'["address", "value"] $ findOwnAddress # pfromData txInfo' # txOutRef' - let correctMinimum = passetClassValueOf' (AssetClass ("", "")) # input.value #== 2000000 - notPayingToEffect = + PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo' + input <- pletFields @'["address", "value"] $ txOut + let notPayingToEffect = pnot #$ pany # plam ( \x -> input.address #== pfield @"address" # pfromData x ) # pfromData txInfo.outputs - correctMinimum #&& notPayingToEffect + notPayingToEffect passert "Transaction output does not match receivers" outputContentMatchesRecivers passert "" outputNumberMatchesReceivers From 1e4d6e554ded29abcbda462e63a8585cc9196fe2 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Sat, 16 Apr 2022 00:33:23 -0500 Subject: [PATCH 08/29] Treasury Withdrawal Effect simple Haddock comment --- agora/Agora/Effect/TreasuryWithdrawal.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 66724be..52f3009 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -62,6 +62,20 @@ deriving via instance (PConstant TreasuryWithdrawalDatum) +{- | Withdraws given list of values to specific target addresses. +It can be evoked by burning GAT. The transaction should have correct +outputs to the users and any left overs should be paid back to the treasury. + +The validator does not accept any Redeemer as all "parameters" are provided +via encoded Datum. + +Note: +It should check... +1. Transaction outputs should contain all of what Datum specified +2. Left over assests should be redirected back to Treasury +It can be more flexiable over... +- The number of outputs themselves +-} treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do From bf67f387823d1a7e51aafa06d42a90987df6c867 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 18 Apr 2022 13:03:10 -0500 Subject: [PATCH 09/29] Treasury Withdrawal Effect checks if remainder is to the treasury It checks if transaction is paying the remainders to the treasury. --- agora/Agora/Effect/TreasuryWithdrawal.hs | 67 +++++++++++++++--------- 1 file changed, 42 insertions(+), 25 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 52f3009..467733b 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -13,15 +13,16 @@ import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) import Agora.Effect (makeEffect) -import Agora.Utils (findTxOutByTxOutRef, passert) +import Agora.Utils ( paddValue, passert ) import Plutarch (popaque) -import Plutarch.Api.V1 ( - PCredential, - PTuple, - PValidator, - PValue, - ptuple, - ) +import Plutarch.Api.V1 + ( PCredential, + PValue, + PTxOut(PTxOut), + PTxInInfo(PTxInInfo), + PTuple, + ptuple, + PValidator ) import Plutarch.DataRepr ( DerivePConstantViaData (..), @@ -78,9 +79,9 @@ It can be more flexiable over... -} treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ - \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do + \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) _txOutRef' txInfo' -> P.do receivers <- plet $ pfromData $ pfield @"receivers" # datum' - txInfo <- pletFields @'["outputs"] txInfo' + txInfo <- pletFields @'["outputs", "inputs"] txInfo' let outputValues = pmap # plam @@ -89,25 +90,41 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ cred <- pletFields @'["credential"] $ pfromData out.address pdata $ ptuple # cred.credential # out.value ) - #$ txInfo.outputs + # txInfo.outputs outputContentMatchesRecivers = pall # plam (\out -> pelem # out # outputValues) #$ receivers - outputNumberMatchesReceivers = plength # receivers #== plength # (pfromData txInfo.outputs) - outputIsNotPayingToEffect = P.do - PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo' - input <- pletFields @'["address", "value"] $ txOut - let notPayingToEffect = - pnot #$ pany - # plam - ( \x -> - input.address #== pfield @"address" # pfromData x - ) - # pfromData txInfo.outputs - notPayingToEffect + sumValues = + pfoldr + # plam + ( \((pfield @"_1" #) . pfromData -> x) y -> P.do + paddValue # (pfromData x) # y + ) + # (pconstant (mempty :: Value)) + inputCred = + pmap + # plam (\inInfo -> P.do + PTxInInfo inInfo' <- pmatch $ pfromData inInfo + PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # inInfo' + let addr = pfromData $ pfield @"address" # out + pfield @"credential" # addr) + # pfromData txInfo.inputs + totalInput = + pfoldr + # plam (\x' y -> P.do + PTxInInfo x <- pmatch $ pfromData x' + PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # x + paddValue # (pfromData $ pfield @"value" # out) # y) + # (pconstant (mempty :: Value)) + # pfromData txInfo.inputs + sumOutputsToInputAddr = sumValues #$ + pfilter + # plam (\((pfield @"_0" #) . pfromData -> addr) -> pelem # (addr) # inputCred) # outputValues + sumReceivers = sumValues # receivers +-- TODO: Probably need to check/exclude the effect input... + excessShouldBePaidToInputs = pdata (paddValue # sumReceivers # sumOutputsToInputAddr) #== pdata totalInput passert "Transaction output does not match receivers" outputContentMatchesRecivers - passert "" outputNumberMatchesReceivers - passert "" outputIsNotPayingToEffect + passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs popaque $ pconstant () From a82fa6f31d4a984e1aa85636b2812bd9c87cbab5 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 18 Apr 2022 13:59:59 -0500 Subject: [PATCH 10/29] Treasury Withdrawal Effect: Only check treasury inputs Tried to make it so that its only checking treasury inputs when checking if transaction is correctly returning the remainders to treasury. --- agora/Agora/Effect/TreasuryWithdrawal.hs | 88 +++++++++++++++--------- 1 file changed, 56 insertions(+), 32 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 467733b..f9623bd 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -13,16 +13,17 @@ import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) import Agora.Effect (makeEffect) -import Agora.Utils ( paddValue, passert ) +import Agora.Utils (findTxOutByTxOutRef, paddValue, passert) import Plutarch (popaque) -import Plutarch.Api.V1 - ( PCredential, - PValue, - PTxOut(PTxOut), - PTxInInfo(PTxInInfo), - PTuple, - ptuple, - PValidator ) +import Plutarch.Api.V1 ( + PCredential, + PTuple, + PTxInInfo (PTxInInfo), + PTxOut (PTxOut), + PValidator, + PValue, + ptuple, + ) import Plutarch.DataRepr ( DerivePConstantViaData (..), @@ -79,9 +80,11 @@ It can be more flexiable over... -} treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ - \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) _txOutRef' txInfo' -> P.do + \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do receivers <- plet $ pfromData $ pfield @"receivers" # datum' txInfo <- pletFields @'["outputs", "inputs"] txInfo' + PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo' + effInput <- pletFields @'["address", "value"] $ txOut let outputValues = pmap # plam @@ -94,37 +97,58 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ outputContentMatchesRecivers = pall # plam (\out -> pelem # out # outputValues) #$ receivers - sumValues = + sumValues = pfoldr # plam ( \((pfield @"_1" #) . pfromData -> x) y -> P.do - paddValue # (pfromData x) # y + paddValue # pfromData x # y ) - # (pconstant (mempty :: Value)) + # pconstant (mempty :: Value) inputCred = pmap - # plam (\inInfo -> P.do - PTxInInfo inInfo' <- pmatch $ pfromData inInfo - PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # inInfo' - let addr = pfromData $ pfield @"address" # out - pfield @"credential" # addr) + # plam + ( \inInfo -> P.do + PTxInInfo inInfo' <- pmatch $ pfromData inInfo + PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # inInfo' + let addr = pfromData $ pfield @"address" # out + pfield @"credential" # addr + ) # pfromData txInfo.inputs - totalInput = + totalTreasuryInputs = pfoldr - # plam (\x' y -> P.do - PTxInInfo x <- pmatch $ pfromData x' - PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # x - paddValue # (pfromData $ pfield @"value" # out) # y) - # (pconstant (mempty :: Value)) + # plam + ( \x' y -> P.do + PTxInInfo x <- pmatch $ pfromData x' + PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # x + -- only take ones from treasury + pif + (effInput.address #== pfield @"address" # out) + (paddValue # pfromData (pfield @"value" # out) # y) + y + ) + # pconstant (mempty :: Value) # pfromData txInfo.inputs - sumOutputsToInputAddr = sumValues #$ - pfilter - # plam (\((pfield @"_0" #) . pfromData -> addr) -> pelem # (addr) # inputCred) # outputValues - sumReceivers = sumValues # receivers --- TODO: Probably need to check/exclude the effect input... - excessShouldBePaidToInputs = pdata (paddValue # sumReceivers # sumOutputsToInputAddr) #== pdata totalInput + sumOutputsToTreasury = + sumValues + #$ pfilter + # plam + ( \((pfield @"_0" #) . pfromData -> addr) -> + pelem # addr # inputCred + #&& pnot # (addr #== pfield @"credential" # effInput.address) + ) + # outputValues + -- TODO: Probably need to check/exclude the effect input... + excessShouldBePaidToInputs = + pdata (paddValue # (sumValues # receivers) # sumOutputsToTreasury) #== pdata totalTreasuryInputs + shouldNotPayToEffect = + pnot #$ pany + # plam + ( \x -> + effInput.address #== pfield @"address" # pfromData x + ) + # pfromData txInfo.outputs passert "Transaction output does not match receivers" outputContentMatchesRecivers - passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs - + passert "Transaction should not pay to effects" shouldNotPayToEffect + passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs -- We might not need this. popaque $ pconstant () From c52b65a3351ed9a4088235c37eaee58992fd8716 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 18 Apr 2022 19:15:41 -0500 Subject: [PATCH 11/29] first step to the Test for Treasury Withdrawal Effect --- .../Spec/Effect/TreasuryWithdrawalEffect.hs | 59 +++++++++++++++++++ agora.cabal | 1 + 2 files changed, 60 insertions(+) create mode 100644 agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs new file mode 100644 index 0000000..2113624 --- /dev/null +++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs @@ -0,0 +1,59 @@ +{- | +Module : Spec.Effect.TreasuryWithdrawalEffect +Maintainer : seungheon.ooh@gmail.com +Description: Sample based testing for Treasury Withdrawal Effect + +This module tests the Treasury Withdrawal Effect. +-} + +module Spec.Effect.TreasuryWithdrawalEffect(currSymbol, signer, validator, validatorHashTN, withdrawalEffect) where + +import Plutarch.Api.V1 +import Plutus.V1.Ledger.Api +import Plutus.V1.Ledger.Value qualified as Value +import Plutus.V1.Ledger.Interval qualified as Interval + +import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator) + +-- | A sample Currency Symbol +currSymbol :: CurrencySymbol +currSymbol = CurrencySymbol "Orange19721121" + +-- | A sample 'PubKeyHash'. +signer :: PubKeyHash +signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" + +-- | Effect validator instance. +validator :: Validator +validator = mkValidator $ treasuryWithdrawalValidator currSymbol + +-- | 'TokenName' that represents the hash of the 'Stake' validator. +validatorHashTN :: TokenName +validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh + +withdrawalEffect :: ScriptContext +withdrawalEffect = + ScriptContext + { scriptContextTxInfo = + TxInfo + { txInfoInputs = + [ TxInInfo + (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 1 + , txOutDatumHash = Nothing + } + ] + , txInfoOutputs = [] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = mempty + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = [] + , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + } + , scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + } diff --git a/agora.cabal b/agora.cabal index aae5776..689ce97 100644 --- a/agora.cabal +++ b/agora.cabal @@ -154,6 +154,7 @@ test-suite agora-test other-modules: Spec.Model.MultiSig Spec.Sample.Stake + Spec.Effect.TreasuryWithdrawalEffect Spec.Stake Spec.Util Spec.AuthorityToken From 5584a47528e3b385a697877a1d81c73f7ba9adbd Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 18 Apr 2022 19:17:36 -0500 Subject: [PATCH 12/29] format... --- .../Spec/Effect/TreasuryWithdrawalEffect.hs | 45 +++++++++---------- agora.cabal | 2 +- 2 files changed, 23 insertions(+), 24 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs index 2113624..cba91e8 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs @@ -5,13 +5,12 @@ Description: Sample based testing for Treasury Withdrawal Effect This module tests the Treasury Withdrawal Effect. -} - -module Spec.Effect.TreasuryWithdrawalEffect(currSymbol, signer, validator, validatorHashTN, withdrawalEffect) where +module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, withdrawalEffect) where import Plutarch.Api.V1 import Plutus.V1.Ledger.Api -import Plutus.V1.Ledger.Value qualified as Value import Plutus.V1.Ledger.Interval qualified as Interval +import Plutus.V1.Ledger.Value qualified as Value import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator) @@ -34,26 +33,26 @@ validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh withdrawalEffect :: ScriptContext withdrawalEffect = ScriptContext - { scriptContextTxInfo = + { scriptContextTxInfo = TxInfo - { txInfoInputs = - [ TxInInfo - (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) - TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 1 - , txOutDatumHash = Nothing - } - ] - , txInfoOutputs = [] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = mempty - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = [signer] - , txInfoData = [] - , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - } + { txInfoInputs = + [ TxInInfo + (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 1 + , txOutDatumHash = Nothing + } + ] + , txInfoOutputs = [] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = mempty + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = [] + , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + } , scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) } diff --git a/agora.cabal b/agora.cabal index 689ce97..3f47333 100644 --- a/agora.cabal +++ b/agora.cabal @@ -152,9 +152,9 @@ test-suite agora-test main-is: Spec.hs hs-source-dirs: agora-test other-modules: + Spec.Effect.TreasuryWithdrawalEffect Spec.Model.MultiSig Spec.Sample.Stake - Spec.Effect.TreasuryWithdrawalEffect Spec.Stake Spec.Util Spec.AuthorityToken From 27d364bda1d28bf85092f7e95de9e71e935ba052 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Tue, 19 Apr 2022 22:32:06 -0400 Subject: [PATCH 13/29] TWE test --- .../Spec/Effect/TreasuryWithdrawalEffect.hs | 36 +++++++++++++++---- agora/Agora/Effect/TreasuryWithdrawal.hs | 6 +++- 2 files changed, 35 insertions(+), 7 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs index cba91e8..e8e3476 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs @@ -12,11 +12,20 @@ import Plutus.V1.Ledger.Api import Plutus.V1.Ledger.Interval qualified as Interval import Plutus.V1.Ledger.Value qualified as Value -import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator) +import Agora.Effect.TreasuryWithdrawal + +--receiverList :: TreasuryWithdrawalDatum +--receiverList = TreasuryWithdrawalDatum [(mempty, mempty)] + +_datum :: TreasuryWithdrawalDatum +_datum = + TreasuryWithdrawalDatum + [ (PubKeyCredential signer, Value.singleton currSymbol validatorHashTN 1) + ] -- | A sample Currency Symbol currSymbol :: CurrencySymbol -currSymbol = CurrencySymbol "Orange19721121" +currSymbol = CurrencySymbol "Orangebottle19721121" -- | A sample 'PubKeyHash'. signer :: PubKeyHash @@ -36,11 +45,25 @@ withdrawalEffect = { scriptContextTxInfo = TxInfo { txInfoInputs = - [ TxInInfo - (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + [ TxInInfo -- Initiator + (TxOutRef "Initiator" 1) TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 1 + , txOutValue = Value.singleton "" "" 2000000 + , txOutDatumHash = Nothing + } + , TxInInfo -- Treasury 1 + (TxOutRef "Treasury 1" 1) + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 10 + , txOutDatumHash = Nothing + } + , TxInInfo -- Treasury 2 + (TxOutRef "Treasury 2" 1) + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 10 , txOutDatumHash = Nothing } ] @@ -54,5 +77,6 @@ withdrawalEffect = , txInfoData = [] , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" } - , scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + , scriptContextPurpose = + Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) } diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index f9623bd..536c0e3 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -7,7 +7,11 @@ Description: An Effect that withdraws treasury deposit An Effect that withdraws treasury deposit -} -module Agora.Effect.TreasuryWithdrawal (TreasuryWithdrawalDatum, PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where +module Agora.Effect.TreasuryWithdrawal ( + TreasuryWithdrawalDatum(..), + PTreasuryWithdrawalDatum(..), + treasuryWithdrawalValidator, + ) where import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) From 0464a03989e7025d43bf64154afdbd1cd8c4a0b6 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Tue, 19 Apr 2022 23:02:51 -0400 Subject: [PATCH 14/29] now proper a proper script context.. and some formatting fixes --- .../Spec/Effect/TreasuryWithdrawalEffect.hs | 56 ++++++++++++++----- agora/Agora/Effect/TreasuryWithdrawal.hs | 6 +- 2 files changed, 46 insertions(+), 16 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs index e8e3476..751a3bc 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs @@ -5,25 +5,21 @@ Description: Sample based testing for Treasury Withdrawal Effect This module tests the Treasury Withdrawal Effect. -} -module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, withdrawalEffect) where +module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1) where import Plutarch.Api.V1 import Plutus.V1.Ledger.Api import Plutus.V1.Ledger.Interval qualified as Interval import Plutus.V1.Ledger.Value qualified as Value +import Data.ByteString.Hash + import Agora.Effect.TreasuryWithdrawal ---receiverList :: TreasuryWithdrawalDatum ---receiverList = TreasuryWithdrawalDatum [(mempty, mempty)] +-- receiverList :: TreasuryWithdrawalDatum +-- receiverList = TreasuryWithdrawalDatum [(mempty, mempty)] -_datum :: TreasuryWithdrawalDatum -_datum = - TreasuryWithdrawalDatum - [ (PubKeyCredential signer, Value.singleton currSymbol validatorHashTN 1) - ] - --- | A sample Currency Symbol +-- | A sample Currency Symbol. currSymbol :: CurrencySymbol currSymbol = CurrencySymbol "Orangebottle19721121" @@ -31,6 +27,24 @@ currSymbol = CurrencySymbol "Orangebottle19721121" signer :: PubKeyHash signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" +-- | List of users who the effect will pay to. +users :: [Credential] +users = + PubKeyCredential . PubKeyHash . toBuiltin . sha2 + <$> [ "Hello world" + , "Hello Agora" + , "Hello Plutarch" + ] + +-- | Datum for Treasury Withdrawal Effect Validator. +_datum :: TreasuryWithdrawalDatum +_datum = + TreasuryWithdrawalDatum + [ (users !! 0, Value.singleton currSymbol validatorHashTN 1) + , (users !! 1, Value.singleton currSymbol validatorHashTN 1) + , (users !! 2, Value.singleton currSymbol validatorHashTN 1) + ] + -- | Effect validator instance. validator :: Validator validator = mkValidator $ treasuryWithdrawalValidator currSymbol @@ -39,8 +53,8 @@ validator = mkValidator $ treasuryWithdrawalValidator currSymbol validatorHashTN :: TokenName validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh -withdrawalEffect :: ScriptContext -withdrawalEffect = +scriptContext1 :: ScriptContext +scriptContext1 = ScriptContext { scriptContextTxInfo = TxInfo @@ -67,7 +81,23 @@ withdrawalEffect = , txOutDatumHash = Nothing } ] - , txInfoOutputs = [] + , txInfoOutputs = + [ TxOut + { txOutAddress = Address (users !! 0) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 1 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (users !! 1) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 1 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (users !! 2) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 1 + , txOutDatumHash = Nothing + } + ] , txInfoFee = Value.singleton "" "" 2 , txInfoMint = mempty , txInfoDCert = [] diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 536c0e3..1156a3c 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -8,10 +8,10 @@ Description: An Effect that withdraws treasury deposit An Effect that withdraws treasury deposit -} module Agora.Effect.TreasuryWithdrawal ( - TreasuryWithdrawalDatum(..), - PTreasuryWithdrawalDatum(..), + TreasuryWithdrawalDatum (..), + PTreasuryWithdrawalDatum (..), treasuryWithdrawalValidator, - ) where +) where import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) From 57a0c104048844ae8f8ef95f93e9d503d2698a92 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Wed, 20 Apr 2022 08:43:22 -0400 Subject: [PATCH 15/29] added test entree Something is wrong. It does not work. --- .../Spec/Effect/TreasuryWithdrawalEffect.hs | 67 +++++++++++++++---- agora-test/Spec/Util.hs | 41 ++++++++++++ 2 files changed, 96 insertions(+), 12 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs index 751a3bc..f96fb65 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs @@ -5,8 +5,10 @@ Description: Sample based testing for Treasury Withdrawal Effect This module tests the Treasury Withdrawal Effect. -} -module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1) where +module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where +import Plutarch.Evaluate +import Plutarch.Builtin import Plutarch.Api.V1 import Plutus.V1.Ledger.Api import Plutus.V1.Ledger.Interval qualified as Interval @@ -16,12 +18,16 @@ import Data.ByteString.Hash import Agora.Effect.TreasuryWithdrawal +import Spec.Util + +import Test.Tasty + -- receiverList :: TreasuryWithdrawalDatum -- receiverList = TreasuryWithdrawalDatum [(mempty, mempty)] -- | A sample Currency Symbol. currSymbol :: CurrencySymbol -currSymbol = CurrencySymbol "Orangebottle19721121" +currSymbol = CurrencySymbol "ff" -- | A sample 'PubKeyHash'. signer :: PubKeyHash @@ -31,14 +37,23 @@ signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" users :: [Credential] users = PubKeyCredential . PubKeyHash . toBuiltin . sha2 - <$> [ "Hello world" - , "Hello Agora" - , "Hello Plutarch" + <$> [ "Orange" + , "Bottle" + , "Hello" + ] + +-- | List of users who the effect will pay to. +treasuries :: [Credential] +treasuries = + ScriptCredential . ValidatorHash . toBuiltin . sha2 + <$> [ "1234" + , "qwer" + , "asdf" ] -- | Datum for Treasury Withdrawal Effect Validator. -_datum :: TreasuryWithdrawalDatum -_datum = +datum :: TreasuryWithdrawalDatum +datum = TreasuryWithdrawalDatum [ (users !! 0, Value.singleton currSymbol validatorHashTN 1) , (users !! 1, Value.singleton currSymbol validatorHashTN 1) @@ -60,23 +75,23 @@ scriptContext1 = TxInfo { txInfoInputs = [ TxInInfo -- Initiator - (TxOutRef "Initiator" 1) + (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing , txOutValue = Value.singleton "" "" 2000000 , txOutDatumHash = Nothing } , TxInInfo -- Treasury 1 - (TxOutRef "Treasury 1" 1) + (TxOutRef "Treasury 1" 2) TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + { txOutAddress = Address (treasuries !! 0) Nothing , txOutValue = Value.singleton currSymbol validatorHashTN 10 , txOutDatumHash = Nothing } , TxInInfo -- Treasury 2 - (TxOutRef "Treasury 2" 1) + (TxOutRef "Treasury 2" 3) TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + { txOutAddress = Address (treasuries !! 1) Nothing , txOutValue = Value.singleton currSymbol validatorHashTN 10 , txOutDatumHash = Nothing } @@ -97,6 +112,17 @@ scriptContext1 = , txOutValue = Value.singleton currSymbol validatorHashTN 1 , txOutDatumHash = Nothing } + -- Send left overs to treasuries + , TxOut + { txOutAddress = Address (treasuries !! 0) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 7 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (treasuries !! 1) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 10 + , txOutDatumHash = Nothing + } ] , txInfoFee = Value.singleton "" "" 2 , txInfoMint = mempty @@ -110,3 +136,20 @@ scriptContext1 = , scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) } + + +tests :: [TestTree] +tests = + [ testGroup + "effect" + [ effectFailsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1] + ] + +_asdfa :: IO () +_asdfa = do + let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1) + case res of + Left e -> do + putStrLn $ show e <> " Traces: " <> show traces + Right _v -> + pure () diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 4350e45..1ebdc07 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -13,6 +13,8 @@ module Spec.Util ( policyFailsWith, validatorSucceedsWith, validatorFailsWith, + effectSucceedsWith, + effectFailsWith, -- * Plutus-land utils datumHash, @@ -129,6 +131,45 @@ validatorFailsWith tag policy datum redeemer scriptContext = # pconstant scriptContext ) + +-- | Check that a validator script succeeds, given a name and arguments. +effectSucceedsWith :: + ( PLift datum + , PlutusTx.ToData (PLifted datum) + ) => + String -> + ClosedTerm PValidator -> + PLifted datum -> + ScriptContext -> + TestTree +effectSucceedsWith tag eff datum scriptContext = + scriptSucceeds tag $ + compile + ( eff + # pforgetData (pconstantData datum) + # pforgetData (pconstantData ()) + # pconstant scriptContext + ) + +-- | Check that a validator script fails, given a name and arguments. +effectFailsWith :: + ( PLift datum + , PlutusTx.ToData (PLifted datum) + ) => + String -> + ClosedTerm PValidator -> + PLifted datum -> + ScriptContext -> + TestTree +effectFailsWith tag eff datum scriptContext = + scriptFails tag $ + compile + ( eff + # pforgetData (pconstantData datum) + # pforgetData (pconstantData ()) + # pconstant scriptContext + ) + -- | Check that an arbitrary script doesn't error when evaluated, given a name. scriptSucceeds :: String -> Script -> TestTree scriptSucceeds name script = testCase name $ do From 6c62c007f1453a6b5c0e5dfd5fdeb74ea08dc3bb Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Wed, 20 Apr 2022 12:06:16 -0400 Subject: [PATCH 16/29] more testings --- .../Spec/Effect/TreasuryWithdrawalEffect.hs | 150 ++++++++++++++---- 1 file changed, 122 insertions(+), 28 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs index f96fb65..96dbc35 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs @@ -17,6 +17,7 @@ import Plutus.V1.Ledger.Value qualified as Value import Data.ByteString.Hash import Agora.Effect.TreasuryWithdrawal +import Agora.AuthorityToken import Spec.Util @@ -27,7 +28,13 @@ import Test.Tasty -- | A sample Currency Symbol. currSymbol :: CurrencySymbol -currSymbol = CurrencySymbol "ff" +currSymbol = CurrencySymbol "12312099" + +gtSymbol :: CurrencySymbol +gtSymbol = CurrencySymbol "abb" + +gtToken :: TokenName +gtToken = TokenName "hey" -- | A sample 'PubKeyHash'. signer :: PubKeyHash @@ -51,13 +58,16 @@ treasuries = , "asdf" ] +_aa :: [Credential] +_aa = treasuries + -- | Datum for Treasury Withdrawal Effect Validator. datum :: TreasuryWithdrawalDatum datum = TreasuryWithdrawalDatum - [ (users !! 0, Value.singleton currSymbol validatorHashTN 1) - , (users !! 1, Value.singleton currSymbol validatorHashTN 1) - , (users !! 2, Value.singleton currSymbol validatorHashTN 1) + [ (users !! 0, Value.singleton gtSymbol gtToken 1) + , (users !! 1, Value.singleton gtSymbol gtToken 1) + , (users !! 2, Value.singleton gtSymbol gtToken 1) ] -- | Effect validator instance. @@ -73,59 +83,59 @@ scriptContext1 = ScriptContext { scriptContextTxInfo = TxInfo - { txInfoInputs = + { txInfoInputs = [ TxInInfo -- Initiator (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing - , txOutValue = Value.singleton "" "" 2000000 - , txOutDatumHash = Nothing - } - , TxInInfo -- Treasury 1 - (TxOutRef "Treasury 1" 2) - TxOut - { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 10 - , txOutDatumHash = Nothing - } - , TxInInfo -- Treasury 2 - (TxOutRef "Treasury 2" 3) - TxOut - { txOutAddress = Address (treasuries !! 1) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 10 - , txOutDatumHash = Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST + , txOutDatumHash = Just (DatumHash "") } + -- , TxInInfo -- Treasury 1 + -- (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) + -- TxOut + -- { txOutAddress = Address (treasuries !! 0) Nothing + -- , txOutValue = Value.singleton gtSymbol gtToken 10 + -- , txOutDatumHash = Just (DatumHash "") + -- } + -- , TxInInfo -- Treasury 2 + -- (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) + -- TxOut + -- { txOutAddress = Address (treasuries !! 1) Nothing + -- , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10 + -- , txOutDatumHash = Just (DatumHash "") + -- } ] - , txInfoOutputs = + , txInfoOutputs = [ TxOut { txOutAddress = Address (users !! 0) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 1 + , txOutValue = Value.singleton gtSymbol gtToken 1 , txOutDatumHash = Nothing } , TxOut { txOutAddress = Address (users !! 1) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 1 + , txOutValue = Value.singleton gtSymbol gtToken 1 , txOutDatumHash = Nothing } , TxOut { txOutAddress = Address (users !! 2) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 1 + , txOutValue = Value.singleton gtSymbol gtToken 1 , txOutDatumHash = Nothing } -- Send left overs to treasuries , TxOut { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 7 + , txOutValue = Value.singleton gtSymbol gtToken 7 , txOutDatumHash = Nothing } , TxOut { txOutAddress = Address (treasuries !! 1) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 10 + , txOutValue = Value.singleton gtSymbol gtToken 10 , txOutDatumHash = Nothing } ] , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = mempty + , txInfoMint = Value.singleton currSymbol validatorHashTN (-1) , txInfoDCert = [] , txInfoWdrl = [] , txInfoValidRange = Interval.always @@ -153,3 +163,87 @@ _asdfa = do putStrLn $ show e <> " Traces: " <> show traces Right _v -> pure () + +_test :: IO () +_test = do + let (res, _budget, traces) = evalScript $ compile (authorityTokensValidIn # pconstant currSymbol # (pconstant $ + TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing , + txOutValue = Value.singleton currSymbol validatorHashTN 1, + txOutDatumHash = Just (DatumHash "")})) + case res of + Left e -> do + putStrLn $ show e <> " Traces: " <> show traces + Right _v -> + pure () + +_test2 :: IO() +_test2 = do + let (res, _budget, traces) = evalScript $ compile (singleAuthorityTokenBurned (pconstant currSymbol) (pconstantData tinfo) (pconstant mv)) + case res of + Left e -> do + putStrLn $ show e <> " Traces: " <> show traces + Right _v -> + putStrLn $ show res + where + mv = mempty -- Value.singleton currSymbol validatorHashTN (1) + tinfo = TxInfo + { txInfoInputs = + [ TxInInfo -- Initiator + (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = mempty + , txOutDatumHash = Just (DatumHash "") + } + , TxInInfo -- Treasury 1 + (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) + TxOut + { txOutAddress = Address (treasuries !! 0) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 10 + , txOutDatumHash = Just (DatumHash "") + } + , TxInInfo -- Treasury 2 + (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) + TxOut + { txOutAddress = Address (treasuries !! 1) Nothing + , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10 + , txOutDatumHash = Just (DatumHash "") + } + ] + , txInfoOutputs = + [ TxOut + { txOutAddress = Address (users !! 0) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 1 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (users !! 1) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 1 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (users !! 2) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 1 + , txOutDatumHash = Nothing + } + -- Send left overs to treasuries + , TxOut + { txOutAddress = Address (treasuries !! 0) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 7 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (treasuries !! 1) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 10 + , txOutDatumHash = Nothing + } + ] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = mempty -- Value.singleton currSymbol validatorHashTN (-1) + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = [] + , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + } From fe5c18969e60d0c727ffb6c970f52e17f3b6ecf9 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Wed, 20 Apr 2022 19:57:14 -0500 Subject: [PATCH 17/29] withdrawal effect that actually passes tests --- .../Spec/Effect/TreasuryWithdrawalEffect.hs | 238 +++++++++--------- agora-test/Spec/Util.hs | 1 - agora/Agora/Effect/TreasuryWithdrawal.hs | 89 ++++--- 3 files changed, 165 insertions(+), 163 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs index 96dbc35..f3e9396 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs @@ -7,17 +7,17 @@ This module tests the Treasury Withdrawal Effect. -} module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where -import Plutarch.Evaluate -import Plutarch.Builtin import Plutarch.Api.V1 +import Plutarch.Builtin +import Plutarch.Evaluate import Plutus.V1.Ledger.Api import Plutus.V1.Ledger.Interval qualified as Interval import Plutus.V1.Ledger.Value qualified as Value import Data.ByteString.Hash -import Agora.Effect.TreasuryWithdrawal import Agora.AuthorityToken +import Agora.Effect.TreasuryWithdrawal import Spec.Util @@ -65,9 +65,9 @@ _aa = treasuries datum :: TreasuryWithdrawalDatum datum = TreasuryWithdrawalDatum - [ (users !! 0, Value.singleton gtSymbol gtToken 1) - , (users !! 1, Value.singleton gtSymbol gtToken 1) - , (users !! 2, Value.singleton gtSymbol gtToken 1) + [ (users !! 0, Value.singleton "1234ab" "LQ" 1) + , (users !! 1, Value.singleton "1234ab" "LQ" 1) + , (users !! 2, Value.singleton "1234ab" "LQ" 1) ] -- | Effect validator instance. @@ -83,7 +83,7 @@ scriptContext1 = ScriptContext { scriptContextTxInfo = TxInfo - { txInfoInputs = + { txInfoInputs = [ TxInInfo -- Initiator (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) TxOut @@ -91,48 +91,48 @@ scriptContext1 = , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST , txOutDatumHash = Just (DatumHash "") } - -- , TxInInfo -- Treasury 1 - -- (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) - -- TxOut - -- { txOutAddress = Address (treasuries !! 0) Nothing - -- , txOutValue = Value.singleton gtSymbol gtToken 10 - -- , txOutDatumHash = Just (DatumHash "") - -- } - -- , TxInInfo -- Treasury 2 - -- (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) - -- TxOut - -- { txOutAddress = Address (treasuries !! 1) Nothing - -- , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10 - -- , txOutDatumHash = Just (DatumHash "") - -- } + , TxInInfo -- Treasury 1 + (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) + TxOut + { txOutAddress = Address (treasuries !! 0) Nothing + , txOutValue = Value.singleton "1234ab" "LQ" 10 + , txOutDatumHash = Just (DatumHash "") + } + , TxInInfo -- Treasury 2 + (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) + TxOut + { txOutAddress = Address (treasuries !! 1) Nothing + , txOutValue = Value.singleton "1234ab" "LQ" 10 + , txOutDatumHash = Just (DatumHash "") + } ] - , txInfoOutputs = + , txInfoOutputs = [ TxOut { txOutAddress = Address (users !! 0) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 1 + , txOutValue = Value.singleton "1234ab" "LQ" 1 , txOutDatumHash = Nothing } , TxOut { txOutAddress = Address (users !! 1) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 1 + , txOutValue = Value.singleton "1234ab" "LQ" 1 , txOutDatumHash = Nothing } , TxOut { txOutAddress = Address (users !! 2) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 1 + , txOutValue = Value.singleton "1234ab" "LQ" 1 , txOutDatumHash = Nothing } - -- Send left overs to treasuries - , TxOut + , -- Send left overs to treasuries + TxOut { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 7 + , txOutValue = Value.singleton "1234ab" "LQ" 7 , txOutDatumHash = Nothing } , TxOut { txOutAddress = Address (treasuries !! 1) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 10 + , txOutValue = Value.singleton "1234ab" "LQ" 10 , txOutDatumHash = Nothing - } + } ] , txInfoFee = Value.singleton "" "" 2 , txInfoMint = Value.singleton currSymbol validatorHashTN (-1) @@ -147,103 +147,111 @@ scriptContext1 = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) } - tests :: [TestTree] tests = [ testGroup - "effect" - [ effectFailsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1] + "effect" + [effectSucceedsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1] ] _asdfa :: IO () _asdfa = do - let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1) - case res of - Left e -> do - putStrLn $ show e <> " Traces: " <> show traces - Right _v -> - pure () + let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1) + case res of + Left e -> do + putStrLn $ show e <> " Traces: " <> show traces + Right _v -> + pure () _test :: IO () _test = do - let (res, _budget, traces) = evalScript $ compile (authorityTokensValidIn # pconstant currSymbol # (pconstant $ - TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing , - txOutValue = Value.singleton currSymbol validatorHashTN 1, - txOutDatumHash = Just (DatumHash "")})) - case res of - Left e -> do - putStrLn $ show e <> " Traces: " <> show traces - Right _v -> - pure () + let (res, _budget, traces) = + evalScript $ + compile + ( authorityTokensValidIn # pconstant currSymbol + # ( pconstant $ + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 1 + , txOutDatumHash = Just (DatumHash "") + } + ) + ) + case res of + Left e -> do + putStrLn $ show e <> " Traces: " <> show traces + Right _v -> + pure () -_test2 :: IO() +_test2 :: IO () _test2 = do - let (res, _budget, traces) = evalScript $ compile (singleAuthorityTokenBurned (pconstant currSymbol) (pconstantData tinfo) (pconstant mv)) - case res of - Left e -> do - putStrLn $ show e <> " Traces: " <> show traces - Right _v -> - putStrLn $ show res - where - mv = mempty -- Value.singleton currSymbol validatorHashTN (1) - tinfo = TxInfo - { txInfoInputs = - [ TxInInfo -- Initiator - (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) - TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing - , txOutValue = mempty - , txOutDatumHash = Just (DatumHash "") - } - , TxInInfo -- Treasury 1 - (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) - TxOut - { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 10 - , txOutDatumHash = Just (DatumHash "") - } - , TxInInfo -- Treasury 2 - (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) - TxOut - { txOutAddress = Address (treasuries !! 1) Nothing - , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10 - , txOutDatumHash = Just (DatumHash "") - } - ] - , txInfoOutputs = - [ TxOut - { txOutAddress = Address (users !! 0) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 1 - , txOutDatumHash = Nothing + let (res, _budget, traces) = evalScript $ compile (singleAuthorityTokenBurned (pconstant currSymbol) (pconstantData tinfo) (pconstant mv)) + case res of + Left e -> do + putStrLn $ show e <> " Traces: " <> show traces + Right _v -> + putStrLn $ show res + where + mv = mempty -- Value.singleton currSymbol validatorHashTN (1) + tinfo = + TxInfo + { txInfoInputs = + [ TxInInfo -- Initiator + (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = mempty + , txOutDatumHash = Just (DatumHash "") } - , TxOut - { txOutAddress = Address (users !! 1) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 1 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (users !! 2) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 1 - , txOutDatumHash = Nothing - } - -- Send left overs to treasuries - , TxOut + , TxInInfo -- Treasury 1 + (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) + TxOut { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 7 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (treasuries !! 1) Nothing , txOutValue = Value.singleton gtSymbol gtToken 10 - , txOutDatumHash = Nothing - } - ] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = mempty -- Value.singleton currSymbol validatorHashTN (-1) - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = [signer] - , txInfoData = [] - , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - } + , txOutDatumHash = Just (DatumHash "") + } + , TxInInfo -- Treasury 2 + (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) + TxOut + { txOutAddress = Address (treasuries !! 1) Nothing + , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10 + , txOutDatumHash = Just (DatumHash "") + } + ] + , txInfoOutputs = + [ TxOut + { txOutAddress = Address (users !! 0) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 1 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (users !! 1) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 1 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (users !! 2) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 1 + , txOutDatumHash = Nothing + } + , -- Send left overs to treasuries + TxOut + { txOutAddress = Address (treasuries !! 0) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 7 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (treasuries !! 1) Nothing + , txOutValue = Value.singleton gtSymbol gtToken 10 + , txOutDatumHash = Nothing + } + ] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = mempty -- Value.singleton currSymbol validatorHashTN (-1) + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = [] + , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + } diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 1ebdc07..32fa1b1 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -131,7 +131,6 @@ validatorFailsWith tag policy datum redeemer scriptContext = # pconstant scriptContext ) - -- | Check that a validator script succeeds, given a name and arguments. effectSucceedsWith :: ( PLift datum diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 1156a3c..ddf3f32 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -22,8 +22,6 @@ import Plutarch (popaque) import Plutarch.Api.V1 ( PCredential, PTuple, - PTxInInfo (PTxInInfo), - PTxOut (PTxOut), PValidator, PValue, ptuple, @@ -92,58 +90,55 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ let outputValues = pmap # plam - ( \out' -> P.do - out <- pletFields @'["address", "value"] $ pfromData out' + ( \(pfromData -> out') -> P.do + out <- pletFields @'["address", "value"] $ out' cred <- pletFields @'["credential"] $ pfromData out.address pdata $ ptuple # cred.credential # out.value ) # txInfo.outputs + inputValues = + pmap + # plam + ( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do + txOut <- pletFields @'["address", "value"] $ txOut' + pdata $ ptuple # txOut.address # txOut.value + ) + # txInfo.inputs + treasuryInputValues = + pfilter + # plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address) + # inputValues + treasuryCredentials = + pmap + # plam ((pfield @"credential" #) . pfromData . (pfield @"_0" #) . pfromData) + # treasuryInputValues + treasuryOutputValues = + pfilter + # plam + ( \((pfield @"_0" #) . pfromData -> addr) -> P.do + pelem # addr # treasuryCredentials + ) + # outputValues + treasuryInputValuesSum = + pfoldr + # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) + # pconstant (mempty :: Value) + # treasuryInputValues + treasuryOutputValuesSum = + pfoldr + # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) + # pconstant (mempty :: Value) + # treasuryOutputValues + receiverValuesSum = + pfoldr + # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) + # pconstant (mempty :: Value) + # receivers outputContentMatchesRecivers = pall # plam (\out -> pelem # out # outputValues) #$ receivers - sumValues = - pfoldr - # plam - ( \((pfield @"_1" #) . pfromData -> x) y -> P.do - paddValue # pfromData x # y - ) - # pconstant (mempty :: Value) - inputCred = - pmap - # plam - ( \inInfo -> P.do - PTxInInfo inInfo' <- pmatch $ pfromData inInfo - PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # inInfo' - let addr = pfromData $ pfield @"address" # out - pfield @"credential" # addr - ) - # pfromData txInfo.inputs - totalTreasuryInputs = - pfoldr - # plam - ( \x' y -> P.do - PTxInInfo x <- pmatch $ pfromData x' - PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # x - -- only take ones from treasury - pif - (effInput.address #== pfield @"address" # out) - (paddValue # pfromData (pfield @"value" # out) # y) - y - ) - # pconstant (mempty :: Value) - # pfromData txInfo.inputs - sumOutputsToTreasury = - sumValues - #$ pfilter - # plam - ( \((pfield @"_0" #) . pfromData -> addr) -> - pelem # addr # inputCred - #&& pnot # (addr #== pfield @"credential" # effInput.address) - ) - # outputValues - -- TODO: Probably need to check/exclude the effect input... excessShouldBePaidToInputs = - pdata (paddValue # (sumValues # receivers) # sumOutputsToTreasury) #== pdata totalTreasuryInputs + pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum shouldNotPayToEffect = pnot #$ pany # plam @@ -154,5 +149,5 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ passert "Transaction output does not match receivers" outputContentMatchesRecivers passert "Transaction should not pay to effects" shouldNotPayToEffect - passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs -- We might not need this. + passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs popaque $ pconstant () From 82dd53efcf8ff3fcc4a82c5b636ae16f4ca9ac6b Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Thu, 21 Apr 2022 16:44:59 -0500 Subject: [PATCH 18/29] Restructured Testings Separated the samples and test sets --- agora-test/Spec.hs | 7 + agora-test/Spec/Effect/TreasuryWithdrawal.hs | 24 ++ .../Spec/Effect/TreasuryWithdrawalEffect.hs | 257 ------------------ .../Spec/Sample/Effect/TreasuryWithdrawal.hs | 132 +++++++++ agora.cabal | 3 +- 5 files changed, 165 insertions(+), 258 deletions(-) create mode 100644 agora-test/Spec/Effect/TreasuryWithdrawal.hs delete mode 100644 agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs create mode 100644 agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index 2f443cd..02394bc 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -8,6 +8,7 @@ import Test.Tasty (defaultMain, testGroup) -------------------------------------------------------------------------------- +import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal import Spec.AuthorityToken qualified as AuthorityToken import Spec.Model.MultiSig qualified as MultiSig import Spec.Stake qualified as Stake @@ -19,6 +20,12 @@ main = testGroup "test suite" [ testGroup + "Effects" + [ testGroup + "Treasury Withdrawal Effect" + TreasuryWithdrawal.tests + ] + , testGroup "Stake tests" Stake.tests , testGroup diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs new file mode 100644 index 0000000..77ceb92 --- /dev/null +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -0,0 +1,24 @@ +{- | +Module : Spec.Effect.TreasuryWithdrawalEffect +Maintainer : seungheon.ooh@gmail.com +Description: Sample based testing for Treasury Withdrawal Effect + +This module tests the Treasury Withdrawal Effect. +-} +module Spec.Effect.TreasuryWithdrawal (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where + +import Spec.Sample.Effect.TreasuryWithdrawal + + +import Agora.Effect.TreasuryWithdrawal + +import Spec.Util + +import Test.Tasty + +tests :: [TestTree] +tests = + [ testGroup + "effect" + [effectSucceedsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1] + ] diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs deleted file mode 100644 index f3e9396..0000000 --- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs +++ /dev/null @@ -1,257 +0,0 @@ -{- | -Module : Spec.Effect.TreasuryWithdrawalEffect -Maintainer : seungheon.ooh@gmail.com -Description: Sample based testing for Treasury Withdrawal Effect - -This module tests the Treasury Withdrawal Effect. --} -module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where - -import Plutarch.Api.V1 -import Plutarch.Builtin -import Plutarch.Evaluate -import Plutus.V1.Ledger.Api -import Plutus.V1.Ledger.Interval qualified as Interval -import Plutus.V1.Ledger.Value qualified as Value - -import Data.ByteString.Hash - -import Agora.AuthorityToken -import Agora.Effect.TreasuryWithdrawal - -import Spec.Util - -import Test.Tasty - --- receiverList :: TreasuryWithdrawalDatum --- receiverList = TreasuryWithdrawalDatum [(mempty, mempty)] - --- | A sample Currency Symbol. -currSymbol :: CurrencySymbol -currSymbol = CurrencySymbol "12312099" - -gtSymbol :: CurrencySymbol -gtSymbol = CurrencySymbol "abb" - -gtToken :: TokenName -gtToken = TokenName "hey" - --- | A sample 'PubKeyHash'. -signer :: PubKeyHash -signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" - --- | List of users who the effect will pay to. -users :: [Credential] -users = - PubKeyCredential . PubKeyHash . toBuiltin . sha2 - <$> [ "Orange" - , "Bottle" - , "Hello" - ] - --- | List of users who the effect will pay to. -treasuries :: [Credential] -treasuries = - ScriptCredential . ValidatorHash . toBuiltin . sha2 - <$> [ "1234" - , "qwer" - , "asdf" - ] - -_aa :: [Credential] -_aa = treasuries - --- | Datum for Treasury Withdrawal Effect Validator. -datum :: TreasuryWithdrawalDatum -datum = - TreasuryWithdrawalDatum - [ (users !! 0, Value.singleton "1234ab" "LQ" 1) - , (users !! 1, Value.singleton "1234ab" "LQ" 1) - , (users !! 2, Value.singleton "1234ab" "LQ" 1) - ] - --- | Effect validator instance. -validator :: Validator -validator = mkValidator $ treasuryWithdrawalValidator currSymbol - --- | 'TokenName' that represents the hash of the 'Stake' validator. -validatorHashTN :: TokenName -validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh - -scriptContext1 :: ScriptContext -scriptContext1 = - ScriptContext - { scriptContextTxInfo = - TxInfo - { txInfoInputs = - [ TxInInfo -- Initiator - (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) - TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST - , txOutDatumHash = Just (DatumHash "") - } - , TxInInfo -- Treasury 1 - (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) - TxOut - { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 10 - , txOutDatumHash = Just (DatumHash "") - } - , TxInInfo -- Treasury 2 - (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) - TxOut - { txOutAddress = Address (treasuries !! 1) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 10 - , txOutDatumHash = Just (DatumHash "") - } - ] - , txInfoOutputs = - [ TxOut - { txOutAddress = Address (users !! 0) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 1 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (users !! 1) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 1 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (users !! 2) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 1 - , txOutDatumHash = Nothing - } - , -- Send left overs to treasuries - TxOut - { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 7 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (treasuries !! 1) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 10 - , txOutDatumHash = Nothing - } - ] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = Value.singleton currSymbol validatorHashTN (-1) - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = [signer] - , txInfoData = [] - , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - } - , scriptContextPurpose = - Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) - } - -tests :: [TestTree] -tests = - [ testGroup - "effect" - [effectSucceedsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1] - ] - -_asdfa :: IO () -_asdfa = do - let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1) - case res of - Left e -> do - putStrLn $ show e <> " Traces: " <> show traces - Right _v -> - pure () - -_test :: IO () -_test = do - let (res, _budget, traces) = - evalScript $ - compile - ( authorityTokensValidIn # pconstant currSymbol - # ( pconstant $ - TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 1 - , txOutDatumHash = Just (DatumHash "") - } - ) - ) - case res of - Left e -> do - putStrLn $ show e <> " Traces: " <> show traces - Right _v -> - pure () - -_test2 :: IO () -_test2 = do - let (res, _budget, traces) = evalScript $ compile (singleAuthorityTokenBurned (pconstant currSymbol) (pconstantData tinfo) (pconstant mv)) - case res of - Left e -> do - putStrLn $ show e <> " Traces: " <> show traces - Right _v -> - putStrLn $ show res - where - mv = mempty -- Value.singleton currSymbol validatorHashTN (1) - tinfo = - TxInfo - { txInfoInputs = - [ TxInInfo -- Initiator - (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) - TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing - , txOutValue = mempty - , txOutDatumHash = Just (DatumHash "") - } - , TxInInfo -- Treasury 1 - (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) - TxOut - { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 10 - , txOutDatumHash = Just (DatumHash "") - } - , TxInInfo -- Treasury 2 - (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) - TxOut - { txOutAddress = Address (treasuries !! 1) Nothing - , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10 - , txOutDatumHash = Just (DatumHash "") - } - ] - , txInfoOutputs = - [ TxOut - { txOutAddress = Address (users !! 0) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 1 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (users !! 1) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 1 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (users !! 2) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 1 - , txOutDatumHash = Nothing - } - , -- Send left overs to treasuries - TxOut - { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 7 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (treasuries !! 1) Nothing - , txOutValue = Value.singleton gtSymbol gtToken 10 - , txOutDatumHash = Nothing - } - ] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = mempty -- Value.singleton currSymbol validatorHashTN (-1) - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = [signer] - , txInfoData = [] - , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - } diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs new file mode 100644 index 0000000..0f5d5a1 --- /dev/null +++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs @@ -0,0 +1,132 @@ +{- | +Module : Spec.Sample.Effect.TreasuryWithdrawalEffect +Maintainer : seungheon.ooh@gmail.com +Description: Sample based testing for Treasury Withdrawal Effect + +This module provides smaples for Treasury Withdrawal Effect tests. +-} +module Spec.Sample.Effect.TreasuryWithdrawal (datum, currSymbol, signer, validator, validatorHashTN, scriptContext1) where + +import Plutarch.Api.V1 +import Plutus.V1.Ledger.Api +import Plutus.V1.Ledger.Interval qualified as Interval +import Plutus.V1.Ledger.Value qualified as Value + +import Data.ByteString.Hash + +import Agora.Effect.TreasuryWithdrawal + +-- | A sample Currency Symbol. +currSymbol :: CurrencySymbol +currSymbol = CurrencySymbol "12312099" + +-- | A sample 'PubKeyHash'. +signer :: PubKeyHash +signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" + +-- | List of users who the effect will pay to. +users :: [Credential] +users = + PubKeyCredential . PubKeyHash . toBuiltin . sha2 + <$> [ "Orange" + , "Bottle" + , "Hello" + ] + +-- | List of users who the effect will pay to. +treasuries :: [Credential] +treasuries = + ScriptCredential . ValidatorHash . toBuiltin . sha2 + <$> [ "1234" + , "qwer" + , "asdf" + ] + +_aa :: [Credential] +_aa = treasuries + +-- | Datum for Treasury Withdrawal Effect Validator. +datum :: TreasuryWithdrawalDatum +datum = + TreasuryWithdrawalDatum + [ (users !! 0, Value.singleton "1234ab" "LQ" 1) + , (users !! 1, Value.singleton "1234ab" "LQ" 1) + , (users !! 2, Value.singleton "1234ab" "LQ" 1) + ] + +-- | Effect validator instance. +validator :: Validator +validator = mkValidator $ treasuryWithdrawalValidator currSymbol + +-- | 'TokenName' that represents the hash of the 'Stake' validator. +validatorHashTN :: TokenName +validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh + +scriptContext1 :: ScriptContext +scriptContext1 = + ScriptContext + { scriptContextTxInfo = + TxInfo + { txInfoInputs = + [ TxInInfo -- Initiator + (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST + , txOutDatumHash = Just (DatumHash "") + } + , TxInInfo -- Treasury 1 + (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) + TxOut + { txOutAddress = Address (treasuries !! 0) Nothing + , txOutValue = Value.singleton "1234ab" "LQ" 10 + , txOutDatumHash = Just (DatumHash "") + } + , TxInInfo -- Treasury 2 + (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) + TxOut + { txOutAddress = Address (treasuries !! 1) Nothing + , txOutValue = Value.singleton "1234ab" "LQ" 10 + , txOutDatumHash = Just (DatumHash "") + } + ] + , txInfoOutputs = + [ TxOut + { txOutAddress = Address (users !! 0) Nothing + , txOutValue = Value.singleton "1234ab" "LQ" 1 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (users !! 1) Nothing + , txOutValue = Value.singleton "1234ab" "LQ" 1 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (users !! 2) Nothing + , txOutValue = Value.singleton "1234ab" "LQ" 1 + , txOutDatumHash = Nothing + } + , -- Send left overs to treasuries + TxOut + { txOutAddress = Address (treasuries !! 0) Nothing + , txOutValue = Value.singleton "1234ab" "LQ" 7 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (treasuries !! 1) Nothing + , txOutValue = Value.singleton "1234ab" "LQ" 10 + , txOutDatumHash = Nothing + } + ] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = Value.singleton currSymbol validatorHashTN (-1) + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = [] + , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + } + , scriptContextPurpose = + Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + } diff --git a/agora.cabal b/agora.cabal index 3f47333..0ace2a8 100644 --- a/agora.cabal +++ b/agora.cabal @@ -152,7 +152,8 @@ test-suite agora-test main-is: Spec.hs hs-source-dirs: agora-test other-modules: - Spec.Effect.TreasuryWithdrawalEffect + Spec.Effect.TreasuryWithdrawal + Spec.Sample.Effect.TreasuryWithdrawal Spec.Model.MultiSig Spec.Sample.Stake Spec.Stake From 7f6ccc0dee15046ac642282d14ffec4d304caacf Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Thu, 21 Apr 2022 19:02:10 -0500 Subject: [PATCH 19/29] Yeah! Treasury Withdrawal Effect works with good tests --- agora-test/Spec.hs | 2 +- agora-test/Spec/Effect/TreasuryWithdrawal.hs | 111 ++++++++++- .../Spec/Sample/Effect/TreasuryWithdrawal.hs | 178 ++++++++++-------- 3 files changed, 203 insertions(+), 88 deletions(-) diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index 02394bc..40a7b7f 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -8,8 +8,8 @@ import Test.Tasty (defaultMain, testGroup) -------------------------------------------------------------------------------- -import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal import Spec.AuthorityToken qualified as AuthorityToken +import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal import Spec.Model.MultiSig qualified as MultiSig import Spec.Stake qualified as Stake diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs index 77ceb92..09bf1dc 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -5,20 +5,117 @@ Description: Sample based testing for Treasury Withdrawal Effect This module tests the Treasury Withdrawal Effect. -} -module Spec.Effect.TreasuryWithdrawal (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where +module Spec.Effect.TreasuryWithdrawal (tests) where -import Spec.Sample.Effect.TreasuryWithdrawal +import Spec.Sample.Effect.TreasuryWithdrawal ( + buildReceiversOutputFromDatum, + buildScriptContext, + currSymbol, + inputGAT, + inputTreasury, + outputTreasury, + outputUser, + users, + ) +import Agora.Effect.TreasuryWithdrawal ( + TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), + treasuryWithdrawalValidator, + ) -import Agora.Effect.TreasuryWithdrawal +import Plutus.V1.Ledger.Value qualified as Value +import Spec.Util (effectFailsWith, effectSucceedsWith) -import Spec.Util - -import Test.Tasty +import Test.Tasty (TestTree, testGroup) tests :: [TestTree] tests = [ testGroup "effect" - [effectSucceedsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1] + [ effectSucceedsWith + "Simple" + (treasuryWithdrawalValidator currSymbol) + datum1 + ( buildScriptContext + [ inputGAT + , inputTreasury 1 (asset1 10) + ] + $ outputTreasury 1 (asset1 7) : + buildReceiversOutputFromDatum datum1 + ) + , effectSucceedsWith + "Simple with multiple treasuries " + (treasuryWithdrawalValidator currSymbol) + datum1 + ( buildScriptContext + [ inputGAT + , inputTreasury 1 (asset1 10) + , inputTreasury 2 (asset1 100) + , inputTreasury 3 (asset1 500) + ] + $ [ outputTreasury 1 (asset1 7) + , outputTreasury 2 (asset1 100) + , outputTreasury 3 (asset1 500) + ] + ++ buildReceiversOutputFromDatum datum1 + ) + , effectSucceedsWith + "Mixed Assets" + (treasuryWithdrawalValidator currSymbol) + datum2 + ( buildScriptContext + [ inputGAT + , inputTreasury 1 (asset1 20) + , inputTreasury 2 (asset2 20) + ] + $ [ outputTreasury 1 (asset1 13) + , outputTreasury 2 (asset2 14) + ] + ++ buildReceiversOutputFromDatum datum2 + ) + , effectFailsWith + "Pay to uknown 3rd party" + (treasuryWithdrawalValidator currSymbol) + datum2 + ( buildScriptContext + [ inputGAT + , inputTreasury 1 (asset1 20) + , inputTreasury 2 (asset2 20) + ] + $ [ outputUser 100 (asset1 2) + , outputTreasury 1 (asset1 11) + , outputTreasury 2 (asset2 14) + ] + ++ buildReceiversOutputFromDatum datum2 + ) + , effectFailsWith + "Missing receiver" + (treasuryWithdrawalValidator currSymbol) + datum2 + ( buildScriptContext + [ inputGAT + , inputTreasury 1 (asset1 20) + , inputTreasury 2 (asset2 20) + ] + $ [ outputTreasury 1 (asset1 13) + , outputTreasury 2 (asset2 14) + ] + ++ drop 1 (buildReceiversOutputFromDatum datum2) + ) + ] ] + where + asset1 = Value.singleton "abbc12" "OrangeBottle" + asset2 = Value.singleton "abbc12" "19721121" + datum1 = + TreasuryWithdrawalDatum + [ (head users, asset1 1) + , (users !! 1, asset1 1) + , (users !! 2, asset1 1) + ] + datum2 = + TreasuryWithdrawalDatum + [ (head users, asset1 4 <> asset2 5) + , (users !! 1, asset1 2 <> asset2 1) + , (users !! 2, asset1 1) + ] diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs index 0f5d5a1..c228dc5 100644 --- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs @@ -5,16 +5,59 @@ Description: Sample based testing for Treasury Withdrawal Effect This module provides smaples for Treasury Withdrawal Effect tests. -} -module Spec.Sample.Effect.TreasuryWithdrawal (datum, currSymbol, signer, validator, validatorHashTN, scriptContext1) where +module Spec.Sample.Effect.TreasuryWithdrawal ( + inputTreasury, + inputGAT, + outputTreasury, + outputUser, + buildReceiversOutputFromDatum, + currSymbol, + users, + treasuries, + buildScriptContext, +) where -import Plutarch.Api.V1 -import Plutus.V1.Ledger.Api +import Plutarch.Api.V1 (mkValidator, validatorHash) +import Plutus.V1.Ledger.Api ( + Address (Address), + Credential (..), + CurrencySymbol (CurrencySymbol), + DatumHash (DatumHash), + PubKeyHash (PubKeyHash), + ScriptContext (..), + ScriptPurpose (Spending), + TokenName (TokenName), + TxInInfo (TxInInfo), + TxInfo ( + TxInfo, + txInfoDCert, + txInfoData, + txInfoFee, + txInfoId, + txInfoInputs, + txInfoMint, + txInfoOutputs, + txInfoSignatories, + txInfoValidRange, + txInfoWdrl + ), + TxOut (..), + TxOutRef (TxOutRef), + Validator, + ValidatorHash (ValidatorHash), + Value, + toBuiltin, + ) import Plutus.V1.Ledger.Interval qualified as Interval import Plutus.V1.Ledger.Value qualified as Value -import Data.ByteString.Hash +import Data.ByteString.Char8 qualified as C +import Data.ByteString.Hash (sha2) -import Agora.Effect.TreasuryWithdrawal +import Agora.Effect.TreasuryWithdrawal ( + TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), + treasuryWithdrawalValidator, + ) -- | A sample Currency Symbol. currSymbol :: CurrencySymbol @@ -26,33 +69,57 @@ signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" -- | List of users who the effect will pay to. users :: [Credential] -users = - PubKeyCredential . PubKeyHash . toBuiltin . sha2 - <$> [ "Orange" - , "Bottle" - , "Hello" - ] +users = PubKeyCredential . PubKeyHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer]) -- | List of users who the effect will pay to. treasuries :: [Credential] -treasuries = - ScriptCredential . ValidatorHash . toBuiltin . sha2 - <$> [ "1234" - , "qwer" - , "asdf" - ] +treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer]) -_aa :: [Credential] -_aa = treasuries +inputGAT :: TxInInfo +inputGAT = + TxInInfo -- Initiator + (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST + , txOutDatumHash = Just (DatumHash "") + } --- | Datum for Treasury Withdrawal Effect Validator. -datum :: TreasuryWithdrawalDatum -datum = - TreasuryWithdrawalDatum - [ (users !! 0, Value.singleton "1234ab" "LQ" 1) - , (users !! 1, Value.singleton "1234ab" "LQ" 1) - , (users !! 2, Value.singleton "1234ab" "LQ" 1) - ] +inputTreasury :: Int -> Value -> TxInInfo +inputTreasury indx val = + TxInInfo -- Initiator + (TxOutRef "" 1) + TxOut + { txOutAddress = Address (treasuries !! indx) Nothing + , txOutValue = val + , txOutDatumHash = Just (DatumHash "") + } + +outputTreasury :: Int -> Value -> TxOut +outputTreasury indx val = + TxOut + { txOutAddress = Address (treasuries !! indx) Nothing + , txOutValue = val + , txOutDatumHash = Nothing + } + +outputUser :: Int -> Value -> TxOut +outputUser indx val = + TxOut + { txOutAddress = Address (users !! indx) Nothing + , txOutValue = val + , txOutDatumHash = Nothing + } + +buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut] +buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs) = f <$> xs + where + f x = + TxOut + { txOutAddress = Address (fst x) Nothing + , txOutValue = snd x + , txOutDatumHash = Nothing + } -- | Effect validator instance. validator :: Validator @@ -62,62 +129,13 @@ validator = mkValidator $ treasuryWithdrawalValidator currSymbol validatorHashTN :: TokenName validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh -scriptContext1 :: ScriptContext -scriptContext1 = +buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext +buildScriptContext inputs outputs = ScriptContext { scriptContextTxInfo = TxInfo - { txInfoInputs = - [ TxInInfo -- Initiator - (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) - TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing - , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST - , txOutDatumHash = Just (DatumHash "") - } - , TxInInfo -- Treasury 1 - (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2) - TxOut - { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 10 - , txOutDatumHash = Just (DatumHash "") - } - , TxInInfo -- Treasury 2 - (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3) - TxOut - { txOutAddress = Address (treasuries !! 1) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 10 - , txOutDatumHash = Just (DatumHash "") - } - ] - , txInfoOutputs = - [ TxOut - { txOutAddress = Address (users !! 0) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 1 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (users !! 1) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 1 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (users !! 2) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 1 - , txOutDatumHash = Nothing - } - , -- Send left overs to treasuries - TxOut - { txOutAddress = Address (treasuries !! 0) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 7 - , txOutDatumHash = Nothing - } - , TxOut - { txOutAddress = Address (treasuries !! 1) Nothing - , txOutValue = Value.singleton "1234ab" "LQ" 10 - , txOutDatumHash = Nothing - } - ] + { txInfoInputs = inputs + , txInfoOutputs = outputs , txInfoFee = Value.singleton "" "" 2 , txInfoMint = Value.singleton currSymbol validatorHashTN (-1) , txInfoDCert = [] From 9866845f04135053be2e4da9ebc9c216d22bf7d9 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Thu, 21 Apr 2022 19:03:14 -0500 Subject: [PATCH 20/29] formatting --- agora.cabal | 4 ++-- flake.nix | 56 ++++++++++++++++++++++++++++++----------------------- 2 files changed, 34 insertions(+), 26 deletions(-) diff --git a/agora.cabal b/agora.cabal index 0ace2a8..baa6b5c 100644 --- a/agora.cabal +++ b/agora.cabal @@ -152,13 +152,13 @@ test-suite agora-test main-is: Spec.hs hs-source-dirs: agora-test other-modules: + Spec.AuthorityToken Spec.Effect.TreasuryWithdrawal - Spec.Sample.Effect.TreasuryWithdrawal Spec.Model.MultiSig + Spec.Sample.Effect.TreasuryWithdrawal Spec.Sample.Stake Spec.Stake Spec.Util - Spec.AuthorityToken build-depends: agora diff --git a/flake.nix b/flake.nix index c6522d6..3b1756a 100644 --- a/flake.nix +++ b/flake.nix @@ -50,8 +50,10 @@ projectFor = system: let pkgs = nixpkgsFor system; - in let pkgs' = nixpkgsFor' system; - in (nixpkgsFor system).haskell-nix.cabalProject' { + in + let pkgs' = nixpkgsFor' system; + in + (nixpkgsFor system).haskell-nix.cabalProject' { src = ./.; compiler-nix-name = ghcVersion; inherit (plutarch) cabalProjectLocal; @@ -120,16 +122,18 @@ inherit (plutarch.tools) fourmolu; }) fourmolu; - in pkgs.runCommand "format-check" { - nativeBuildInputs = [ - pkgs'.git - pkgs'.fd - pkgs'.haskellPackages.cabal-fmt - pkgs'.nixpkgs-fmt - fourmolu - pkgs'.haskell.packages."${ghcVersion}".hlint - ]; - } '' + in + pkgs.runCommand "format-check" + { + nativeBuildInputs = [ + pkgs'.git + pkgs'.fd + pkgs'.haskellPackages.cabal-fmt + pkgs'.nixpkgs-fmt + fourmolu + pkgs'.haskell.packages."${ghcVersion}".hlint + ]; + } '' export LC_CTYPE=C.UTF-8 export LC_ALL=C.UTF-8 export LANG=C.UTF-8 @@ -139,20 +143,23 @@ mkdir $out ''; - in { + in + { project = perSystem projectFor; flake = perSystem (system: (projectFor system).flake { }); packages = perSystem (system: self.flake.${system}.packages // { - haddock = let - agora-doc = self.flake.${system}.packages."agora:lib:agora".doc; - pkgs = nixpkgsFor system; - in pkgs.runCommand "haddock-merge" { } '' - cd ${self} - mkdir $out - cp -r ${agora-doc}/share/doc/* $out - ''; + haddock = + let + agora-doc = self.flake.${system}.packages."agora:lib:agora".doc; + pkgs = nixpkgsFor system; + in + pkgs.runCommand "haddock-merge" { } '' + cd ${self} + mkdir $out + cp -r ${agora-doc}/share/doc/* $out + ''; }); # Define what we want to test @@ -163,9 +170,10 @@ agora-test = self.flake.${system}.packages."agora:test:agora-test"; }); check = perSystem (system: - (nixpkgsFor system).runCommand "combined-test" { - checksss = builtins.attrValues self.checks.${system}; - } '' + (nixpkgsFor system).runCommand "combined-test" + { + checksss = builtins.attrValues self.checks.${system}; + } '' echo $checksss touch $out ''); From efb0776730709c69845224efd7a10d546fd432ed Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Fri, 22 Apr 2022 08:23:54 -0400 Subject: [PATCH 21/29] simple fixes suggested from review --- agora-test/Spec/Util.hs | 18 +++----------- agora/Agora/Effect/TreasuryWithdrawal.hs | 30 ++++++++++++------------ 2 files changed, 18 insertions(+), 30 deletions(-) diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 32fa1b1..069c7e3 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -142,13 +142,7 @@ effectSucceedsWith :: ScriptContext -> TestTree effectSucceedsWith tag eff datum scriptContext = - scriptSucceeds tag $ - compile - ( eff - # pforgetData (pconstantData datum) - # pforgetData (pconstantData ()) - # pconstant scriptContext - ) + validatorSucceedsWith tag eff datum () scriptContext -- | Check that a validator script fails, given a name and arguments. effectFailsWith :: @@ -161,14 +155,8 @@ effectFailsWith :: ScriptContext -> TestTree effectFailsWith tag eff datum scriptContext = - scriptFails tag $ - compile - ( eff - # pforgetData (pconstantData datum) - # pforgetData (pconstantData ()) - # pconstant scriptContext - ) - + validatorFailsWith tag eff datum () scriptContext + -- | Check that an arbitrary script doesn't error when evaluated, given a name. scriptSucceeds :: String -> Script -> TestTree scriptSucceeds name script = testCase name $ do diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index ddf3f32..d8a496a 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -67,18 +67,18 @@ deriving via (PConstant TreasuryWithdrawalDatum) {- | Withdraws given list of values to specific target addresses. -It can be evoked by burning GAT. The transaction should have correct -outputs to the users and any left overs should be paid back to the treasury. + It can be evoked by burning GAT. The transaction should have correct + outputs to the users and any left overs should be paid back to the treasury. -The validator does not accept any Redeemer as all "parameters" are provided -via encoded Datum. + The validator does not accept any Redeemer as all "parameters" are provided + via encoded Datum. -Note: -It should check... -1. Transaction outputs should contain all of what Datum specified -2. Left over assests should be redirected back to Treasury -It can be more flexiable over... -- The number of outputs themselves + Note: + It should check... + 1. Transaction outputs should contain all of what Datum specified + 2. Left over assests should be redirected back to Treasury + It can be more flexiable over... + - The number of outputs themselves -} treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ @@ -104,11 +104,11 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ pdata $ ptuple # txOut.address # txOut.value ) # txInfo.inputs - treasuryInputValues = - pfilter - # plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address) - # inputValues - treasuryCredentials = + treasuryInputValues <- plet $ + pfilter + # plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address) + # inputValues + let treasuryCredentials = pmap # plam ((pfield @"credential" #) . pfromData . (pfield @"_0" #) . pfromData) # treasuryInputValues From e91dcb7ce1dcbbb5cfec1440319143193b6c7bd5 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Fri, 22 Apr 2022 11:18:38 -0400 Subject: [PATCH 22/29] Now it checks specific treasury Emily's suggestion on the review --- agora-test/Spec/Effect/TreasuryWithdrawal.hs | 48 +++++++++++++++---- .../Spec/Sample/Effect/TreasuryWithdrawal.hs | 2 +- agora-test/Spec/Util.hs | 2 +- agora/Agora/Effect/TreasuryWithdrawal.hs | 46 +++++++++--------- 4 files changed, 64 insertions(+), 34 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs index 09bf1dc..9df0310 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -7,16 +7,16 @@ This module tests the Treasury Withdrawal Effect. -} module Spec.Effect.TreasuryWithdrawal (tests) where -import Spec.Sample.Effect.TreasuryWithdrawal ( - buildReceiversOutputFromDatum, - buildScriptContext, - currSymbol, - inputGAT, - inputTreasury, - outputTreasury, - outputUser, - users, - ) +import Spec.Sample.Effect.TreasuryWithdrawal + ( currSymbol, + users, + treasuries, + inputGAT, + inputTreasury, + outputTreasury, + outputUser, + buildReceiversOutputFromDatum, + buildScriptContext ) import Agora.Effect.TreasuryWithdrawal ( TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), @@ -102,6 +102,18 @@ tests = ] ++ drop 1 (buildReceiversOutputFromDatum datum2) ) + , effectFailsWith + "Unauthorized treasury" + (treasuryWithdrawalValidator currSymbol) + datum3 + ( buildScriptContext + [ inputGAT + , inputTreasury 999 (asset1 20) + ] + $ [ outputTreasury 999 (asset1 17) + ] + ++ buildReceiversOutputFromDatum datum3 + ) ] ] where @@ -112,10 +124,26 @@ tests = [ (head users, asset1 1) , (users !! 1, asset1 1) , (users !! 2, asset1 1) + ] $ + [ head treasuries + , treasuries !! 1 + , treasuries !! 2 ] datum2 = TreasuryWithdrawalDatum [ (head users, asset1 4 <> asset2 5) , (users !! 1, asset1 2 <> asset2 1) , (users !! 2, asset1 1) + ] $ + [ head treasuries + , treasuries !! 1 + , treasuries !! 2 ] + datum3 = + TreasuryWithdrawalDatum + [ (head users, asset1 1) + , (users !! 1, asset1 1) + , (users !! 2, asset1 1) + ] $ + [ treasuries !! 1 + ] diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs index c228dc5..6469953 100644 --- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs @@ -112,7 +112,7 @@ outputUser indx val = } buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut] -buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs) = f <$> xs +buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs where f x = TxOut diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 069c7e3..df20043 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -156,7 +156,7 @@ effectFailsWith :: TestTree effectFailsWith tag eff datum scriptContext = validatorFailsWith tag eff datum () scriptContext - + -- | Check that an arbitrary script doesn't error when evaluated, given a name. scriptSucceeds :: String -> Script -> TestTree scriptSucceeds name script = testCase name $ do diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index d8a496a..5468112 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -38,7 +38,11 @@ import Plutus.V1.Ledger.Credential (Credential) import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified -newtype TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]} +data TreasuryWithdrawalDatum = + TreasuryWithdrawalDatum + { receivers :: [(Credential, Value)] + , treasuries :: [Credential] + } deriving stock (Show, GHC.Generic) deriving anyclass (Generic) @@ -50,7 +54,9 @@ newtype PTreasuryWithdrawalDatum (s :: S) ( Term s ( PDataRecord - '["receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))] + '[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue)) + , "treasuries" ':= PBuiltinList (PAsData PCredential) + ] ) ) deriving stock (GHC.Generic) @@ -83,17 +89,17 @@ deriving via treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do - receivers <- plet $ pfromData $ pfield @"receivers" # datum' + datum <- pletFields @'["receivers", "treasuries"] datum' txInfo <- pletFields @'["outputs", "inputs"] txInfo' PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo' effInput <- pletFields @'["address", "value"] $ txOut let outputValues = pmap # plam - ( \(pfromData -> out') -> P.do - out <- pletFields @'["address", "value"] $ out' - cred <- pletFields @'["credential"] $ pfromData out.address - pdata $ ptuple # cred.credential # out.value + ( \(pfromData -> txOut') -> P.do + txOut <- pletFields @'["address", "value"] $ txOut' + let cred = pfield @"credential" # pfromData txOut.address + pdata $ ptuple # cred # txOut.value ) # txInfo.outputs inputValues = @@ -101,23 +107,19 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ # plam ( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do txOut <- pletFields @'["address", "value"] $ txOut' - pdata $ ptuple # txOut.address # txOut.value + let cred = pfield @"credential" # pfromData txOut.address + pdata $ ptuple # cred # txOut.value ) # txInfo.inputs - treasuryInputValues <- plet $ - pfilter - # plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address) - # inputValues - let treasuryCredentials = - pmap - # plam ((pfield @"credential" #) . pfromData . (pfield @"_0" #) . pfromData) - # treasuryInputValues - treasuryOutputValues = + treasuryInputValues <- + plet $ + pfilter + # plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) + # inputValues + let treasuryOutputValues = pfilter # plam - ( \((pfield @"_0" #) . pfromData -> addr) -> P.do - pelem # addr # treasuryCredentials - ) + ( \((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) # outputValues treasuryInputValuesSum = pfoldr @@ -133,10 +135,10 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ pfoldr # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) # pconstant (mempty :: Value) - # receivers + # datum.receivers outputContentMatchesRecivers = pall # plam (\out -> pelem # out # outputValues) - #$ receivers + #$ datum.receivers excessShouldBePaidToInputs = pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum shouldNotPayToEffect = From 05a6808767b20fa306738f69456526719d776d47 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Fri, 22 Apr 2022 19:01:36 -0500 Subject: [PATCH 23/29] stricter constraints over inputs It will only allow treasuries given in the datum as input. It prevents unwanted change in the system. --- agora-test/Spec/Effect/TreasuryWithdrawal.hs | 52 ++++++++++++------- .../Spec/Sample/Effect/TreasuryWithdrawal.hs | 15 +++++- agora-test/Spec/Util.hs | 6 +-- agora/Agora/Effect/TreasuryWithdrawal.hs | 36 ++++++------- 4 files changed, 66 insertions(+), 43 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs index 9df0310..67ae244 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -7,16 +7,18 @@ This module tests the Treasury Withdrawal Effect. -} module Spec.Effect.TreasuryWithdrawal (tests) where -import Spec.Sample.Effect.TreasuryWithdrawal - ( currSymbol, - users, - treasuries, - inputGAT, - inputTreasury, - outputTreasury, - outputUser, - buildReceiversOutputFromDatum, - buildScriptContext ) +import Spec.Sample.Effect.TreasuryWithdrawal ( + buildReceiversOutputFromDatum, + buildScriptContext, + currSymbol, + inputGAT, + inputTreasury, + inputUser, + outputTreasury, + outputUser, + treasuries, + users, + ) import Agora.Effect.TreasuryWithdrawal ( TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), @@ -110,10 +112,23 @@ tests = [ inputGAT , inputTreasury 999 (asset1 20) ] - $ [ outputTreasury 999 (asset1 17) + $ outputTreasury 999 (asset1 17) : + buildReceiversOutputFromDatum datum3 + ) + , effectFailsWith + "Prevent transactions besides the withdrawal" + (treasuryWithdrawalValidator currSymbol) + datum3 + ( buildScriptContext + [ inputGAT + , inputTreasury 1 (asset1 20) + , inputUser 99 (asset2 100) + ] + $ [ outputTreasury 1 (asset1 17) + , outputUser 100 (asset2 100) ] ++ buildReceiversOutputFromDatum datum3 - ) + ) ] ] where @@ -124,17 +139,17 @@ tests = [ (head users, asset1 1) , (users !! 1, asset1 1) , (users !! 2, asset1 1) - ] $ - [ head treasuries - , treasuries !! 1 + ] + [ treasuries !! 1 , treasuries !! 2 + , treasuries !! 3 ] datum2 = TreasuryWithdrawalDatum [ (head users, asset1 4 <> asset2 5) , (users !! 1, asset1 2 <> asset2 1) , (users !! 2, asset1 1) - ] $ + ] [ head treasuries , treasuries !! 1 , treasuries !! 2 @@ -144,6 +159,5 @@ tests = [ (head users, asset1 1) , (users !! 1, asset1 1) , (users !! 2, asset1 1) - ] $ - [ treasuries !! 1 - ] + ] + [treasuries !! 1] diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs index 6469953..37aa634 100644 --- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs @@ -7,6 +7,7 @@ This module provides smaples for Treasury Withdrawal Effect tests. -} module Spec.Sample.Effect.TreasuryWithdrawal ( inputTreasury, + inputUser, inputGAT, outputTreasury, outputUser, @@ -77,7 +78,7 @@ treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show inputGAT :: TxInInfo inputGAT = - TxInInfo -- Initiator + TxInInfo (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing @@ -87,7 +88,7 @@ inputGAT = inputTreasury :: Int -> Value -> TxInInfo inputTreasury indx val = - TxInInfo -- Initiator + TxInInfo (TxOutRef "" 1) TxOut { txOutAddress = Address (treasuries !! indx) Nothing @@ -95,6 +96,16 @@ inputTreasury indx val = , txOutDatumHash = Just (DatumHash "") } +inputUser :: Int -> Value -> TxInInfo +inputUser indx val = + TxInInfo + (TxOutRef "" 1) + TxOut + { txOutAddress = Address (users !! indx) Nothing + , txOutValue = val + , txOutDatumHash = Just (DatumHash "") + } + outputTreasury :: Int -> Value -> TxOut outputTreasury indx val = TxOut diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index df20043..f36b3ba 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -141,8 +141,7 @@ effectSucceedsWith :: PLifted datum -> ScriptContext -> TestTree -effectSucceedsWith tag eff datum scriptContext = - validatorSucceedsWith tag eff datum () scriptContext +effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum () -- | Check that a validator script fails, given a name and arguments. effectFailsWith :: @@ -154,8 +153,7 @@ effectFailsWith :: PLifted datum -> ScriptContext -> TestTree -effectFailsWith tag eff datum scriptContext = - validatorFailsWith tag eff datum () scriptContext +effectFailsWith tag eff datum = validatorFailsWith tag eff datum () -- | Check that an arbitrary script doesn't error when evaluated, given a name. scriptSucceeds :: String -> Script -> TestTree diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 5468112..29a269d 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -38,11 +38,10 @@ import Plutus.V1.Ledger.Credential (Credential) import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified -data TreasuryWithdrawalDatum = - TreasuryWithdrawalDatum - { receivers :: [(Credential, Value)] - , treasuries :: [Credential] - } +data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum + { receivers :: [(Credential, Value)] + , treasuries :: [Credential] + } deriving stock (Show, GHC.Generic) deriving anyclass (Generic) @@ -119,23 +118,15 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ let treasuryOutputValues = pfilter # plam - ( \((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) + (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) # outputValues - treasuryInputValuesSum = + sumValues = pfoldr # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) # pconstant (mempty :: Value) - # treasuryInputValues - treasuryOutputValuesSum = - pfoldr - # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) - # pconstant (mempty :: Value) - # treasuryOutputValues - receiverValuesSum = - pfoldr - # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) - # pconstant (mempty :: Value) - # datum.receivers + treasuryInputValuesSum = sumValues # treasuryInputValues + treasuryOutputValuesSum = sumValues # treasuryOutputValues + receiverValuesSum = sumValues # datum.receivers outputContentMatchesRecivers = pall # plam (\out -> pelem # out # outputValues) #$ datum.receivers @@ -148,8 +139,17 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ effInput.address #== pfield @"address" # pfromData x ) # pfromData txInfo.outputs + inputsAreOnlyTreasuries = + pall + # plam + ( \((pfield @"_0" #) . pfromData -> cred) -> + cred #== pfield @"credential" # effInput.address + #|| pelem # cred # datum.treasuries + ) + # inputValues passert "Transaction output does not match receivers" outputContentMatchesRecivers passert "Transaction should not pay to effects" shouldNotPayToEffect + passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs popaque $ pconstant () From 75f5e83bcfca6c999654e58cb177f9e2b4c9f1d2 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Fri, 22 Apr 2022 20:09:23 -0500 Subject: [PATCH 24/29] optimized validator --- agora/Agora/Effect/TreasuryWithdrawal.hs | 57 +++++++++++------------- 1 file changed, 27 insertions(+), 30 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 29a269d..3f980c4 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -92,41 +92,38 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ txInfo <- pletFields @'["outputs", "inputs"] txInfo' PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo' effInput <- pletFields @'["address", "value"] $ txOut - let outputValues = - pmap - # plam - ( \(pfromData -> txOut') -> P.do - txOut <- pletFields @'["address", "value"] $ txOut' - let cred = pfield @"credential" # pfromData txOut.address - pdata $ ptuple # cred # txOut.value - ) - # txInfo.outputs - inputValues = - pmap - # plam - ( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do - txOut <- pletFields @'["address", "value"] $ txOut' - let cred = pfield @"credential" # pfromData txOut.address - pdata $ ptuple # cred # txOut.value - ) - # txInfo.inputs - treasuryInputValues <- + outputValues <- plet $ - pfilter - # plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) - # inputValues - let treasuryOutputValues = + pmap + # plam + ( \(pfromData -> txOut') -> P.do + txOut <- pletFields @'["address", "value"] $ txOut' + let cred = pfield @"credential" # pfromData txOut.address + pdata $ ptuple # cred # txOut.value + ) + # txInfo.outputs + inputValues <- + plet $ + pmap + # plam + ( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do + txOut <- pletFields @'["address", "value"] $ txOut' + let cred = pfield @"credential" # pfromData txOut.address + pdata $ ptuple # cred # txOut.value + ) + # txInfo.inputs + let ofTreasury = pfilter - # plam - (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) - # outputValues + # plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) sumValues = pfoldr # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) # pconstant (mempty :: Value) - treasuryInputValuesSum = sumValues # treasuryInputValues - treasuryOutputValuesSum = sumValues # treasuryOutputValues + treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues + treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues receiverValuesSum = sumValues # datum.receivers + + -- Constraints outputContentMatchesRecivers = pall # plam (\out -> pelem # out # outputValues) #$ datum.receivers @@ -148,8 +145,8 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ ) # inputValues - passert "Transaction output does not match receivers" outputContentMatchesRecivers passert "Transaction should not pay to effects" shouldNotPayToEffect - passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries + passert "Transaction output does not match receivers" outputContentMatchesRecivers passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs + passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries popaque $ pconstant () From 35b862153c3407422ab68fde5375bc1cc4e1a4d5 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 25 Apr 2022 08:46:58 -0400 Subject: [PATCH 25/29] take collaterals into account --- agora-test/Spec/Effect/TreasuryWithdrawal.hs | 8 +++++++ .../Spec/Sample/Effect/TreasuryWithdrawal.hs | 11 ++++++++++ agora/Agora/Effect/TreasuryWithdrawal.hs | 21 ++++++++++++------- 3 files changed, 32 insertions(+), 8 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs index 67ae244..7deb7da 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -14,6 +14,7 @@ import Spec.Sample.Effect.TreasuryWithdrawal ( inputGAT, inputTreasury, inputUser, + inputCollateral, outputTreasury, outputUser, treasuries, @@ -40,6 +41,7 @@ tests = datum1 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 1 (asset1 10) ] $ outputTreasury 1 (asset1 7) : @@ -51,6 +53,7 @@ tests = datum1 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 1 (asset1 10) , inputTreasury 2 (asset1 100) , inputTreasury 3 (asset1 500) @@ -67,6 +70,7 @@ tests = datum2 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 1 (asset1 20) , inputTreasury 2 (asset2 20) ] @@ -81,6 +85,7 @@ tests = datum2 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 1 (asset1 20) , inputTreasury 2 (asset2 20) ] @@ -96,6 +101,7 @@ tests = datum2 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 1 (asset1 20) , inputTreasury 2 (asset2 20) ] @@ -110,6 +116,7 @@ tests = datum3 ( buildScriptContext [ inputGAT + , inputCollateral 10 , inputTreasury 999 (asset1 20) ] $ outputTreasury 999 (asset1 17) : @@ -122,6 +129,7 @@ tests = ( buildScriptContext [ inputGAT , inputTreasury 1 (asset1 20) + , inputTreasury 999 (asset1 20) , inputUser 99 (asset2 100) ] $ [ outputTreasury 1 (asset1 17) diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs index 37aa634..78e89e2 100644 --- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs @@ -9,6 +9,7 @@ module Spec.Sample.Effect.TreasuryWithdrawal ( inputTreasury, inputUser, inputGAT, + inputCollateral, outputTreasury, outputUser, buildReceiversOutputFromDatum, @@ -106,6 +107,16 @@ inputUser indx val = , txOutDatumHash = Just (DatumHash "") } +inputCollateral :: Int -> TxInInfo +inputCollateral indx = + TxInInfo -- Initiator + (TxOutRef "" 1) + TxOut + { txOutAddress = Address (users !! indx) Nothing + , txOutValue = Value.singleton "" "" 2000000 + , txOutDatumHash = Just (DatumHash "") + } + outputTreasury :: Int -> Value -> TxOut outputTreasury indx val = TxOut diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 3f980c4..ff9d3ec 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -20,12 +20,12 @@ import Agora.Effect (makeEffect) import Agora.Utils (findTxOutByTxOutRef, paddValue, passert) import Plutarch (popaque) import Plutarch.Api.V1 ( - PCredential, - PTuple, - PValidator, - PValue, ptuple, - ) + PValidator, + PTuple, + PValue, + PCredential(..) + ) import Plutarch.DataRepr ( DerivePConstantViaData (..), @@ -34,7 +34,7 @@ import Plutarch.DataRepr ( ) import Plutarch.Lift (PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P -import Plutus.V1.Ledger.Credential (Credential) +import Plutus.V1.Ledger.Credential ( Credential ) import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified @@ -122,6 +122,10 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues receiverValuesSum = sumValues # datum.receivers + isCollateral = plam $ \cred -> P.do + pmatch cred $ \case + PPubKeyCredential _ -> pcon PTrue + PScriptCredential _ -> pcon PFalse -- Constraints outputContentMatchesRecivers = @@ -136,17 +140,18 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ effInput.address #== pfield @"address" # pfromData x ) # pfromData txInfo.outputs - inputsAreOnlyTreasuries = + inputsAreOnlyTreasuriesOrCollateral = pall # plam ( \((pfield @"_0" #) . pfromData -> cred) -> cred #== pfield @"credential" # effInput.address #|| pelem # cred # datum.treasuries + #|| isCollateral # pfromData cred ) # inputValues passert "Transaction should not pay to effects" shouldNotPayToEffect passert "Transaction output does not match receivers" outputContentMatchesRecivers passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs - passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries + passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuriesOrCollateral popaque $ pconstant () From 8315f410e8e9b2d7122ff116bda7f1df4701dee9 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 25 Apr 2022 08:48:22 -0400 Subject: [PATCH 26/29] format --- agora-test/Spec/Effect/TreasuryWithdrawal.hs | 2 +- agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs | 2 +- agora/Agora/Effect/TreasuryWithdrawal.hs | 12 ++++++------ 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs index 7deb7da..db0aed6 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -11,10 +11,10 @@ import Spec.Sample.Effect.TreasuryWithdrawal ( buildReceiversOutputFromDatum, buildScriptContext, currSymbol, + inputCollateral, inputGAT, inputTreasury, inputUser, - inputCollateral, outputTreasury, outputUser, treasuries, diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs index 78e89e2..81709fe 100644 --- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs @@ -115,7 +115,7 @@ inputCollateral indx = { txOutAddress = Address (users !! indx) Nothing , txOutValue = Value.singleton "" "" 2000000 , txOutDatumHash = Just (DatumHash "") - } + } outputTreasury :: Int -> Value -> TxOut outputTreasury indx val = diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index ff9d3ec..0fbe118 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -20,12 +20,12 @@ import Agora.Effect (makeEffect) import Agora.Utils (findTxOutByTxOutRef, paddValue, passert) import Plutarch (popaque) import Plutarch.Api.V1 ( - ptuple, - PValidator, + PCredential (..), PTuple, + PValidator, PValue, - PCredential(..) - ) + ptuple, + ) import Plutarch.DataRepr ( DerivePConstantViaData (..), @@ -34,7 +34,7 @@ import Plutarch.DataRepr ( ) import Plutarch.Lift (PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P -import Plutus.V1.Ledger.Credential ( Credential ) +import Plutus.V1.Ledger.Credential (Credential) import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified @@ -125,7 +125,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ isCollateral = plam $ \cred -> P.do pmatch cred $ \case PPubKeyCredential _ -> pcon PTrue - PScriptCredential _ -> pcon PFalse + PScriptCredential _ -> pcon PFalse -- Constraints outputContentMatchesRecivers = From 349b4454ab26f8f0b0c7ffd6b1c37dde0171eadd Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 25 Apr 2022 09:04:07 -0400 Subject: [PATCH 27/29] rename! --- agora/Agora/Effect/TreasuryWithdrawal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 0fbe118..abf23bf 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -122,7 +122,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues receiverValuesSum = sumValues # datum.receivers - isCollateral = plam $ \cred -> P.do + isPubkey = plam $ \cred -> P.do pmatch cred $ \case PPubKeyCredential _ -> pcon PTrue PScriptCredential _ -> pcon PFalse @@ -146,7 +146,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ ( \((pfield @"_0" #) . pfromData -> cred) -> cred #== pfield @"credential" # effInput.address #|| pelem # cred # datum.treasuries - #|| isCollateral # pfromData cred + #|| isPubkey # pfromData cred ) # inputValues From cbff7324d8673b95aa79a6d97f69071d6d48df43 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 25 Apr 2022 11:16:17 -0400 Subject: [PATCH 28/29] PTryFrom for Treasury Withdrawal Effect! --- agora/Agora/Effect/TreasuryWithdrawal.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index abf23bf..f39ad92 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -15,10 +15,12 @@ module Agora.Effect.TreasuryWithdrawal ( import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) +import Control.Applicative (Const) import Agora.Effect (makeEffect) import Agora.Utils (findTxOutByTxOutRef, paddValue, passert) import Plutarch (popaque) +import Plutarch.Internal (punsafeCoerce) import Plutarch.Api.V1 ( PCredential (..), PTuple, @@ -32,6 +34,7 @@ import Plutarch.DataRepr ( PDataFields, PIsDataReprInstances (..), ) +import Plutarch.TryFrom ( PTryFrom(..) ) import Plutarch.Lift (PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P import Plutus.V1.Ledger.Credential (Credential) @@ -71,6 +74,13 @@ deriving via instance (PConstant TreasuryWithdrawalDatum) +instance PTryFrom PData PTreasuryWithdrawalDatum where + type PTryFromExcess PData PTreasuryWithdrawalDatum = Const () + ptryFrom' opq cont = + -- this will need to not use punsafeCoerce... + cont (punsafeCoerce opq, ()) + + {- | Withdraws given list of values to specific target addresses. It can be evoked by burning GAT. The transaction should have correct outputs to the users and any left overs should be paid back to the treasury. From e262395556b75a1878328308409b11fa1d844b70 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 25 Apr 2022 11:17:15 -0400 Subject: [PATCH 29/29] format --- agora.cabal | 2 +- agora/Agora/Effect/TreasuryWithdrawal.hs | 7 +++---- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/agora.cabal b/agora.cabal index e73243f..c1729d0 100644 --- a/agora.cabal +++ b/agora.cabal @@ -123,8 +123,8 @@ library exposed-modules: Agora.AuthorityToken Agora.Effect - Agora.Effect.TreasuryWithdrawal Agora.Effect.NoOp + Agora.Effect.TreasuryWithdrawal Agora.Governor Agora.MultiSig Agora.Proposal diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index f39ad92..209877f 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -13,14 +13,13 @@ module Agora.Effect.TreasuryWithdrawal ( treasuryWithdrawalValidator, ) where +import Control.Applicative (Const) import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) -import Control.Applicative (Const) import Agora.Effect (makeEffect) import Agora.Utils (findTxOutByTxOutRef, paddValue, passert) import Plutarch (popaque) -import Plutarch.Internal (punsafeCoerce) import Plutarch.Api.V1 ( PCredential (..), PTuple, @@ -28,15 +27,16 @@ import Plutarch.Api.V1 ( PValue, ptuple, ) +import Plutarch.Internal (punsafeCoerce) import Plutarch.DataRepr ( DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..), ) -import Plutarch.TryFrom ( PTryFrom(..) ) import Plutarch.Lift (PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P +import Plutarch.TryFrom (PTryFrom (..)) import Plutus.V1.Ledger.Credential (Credential) import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified @@ -80,7 +80,6 @@ instance PTryFrom PData PTreasuryWithdrawalDatum where -- this will need to not use punsafeCoerce... cont (punsafeCoerce opq, ()) - {- | Withdraws given list of values to specific target addresses. It can be evoked by burning GAT. The transaction should have correct outputs to the users and any left overs should be paid back to the treasury.