From 37cf3ab88eb797d7eaeed19c7acda63371aa7515 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 76d145469290efff69f1797736583091b01a22da 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 b3b057cfb84135699aadc95da13bfd01da135e79 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 e3bf41af29ada78adb87dc54207dab56931ec906 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 7cae728860150fc1c8966075c7cd513e453f02a5 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 e08efd173b7416658eedd2db1161f9d81ec00c9b 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 4cd6e6f534509afc4e0958d94de8f0a80cabefd3 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 0b90e041c6d0a74c8c35f82db30aca8d48ecedb2 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 c9adf02614a88598beb6f61038112b685f1155c9 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 4328fa1ba9abc9d5c017b025f68cdd6d43ef21cd 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 c90cd94c59f32dd04a8adfdd833c297c440d22c9 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 aa4d198e9f7ff14add27c3f9fabeba50ea797c28 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 774702f255db7bd84efbc4a87ca5ac696a1537e6 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 c96ac583db7ac352d212bea331f01571775691bc 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 54e95364ea7dd1b990c38e8be8dd1faae571a408 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 6c02b94e16536bb2ce59c7ff6866d019c77ca011 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 bed2f37c2f9d8a30fac9efc5334a031a375f07c6 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 0d99e365412901a16d2a08be82d6e43af4cb1978 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 df8baf4f4f9ec74043b479839c02efc90b389e5f 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 11a10bd4ec143138e05ce6f25ac635519fdced81 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 17817ba68b1754d38b94f68baadac423320cea1d 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 ec46273b5bed48f39a31f8f3b2ebfade4bf17f51 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 bf13fd926ed963c24e09a067afa630a5d14fc4f5 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 5c6376415975e0b5e12c29b2bb8d27a93eef41ef 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 5a688262c3fff8db7a306f0d9b081a879a782be9 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 5ff09ee207a0de1f0e9297a96c73fbeccc3ee24e 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 d5720e05bfebc546fbf083131f1e7ec501f5b536 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 e08f294adc96f81298fa9544fae9de3866becf88 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 3ec470a9edad01acb513e1fb9f58ad6ae0e37855 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.