From 80496430ab05ea9061b29ddd4376ec067da731b5 Mon Sep 17 00:00:00 2001 From: fanghr Date: Wed, 18 May 2022 00:17:58 +0800 Subject: [PATCH 01/14] add uitls to update a `PMap` on-chain --- agora/Agora/Utils.hs | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 558bc13..c594200 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -40,6 +40,8 @@ module Agora.Utils ( pmsortBy, pmsort, pnubSort, + pupdate, + pmapMaybe, -- * Functions which should (probably) not be upstreamed anyOutput, @@ -286,6 +288,42 @@ pmapUnionWith = phoistAcyclic $ # ys pure $ pcon (PMap $ pconcat # ls # rs) +-- | A special version of `pmap` which allows list elements to be thrown out. +pmapMaybe :: forall s a list. (PIsListLike list a) => Term s ((a :--> PMaybe a) :--> list a :--> list a) +pmapMaybe = phoistAcyclic $ + pfix #$ plam $ \self f l -> pif (pnull # l) pnil $ + unTermCont $ do + x <- tclet $ phead # l + xs <- tclet $ ptail # l + + pure $ + pmatch (f # x) $ \case + PJust ux -> pcons # ux #$ self # f # xs + _ -> self # f # xs + +-- | / O(n) /. Update the value at a given key in a `PMap`, have the same functionalities as 'Data.Map.update'. +pupdate :: forall s k v. (PIsData k, PIsData v) => Term s ((v :--> PMaybe v) :--> k :--> PMap k v :--> PMap k v) +pupdate = phoistAcyclic $ + plam $ \f (pdata -> tk) (pto -> (ps :: Term _ (PBuiltinList _))) -> + pcon $ + PMap $ + pmapMaybe + # plam + ( \kv -> + let k = pfstBuiltin # kv + v = pfromData $ psndBuiltin # kv + in pif + (k #== tk) + -- 'PBuiltinPair' doesn't have 'PFunctor', so: + ( pmatch (f # v) $ + \case + PJust uv -> pcon $ PJust $ ppairDataBuiltin # k # pdata uv + _ -> pcon PNothing + ) + (pcon $ PJust kv) + ) + # ps + -- | Add two 'PValue's together. paddValue :: forall s. Term s (PValue :--> PValue :--> PValue) paddValue = phoistAcyclic $ From 11743e0aace5c5e5a5545075cb0fdbf1b2e8661e Mon Sep 17 00:00:00 2001 From: fanghr Date: Wed, 18 May 2022 16:49:55 +0800 Subject: [PATCH 02/14] `PEq` instances for a bunch of on-chain structures --- agora/Agora/Proposal.hs | 4 ++-- agora/Agora/Stake.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 794ea0a..3c82fe3 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -303,7 +303,7 @@ data PProposalStatus (s :: S) deriving anyclass (Generic) deriving anyclass (PIsDataRepr) deriving - (PlutusType, PIsData) + (PlutusType, PIsData, PEq) via PIsDataReprInstances PProposalStatus instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus @@ -361,7 +361,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum deriving anyclass (Generic) deriving anyclass (PIsDataRepr) deriving - (PlutusType, PIsData, PDataFields) + (PlutusType, PIsData, PDataFields, PEq) via (PIsDataReprInstances PProposalDatum) -- TODO: Derive this. diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index a33f632..e62e20a 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -191,7 +191,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum deriving anyclass (Generic) deriving anyclass (PIsDataRepr) deriving - (PlutusType, PIsData, PDataFields) + (PlutusType, PIsData, PDataFields, PEq) via (PIsDataReprInstances PStakeDatum) instance PTryFrom PData (PAsData PStakeDatum) where @@ -241,7 +241,7 @@ newtype PProposalLock (s :: S) = PProposalLock deriving anyclass (Generic) deriving anyclass (PIsDataRepr) deriving - (PlutusType, PIsData, PDataFields) + (PlutusType, PIsData, PDataFields, PEq) via (PIsDataReprInstances PProposalLock) deriving via From cf51d47a0d7d46cf3c2a4b5ba974fe20906f57fb Mon Sep 17 00:00:00 2001 From: fanghr Date: Wed, 18 May 2022 17:14:04 +0800 Subject: [PATCH 03/14] validation logic for voting --- agora/Agora/Proposal/Scripts.hs | 134 +++++++++++++++++++++++++++++++- 1 file changed, 131 insertions(+), 3 deletions(-) diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index ce2dcbe..f09e90b 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -13,18 +13,24 @@ module Agora.Proposal.Scripts ( import Agora.Proposal ( PProposalDatum (PProposalDatum), PProposalRedeemer (..), + PProposalVotes (PProposalVotes), Proposal (governorSTAssetClass, stakeSTAssetClass), + ProposalStatus (VotingReady), ) import Agora.Record (mkRecordConstr, (.&), (.=)) -import Agora.Stake (findStakeOwnedBy) +import Agora.Stake (PProposalLock (..), PStakeDatum (..), findStakeOwnedBy) import Agora.Utils ( anyOutput, findTxOutByTxOutRef, getMintingPolicySymbol, + mustBePJust, + mustFindDatum', + pisJust, pisUniqBy, psymbolValueOf, ptokenSpent, ptxSignedBy, + pupdate, pvalueSpent, tcassert, tclet, @@ -39,6 +45,8 @@ import Plutarch.Api.V1 ( PValidator, ) import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) +import Plutarch.Map.Extra (plookup) +import Plutarch.SafeMoney (puntag) import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) {- | Policy for Proposals. @@ -123,7 +131,7 @@ proposalValidator proposal = ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx' txInfo <- tclet $ pfromData ctx.txInfo PTxInfo txInfo' <- tcmatch txInfo - txInfoF <- tcont $ pletFields @'["inputs", "mint", "datums", "signatories"] txInfo' + txInfoF <- tcont $ pletFields @'["inputs", "outputs", "mint", "datums", "signatories"] txInfo' PSpending ((pfield @"_0" #) -> txOutRef) <- tcmatch $ pfromData ctx.purpose PJust txOut <- tcmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs @@ -165,7 +173,127 @@ proposalValidator proposal = pure $ pmatch proposalRedeemer $ \case - PVote _r -> popaque (pconstant ()) + PVote r -> unTermCont $ do + -- TODO: do we have to check the timing here? + tcassert "Input proposal must be in VotingReady state" $ + proposalF.status #== pconstant VotingReady + + -- Ensure the transaction is voting to a valid 'ResultTag'(outcome). + PProposalVotes voteMap <- tcmatch proposalF.votes + voteFor <- tclet $ pfromData $ pfield @"resultTag" # r + + tcassert "Invalid vote option" $ + pisJust #$ plookup # voteFor # voteMap + + -- Find the input stake, the amount of new votes should be the 'stakedAmount'. + let stakeInput = + pfield @"resolved" + #$ mustBePJust + # "Stake input not found" + #$ pfind + # plam + ( \(pfromData . (pfield @"value" #) . (pfield @"resolved" #) -> value) -> + passetClassValueOf # value # stakeSTAssetClass #== 1 + ) + # pfromData txInfoF.inputs + + stakeIn :: Term _ PStakeDatum + stakeIn = mustFindDatum' # (pfield @"datumHash" # stakeInput) # txInfoF.datums + + stakeInF <- tcont $ pletFields @'["stakedAmount", "lockedBy", "owner"] stakeIn + + -- Ensure that no lock with the current proposal id has been put on the stake. + tcassert "Cannot vote on the a proposal using the same stake twice" $ + pnot #$ pany + # plam + ( \((pfield @"proposalTag" #) . pfromData -> pid) -> + pid #== proposalF.proposalId + ) + # pfromData stakeInF.lockedBy + + -- TODO: maybe we can move this outside of the pmatch block. + -- Filter out own output with own address and PST. + ownOutput <- + tclet $ + mustBePJust # "Own output not found" #$ pfind + # plam + ( \input -> unTermCont $ do + inputF <- tcont $ pletFields @'["address", "value"] input + pure $ + inputF.address #== ownAddress + #&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1 + ) + # pfromData txInfoF.outputs + + ownOutputF <- tcont $ pletFields @'["datumHash", "value"] ownOutput + + -- TODO: is this really necessary? + tcassert "Own output value should be correct" $ ownOutputF.value #== pdata txOutF.value + + let proposalOut :: Term _ PProposalDatum + proposalOut = mustFindDatum' # (pfield @"datumHash" # ownOutput) # txInfoF.datums + + let -- Update the vote counter of the proposal, and leave other stuff as is. + expectedNewVotes = pmatch (pfromData proposalF.votes) $ \(PProposalVotes m) -> + pcon $ + PProposalVotes $ + pupdate + # plam + ( \votes -> + pcon $ PJust $ votes + (puntag stakeInF.stakedAmount) + ) + # voteFor + # m + expectedProposalOut = + mkRecordConstr + PProposalDatum + ( #proposalId .= proposalF.proposalId + .& #effects .= proposalF.effects + .& #status .= proposalF.status + .& #cosigners .= proposalF.cosigners + .& #thresholds .= proposalF.thresholds + .& #votes .= pdata expectedNewVotes + ) + + tcassert "Invalid output proposal" $ proposalOut #== expectedProposalOut + + -- We validate the output stake datum here as well: We need the vote option + -- to create a proper 'ProposalLock'. However the vote option is encoded + -- in the proposal redeemer, which is invisible for the stake validator. + + let stakeOutput = + mustBePJust # "Stake output not found" + #$ pfind + # plam + ( \(pfromData . (pfield @"value" #) -> value) -> + passetClassValueOf # value # stakeSTAssetClass #== 1 + ) + # pfromData txInfoF.outputs + + stakeOut :: Term _ PStakeDatum + stakeOut = mustFindDatum' # (pfield @"datumHash" # stakeOutput) # txInfoF.datums + + let newProposalLock = + mkRecordConstr + PProposalLock + ( #vote .= pdata voteFor + .& #proposalTag .= proposalF.proposalId + ) + expectedProposalLocks = + pcons + # pdata newProposalLock + # pfromData stakeInF.lockedBy + expectedStakeOut = + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeInF.stakedAmount + .& #owner .= stakeInF.owner + .& #lockedBy .= pdata expectedProposalLocks + ) + + tcassert "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut + + pure $ popaque (pconstant ()) -------------------------------------------------------------------------- PCosign r -> unTermCont $ do newSigs <- tclet $ pfield @"newCosigners" # r From 92c64f8d7a2f6946bf3b02cf166dc48ce5f22ee5 Mon Sep 17 00:00:00 2001 From: fanghr Date: Wed, 18 May 2022 20:34:56 +0800 Subject: [PATCH 04/14] store timing config in the proposal datum .... and mock the value upon creation for now --- agora-sample/Sample/Governor.hs | 3 +++ agora-sample/Sample/Proposal.hs | 2 ++ agora-sample/Sample/Shared.hs | 13 +++++++++++++ agora-test/Spec/Proposal.hs | 3 ++- agora/Agora/Governor/Scripts.hs | 13 +++++++++++++ agora/Agora/Proposal.hs | 5 +++++ agora/Agora/Proposal/Scripts.hs | 3 +++ agora/Agora/Proposal/Time.hs | 28 +++++++++++++++++++++++++++- 8 files changed, 68 insertions(+), 2 deletions(-) diff --git a/agora-sample/Sample/Governor.hs b/agora-sample/Sample/Governor.hs index ff5f0bf..f1c8f38 100644 --- a/agora-sample/Sample/Governor.hs +++ b/agora-sample/Sample/Governor.hs @@ -73,6 +73,7 @@ import Sample.Shared ( gstUTXORef, minAda, proposalPolicySymbol, + proposalTimingConfig, proposalValidatorAddress, signer, signer2, @@ -234,6 +235,7 @@ createProposal = , cosigners = [signer] , thresholds = defaultProposalThresholds , votes = emptyVotesFor effects + , timingConfig = proposalTimingConfig } ) proposalOutput :: TxOut @@ -408,6 +410,7 @@ mintGATs = , cosigners = [signer, signer2] , thresholds = defaultProposalThresholds , votes = proposalVotes + , timingConfig = proposalTimingConfig } proposalInputDatum :: Datum proposalInputDatum = Datum $ toBuiltinData proposalInputDatum' diff --git a/agora-sample/Sample/Proposal.hs b/agora-sample/Sample/Proposal.hs index e778fca..7853606 100644 --- a/agora-sample/Sample/Proposal.hs +++ b/agora-sample/Sample/Proposal.hs @@ -74,6 +74,7 @@ proposalCreation = , cosigners = [signer] , thresholds = defaultProposalThresholds , votes = emptyVotesFor effects + , timingConfig = proposalTimingConfig } ) @@ -167,6 +168,7 @@ cosignProposal newSigners = , cosigners = [signer] , thresholds = defaultProposalThresholds , votes = emptyVotesFor effects + , timingConfig = proposalTimingConfig } stakeDatum :: StakeDatum stakeDatum = StakeDatum (Tagged 50_000_000) signer2 [] diff --git a/agora-sample/Sample/Shared.hs b/agora-sample/Sample/Shared.hs index c6f40a7..71f2192 100644 --- a/agora-sample/Sample/Shared.hs +++ b/agora-sample/Sample/Shared.hs @@ -36,6 +36,7 @@ module Sample.Shared ( proposalPolicySymbol, proposalValidatorHash, proposalValidatorAddress, + proposalTimingConfig, -- ** Authority authorityToken, @@ -74,6 +75,9 @@ import Agora.Proposal ( Proposal (..), ProposalThresholds (..), ) +import Agora.Proposal.Time ( + ProposalTimingConfig (..), + ) import Agora.Stake (Stake (..)) import Agora.Treasury (treasuryValidator) import Agora.Utils (validatorHashToTokenName) @@ -184,6 +188,15 @@ authorityToken = authorityTokenFromGovernor governor authorityTokenSymbol :: CurrencySymbol authorityTokenSymbol = authorityTokenSymbolFromGovernor governor +proposalTimingConfig :: ProposalTimingConfig +proposalTimingConfig = + ProposalTimingConfig + { draftTime = 0 + , votingTime = 1000 + , lockingTime = 2000 + , executingTime = 3000 + } + ------------------------------------------------------------------ treasuryOut :: TxOut diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs index cb049ed..a9caafb 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-test/Spec/Proposal.hs @@ -13,7 +13,7 @@ module Spec.Proposal (tests) where import Agora.Proposal ( Proposal (..), - ProposalDatum (ProposalDatum), + ProposalDatum (..), ProposalId (ProposalId), ProposalRedeemer (Cosign), ProposalStatus (Draft), @@ -77,6 +77,7 @@ tests = [ (ResultTag 0, AssocMap.empty) , (ResultTag 1, AssocMap.empty) ] + , timingConfig = Shared.proposalTimingConfig } ) (Cosign [signer2]) diff --git a/agora/Agora/Governor/Scripts.hs b/agora/Agora/Governor/Scripts.hs index 8389f1d..d424db5 100644 --- a/agora/Agora/Governor/Scripts.hs +++ b/agora/Agora/Governor/Scripts.hs @@ -126,6 +126,7 @@ import Plutarch.TryFrom (ptryFrom) -------------------------------------------------------------------------------- +import Agora.Proposal.Time (ProposalTimingConfig (..)) import Plutus.V1.Ledger.Api ( CurrencySymbol (..), MintingPolicy, @@ -576,6 +577,8 @@ governorValidator gov = .& #cosigners .= proposalInputDatumF.cosigners .& #thresholds .= proposalInputDatumF.thresholds .& #votes .= proposalInputDatumF.votes + -- FIXME: copy from the governor datum + .& #timingConfig .= pdata (pconstant tmpTimingConfig) ) tcassert "Unexpected output proposal datum" $ @@ -727,6 +730,16 @@ governorValidator gov = let sym = governorSTSymbolFromGovernor gov in phoistAcyclic $ pconstant sym + -- TODO: remove this. This is temperary. + tmpTimingConfig :: ProposalTimingConfig + tmpTimingConfig = + ProposalTimingConfig + { draftTime = 0 + , votingTime = 1000 + , lockingTime = 2000 + , executingTime = 3000 + } + -------------------------------------------------------------------------------- -- | Get the 'CurrencySymbol' of GST. diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 3c82fe3..21407d3 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -44,6 +44,8 @@ import PlutusTx qualified import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- + +import Agora.Proposal.Time (PProposalTimingConfig, ProposalTimingConfig) import Agora.SafeMoney (GTTag) import Agora.Utils (pkeysEqual, pnotNull) import Control.Applicative (Const) @@ -186,6 +188,8 @@ data ProposalDatum = ProposalDatum -- ^ Thresholds copied over on initialization. , votes :: ProposalVotes -- ^ Vote tally on the proposal + , timingConfig :: ProposalTimingConfig + -- ^ Timing configuration copied over on initialization. } deriving stock (Eq, Show, GHC.Generic) @@ -354,6 +358,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash) , "thresholds" ':= PProposalThresholds , "votes" ':= PProposalVotes + , "timingConfig" ':= PProposalTimingConfig ] ) } diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index f09e90b..d56e146 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -151,6 +151,7 @@ proposalValidator proposal = , "cosigners" , "thresholds" , "votes" + , "timingConfig" ] proposalDatum @@ -253,6 +254,7 @@ proposalValidator proposal = .& #cosigners .= proposalF.cosigners .& #thresholds .= proposalF.thresholds .& #votes .= pdata expectedNewVotes + .& #timingConfig .= proposalF.timingConfig ) tcassert "Invalid output proposal" $ proposalOut #== expectedProposalOut @@ -342,6 +344,7 @@ proposalValidator proposal = .& #cosigners .= pdata updatedSigs .& #thresholds .= proposalF.thresholds .& #votes .= proposalF.votes + .& #timingConfig .= proposalF.timingConfig ) ) in foldr1 diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index afc4339..54fed1a 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -39,7 +39,12 @@ import Plutarch.Api.V1 ( PPOSIXTimeRange, PUpperBound (PUpperBound), ) -import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..)) +import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..)) +import Plutarch.Lift ( + DerivePConstantViaNewtype (..), + PConstantDecl, + PUnsafeLiftDecl (..), + ) import Plutarch.Numeric (AdditiveSemigroup ((+))) import Plutarch.Unsafe (punsafeCoerce) import Plutus.V1.Ledger.Time (POSIXTime) @@ -122,10 +127,24 @@ newtype PProposalTime (s :: S) (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PProposalTime) +instance PUnsafeLiftDecl PProposalTime where + type PLifted PProposalTime = ProposalTime +deriving via + (DerivePConstantViaData ProposalTime PProposalTime) + instance + (PConstantDecl ProposalTime) + -- | Plutarch-level version of 'ProposalStartingTime'. newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime) deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalStartingTime PPOSIXTime) +instance PUnsafeLiftDecl PProposalStartingTime where + type PLifted PProposalStartingTime = ProposalStartingTime +deriving via + (DerivePConstantViaNewtype ProposalStartingTime PProposalStartingTime PPOSIXTime) + instance + (PConstantDecl ProposalStartingTime) + -- | Plutarch-level version of 'ProposalTimingConfig'. newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig { getProposalTimingConfig :: @@ -146,6 +165,13 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PProposalTimingConfig) +instance PUnsafeLiftDecl PProposalTimingConfig where + type PLifted PProposalTimingConfig = ProposalTimingConfig +deriving via + (DerivePConstantViaData ProposalTimingConfig PProposalTimingConfig) + instance + (PConstantDecl ProposalTimingConfig) + -------------------------------------------------------------------------------- -- FIXME: Orphan instance, move this to plutarch-extra. From e8b87654f3cce9f8c3300061bcdc2c9a377b74ca Mon Sep 17 00:00:00 2001 From: fanghr Date: Wed, 18 May 2022 21:01:14 +0800 Subject: [PATCH 05/14] store starting time of the proposal in its datum ... hardcoded to 0 upon creation for now --- agora-sample/Sample/Governor.hs | 3 +++ agora-sample/Sample/Proposal.hs | 2 ++ agora-sample/Sample/Shared.hs | 6 ++++++ agora-test/Spec/Proposal.hs | 1 + agora/Agora/Governor/Scripts.hs | 8 +++++++- agora/Agora/Proposal.hs | 5 ++++- agora/Agora/Proposal/Scripts.hs | 3 +++ 7 files changed, 26 insertions(+), 2 deletions(-) diff --git a/agora-sample/Sample/Governor.hs b/agora-sample/Sample/Governor.hs index f1c8f38..27d867b 100644 --- a/agora-sample/Sample/Governor.hs +++ b/agora-sample/Sample/Governor.hs @@ -80,6 +80,7 @@ import Sample.Shared ( stake, stakeAddress, stakeAssetClass, + tmpProposalStartingTime, ) import Test.Util (datumPair, toDatumHash) @@ -236,6 +237,7 @@ createProposal = , thresholds = defaultProposalThresholds , votes = emptyVotesFor effects , timingConfig = proposalTimingConfig + , startingTime = tmpProposalStartingTime } ) proposalOutput :: TxOut @@ -411,6 +413,7 @@ mintGATs = , thresholds = defaultProposalThresholds , votes = proposalVotes , timingConfig = proposalTimingConfig + , startingTime = tmpProposalStartingTime } proposalInputDatum :: Datum proposalInputDatum = Datum $ toBuiltinData proposalInputDatum' diff --git a/agora-sample/Sample/Proposal.hs b/agora-sample/Sample/Proposal.hs index 7853606..329d862 100644 --- a/agora-sample/Sample/Proposal.hs +++ b/agora-sample/Sample/Proposal.hs @@ -75,6 +75,7 @@ proposalCreation = , thresholds = defaultProposalThresholds , votes = emptyVotesFor effects , timingConfig = proposalTimingConfig + , startingTime = tmpProposalStartingTime } ) @@ -169,6 +170,7 @@ cosignProposal newSigners = , thresholds = defaultProposalThresholds , votes = emptyVotesFor effects , timingConfig = proposalTimingConfig + , startingTime = tmpProposalStartingTime } stakeDatum :: StakeDatum stakeDatum = StakeDatum (Tagged 50_000_000) signer2 [] diff --git a/agora-sample/Sample/Shared.hs b/agora-sample/Sample/Shared.hs index 71f2192..1f30fb0 100644 --- a/agora-sample/Sample/Shared.hs +++ b/agora-sample/Sample/Shared.hs @@ -37,6 +37,7 @@ module Sample.Shared ( proposalValidatorHash, proposalValidatorAddress, proposalTimingConfig, + tmpProposalStartingTime, -- ** Authority authorityToken, @@ -76,6 +77,7 @@ import Agora.Proposal ( ProposalThresholds (..), ) import Agora.Proposal.Time ( + ProposalStartingTime (..), ProposalTimingConfig (..), ) import Agora.Stake (Stake (..)) @@ -197,6 +199,10 @@ proposalTimingConfig = , executingTime = 3000 } +-- FIXME: should be removed. +tmpProposalStartingTime :: ProposalStartingTime +tmpProposalStartingTime = ProposalStartingTime 0 + ------------------------------------------------------------------ treasuryOut :: TxOut diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs index a9caafb..646d96e 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-test/Spec/Proposal.hs @@ -78,6 +78,7 @@ tests = , (ResultTag 1, AssocMap.empty) ] , timingConfig = Shared.proposalTimingConfig + , startingTime = Shared.tmpProposalStartingTime } ) (Cosign [signer2]) diff --git a/agora/Agora/Governor/Scripts.hs b/agora/Agora/Governor/Scripts.hs index d424db5..d1b176e 100644 --- a/agora/Agora/Governor/Scripts.hs +++ b/agora/Agora/Governor/Scripts.hs @@ -126,7 +126,7 @@ import Plutarch.TryFrom (ptryFrom) -------------------------------------------------------------------------------- -import Agora.Proposal.Time (ProposalTimingConfig (..)) +import Agora.Proposal.Time (ProposalStartingTime (..), ProposalTimingConfig (..)) import Plutus.V1.Ledger.Api ( CurrencySymbol (..), MintingPolicy, @@ -579,6 +579,8 @@ governorValidator gov = .& #votes .= proposalInputDatumF.votes -- FIXME: copy from the governor datum .& #timingConfig .= pdata (pconstant tmpTimingConfig) + -- FIXME: calculate from 'txInfoValidRange' + .& #startingTime .= pdata (pconstant tmpProposalStartingTime) ) tcassert "Unexpected output proposal datum" $ @@ -740,6 +742,10 @@ governorValidator gov = , executingTime = 3000 } + -- TODO: remove this. + tmpProposalStartingTime :: ProposalStartingTime + tmpProposalStartingTime = ProposalStartingTime 0 + -------------------------------------------------------------------------------- -- | Get the 'CurrencySymbol' of GST. diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 21407d3..0da7627 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -45,7 +45,7 @@ import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- -import Agora.Proposal.Time (PProposalTimingConfig, ProposalTimingConfig) +import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig) import Agora.SafeMoney (GTTag) import Agora.Utils (pkeysEqual, pnotNull) import Control.Applicative (Const) @@ -190,6 +190,8 @@ data ProposalDatum = ProposalDatum -- ^ Vote tally on the proposal , timingConfig :: ProposalTimingConfig -- ^ Timing configuration copied over on initialization. + , startingTime :: ProposalStartingTime + -- ^ The time upon the creation of the proposal. } deriving stock (Eq, Show, GHC.Generic) @@ -359,6 +361,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum , "thresholds" ':= PProposalThresholds , "votes" ':= PProposalVotes , "timingConfig" ':= PProposalTimingConfig + , "startingTime" ':= PProposalStartingTime ] ) } diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index d56e146..44ab890 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -152,6 +152,7 @@ proposalValidator proposal = , "thresholds" , "votes" , "timingConfig" + , "startingTime" ] proposalDatum @@ -255,6 +256,7 @@ proposalValidator proposal = .& #thresholds .= proposalF.thresholds .& #votes .= pdata expectedNewVotes .& #timingConfig .= proposalF.timingConfig + .& #startingTime .= proposalF.startingTime ) tcassert "Invalid output proposal" $ proposalOut #== expectedProposalOut @@ -345,6 +347,7 @@ proposalValidator proposal = .& #thresholds .= proposalF.thresholds .& #votes .= proposalF.votes .& #timingConfig .= proposalF.timingConfig + .& #startingTime .= proposalF.startingTime ) ) in foldr1 From b4ca5747572c876d633e1eff342983a94c767804 Mon Sep 17 00:00:00 2001 From: fanghr Date: Wed, 18 May 2022 21:11:55 +0800 Subject: [PATCH 06/14] ensure that the voting op is within a valid period --- agora/Agora/Proposal/Scripts.hs | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 44ab890..7656303 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -17,6 +17,7 @@ import Agora.Proposal ( Proposal (governorSTAssetClass, stakeSTAssetClass), ProposalStatus (VotingReady), ) +import Agora.Proposal.Time (currentProposalTime, isVotingPeriod) import Agora.Record (mkRecordConstr, (.&), (.=)) import Agora.Stake (PProposalLock (..), PStakeDatum (..), findStakeOwnedBy) import Agora.Utils ( @@ -131,7 +132,17 @@ proposalValidator proposal = ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx' txInfo <- tclet $ pfromData ctx.txInfo PTxInfo txInfo' <- tcmatch txInfo - txInfoF <- tcont $ pletFields @'["inputs", "outputs", "mint", "datums", "signatories"] txInfo' + txInfoF <- + tcont $ + pletFields + @'[ "inputs" + , "outputs" + , "mint" + , "datums" + , "signatories" + , "validRange" + ] + txInfo' PSpending ((pfield @"_0" #) -> txOutRef) <- tcmatch $ pfromData ctx.purpose PJust txOut <- tcmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs @@ -173,13 +184,17 @@ proposalValidator proposal = tcassert "ST at inputs must be 1" (spentST #== 1) + currentTime <- tclet $ currentProposalTime # txInfoF.validRange + pure $ pmatch proposalRedeemer $ \case PVote r -> unTermCont $ do - -- TODO: do we have to check the timing here? tcassert "Input proposal must be in VotingReady state" $ proposalF.status #== pconstant VotingReady + tcassert "Proposal time should be wthin the voting period" $ + isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime + -- Ensure the transaction is voting to a valid 'ResultTag'(outcome). PProposalVotes voteMap <- tcmatch proposalF.votes voteFor <- tclet $ pfromData $ pfield @"resultTag" # r From 82201a6e1fdae1c47353eff76ad4d885479f5bda Mon Sep 17 00:00:00 2001 From: fanghr Date: Wed, 18 May 2022 21:33:42 +0800 Subject: [PATCH 07/14] add sample test && fix broken tests --- agora-sample/Sample/Proposal.hs | 157 +++++++++++++++++++++++++++++++- agora-sample/Sample/Shared.hs | 2 +- agora-test/Spec/Proposal.hs | 52 ++++++++++- agora-testlib/Test/Util.hs | 22 +++++ agora/Agora/Governor/Scripts.hs | 2 +- agora/Agora/Proposal/Scripts.hs | 28 +++--- 6 files changed, 238 insertions(+), 25 deletions(-) diff --git a/agora-sample/Sample/Proposal.hs b/agora-sample/Sample/Proposal.hs index 329d862..7763f42 100644 --- a/agora-sample/Sample/Proposal.hs +++ b/agora-sample/Sample/Proposal.hs @@ -11,6 +11,7 @@ module Sample.Proposal ( cosignProposal, proposalRef, stakeRef, + voteOnProposal, ) where -------------------------------------------------------------------------------- @@ -21,6 +22,7 @@ import Plutus.V1.Ledger.Api ( Address (Address), Credential (ScriptCredential), Datum (Datum), + POSIXTimeRange, PubKeyHash, ScriptContext (..), ScriptPurpose (..), @@ -43,14 +45,16 @@ import Agora.Proposal ( ProposalDatum (..), ProposalId (..), ProposalStatus (..), + ProposalVotes (..), ResultTag (..), emptyVotesFor, ) -import Agora.Stake (Stake (..), StakeDatum (StakeDatum)) +import Agora.Proposal.Time (ProposalTimingConfig (..)) +import Agora.Stake (ProposalLock (ProposalLock), Stake (..), StakeDatum (..)) import Plutarch.SafeMoney (Tagged (Tagged), untag) import PlutusTx.AssocMap qualified as AssocMap import Sample.Shared -import Test.Util (datumPair, toDatumHash) +import Test.Util (closedBoundedInterval, datumPair, toDatumHash, updateMap) -------------------------------------------------------------------------------- @@ -176,6 +180,11 @@ cosignProposal newSigners = stakeDatum = StakeDatum (Tagged 50_000_000) signer2 [] proposalAfter :: ProposalDatum proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners} + validTimeRange :: POSIXTimeRange + validTimeRange = + closedBoundedInterval + 10 + (proposalTimingConfig.draftTime - 10) in TxInfo { txInfoInputs = [ TxInInfo @@ -227,7 +236,7 @@ cosignProposal newSigners = , txInfoMint = st , txInfoDCert = [] , txInfoWdrl = [] - , txInfoValidRange = Interval.always + , txInfoValidRange = validTimeRange , txInfoSignatories = newSigners , txInfoData = [ datumPair . Datum $ toBuiltinData proposalBefore @@ -236,3 +245,145 @@ cosignProposal newSigners = ] , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" } + +{- | A valid transaction of voting on a propsal. + + -- TODO: docs +-} +voteOnProposal :: ResultTag -> Integer -> TxInfo +voteOnProposal voteFor voteCount = + let pst = Value.singleton proposalPolicySymbol "" 1 + sst = Value.assetClassValue stakeAssetClass 1 + + --- + + stakeOwner = signer + + --- + + effects = + AssocMap.fromList + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.empty) + ] + + --- + + initialVotes :: AssocMap.Map ResultTag Integer + initialVotes = + AssocMap.fromList + [ (ResultTag 0, 42) + , (ResultTag 1, 4242) + ] + + --- + + proposalInputDatum' :: ProposalDatum + proposalInputDatum' = + ProposalDatum + { proposalId = ProposalId 42 + , effects = effects + , status = VotingReady + , cosigners = [stakeOwner] + , thresholds = defaultProposalThresholds + , votes = ProposalVotes initialVotes + , timingConfig = proposalTimingConfig + , startingTime = tmpProposalStartingTime + } + proposalInputDatum :: Datum + proposalInputDatum = Datum $ toBuiltinData proposalInputDatum' + proposalInput :: TxOut + proposalInput = + TxOut + { txOutAddress = proposalValidatorAddress + , txOutValue = pst + , txOutDatumHash = Just $ toDatumHash proposalInputDatum + } + + --- + + existingLocks :: [ProposalLock] + existingLocks = + [ ProposalLock (ResultTag 0) (ProposalId 0) + , ProposalLock (ResultTag 2) (ProposalId 1) + ] + + --- + + stakeInputDatum' :: StakeDatum + stakeInputDatum' = + StakeDatum + { stakedAmount = Tagged voteCount + , owner = stakeOwner + , lockedBy = existingLocks + } + stakeInputDatum :: Datum + stakeInputDatum = Datum $ toBuiltinData stakeInputDatum' + stakeInput :: TxOut + stakeInput = + TxOut + { txOutAddress = stakeAddress + , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) voteCount + , txOutDatumHash = Just $ toDatumHash stakeInputDatum + } + + --- + + updatedVotes :: AssocMap.Map ResultTag Integer + updatedVotes = updateMap (Just . (+ voteCount)) voteFor initialVotes + + --- + + proposalOutputDatum' :: ProposalDatum + proposalOutputDatum' = + proposalInputDatum' + { votes = ProposalVotes updatedVotes + } + proposalOutputDatum :: Datum + proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum' + proposalOutput :: TxOut + proposalOutput = + proposalInput + { txOutDatumHash = Just $ toDatumHash proposalOutputDatum + } + + --- + + -- Off-chain code should do exactly like this: prepend new lock to the list. + updatedLocks :: [ProposalLock] + updatedLocks = ProposalLock voteFor proposalInputDatum'.proposalId : existingLocks + + --- + + stakeOutputDatum' :: StakeDatum + stakeOutputDatum' = + stakeInputDatum' + { lockedBy = updatedLocks + } + stakeOutputDatum :: Datum + stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum' + stakeOutput :: TxOut + stakeOutput = + stakeInput + { txOutDatumHash = Just $ toDatumHash stakeOutputDatum + } + + --- + + validTimeRange = + closedBoundedInterval (proposalTimingConfig.draftTime + 1) (proposalTimingConfig.votingTime - 1) + in TxInfo + { txInfoInputs = + [ TxInInfo proposalRef proposalInput + , TxInInfo stakeRef stakeInput + ] + , txInfoOutputs = [proposalOutput, stakeOutput] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = mempty + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = validTimeRange + , txInfoSignatories = [stakeOwner] + , txInfoData = datumPair <$> [proposalInputDatum, proposalOutputDatum, stakeInputDatum, stakeOutputDatum] + , txInfoId = "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c" + } diff --git a/agora-sample/Sample/Shared.hs b/agora-sample/Sample/Shared.hs index 1f30fb0..46cc0d3 100644 --- a/agora-sample/Sample/Shared.hs +++ b/agora-sample/Sample/Shared.hs @@ -193,7 +193,7 @@ authorityTokenSymbol = authorityTokenSymbolFromGovernor governor proposalTimingConfig :: ProposalTimingConfig proposalTimingConfig = ProposalTimingConfig - { draftTime = 0 + { draftTime = 50 , votingTime = 1000 , lockingTime = 2000 , executingTime = 3000 diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs index 646d96e..3ed1e4e 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-test/Spec/Proposal.hs @@ -15,8 +15,9 @@ import Agora.Proposal ( Proposal (..), ProposalDatum (..), ProposalId (ProposalId), - ProposalRedeemer (Cosign), - ProposalStatus (Draft), + ProposalRedeemer (Cosign, Vote), + ProposalStatus (Draft, VotingReady), + ProposalVotes (ProposalVotes), ResultTag (ResultTag), cosigners, effects, @@ -30,7 +31,11 @@ import Agora.Proposal.Scripts ( proposalPolicy, proposalValidator, ) -import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake)) +import Agora.Stake ( + ProposalLock (ProposalLock), + StakeDatum (StakeDatum), + StakeRedeemer (PermitVote, WitnessStake), + ) import Agora.Stake.Scripts (stakeValidator) import Plutarch.SafeMoney (Tagged (Tagged)) import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..)) @@ -90,5 +95,46 @@ tests = WitnessStake (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef)) ] + , testGroup + "voting" + [ validatorSucceedsWith + "proposal" + (proposalValidator Shared.proposal) + ( ProposalDatum + { proposalId = ProposalId 42 + , effects = + AssocMap.fromList + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.empty) + ] + , status = VotingReady + , cosigners = [signer] + , thresholds = Shared.defaultProposalThresholds + , votes = + ProposalVotes + ( AssocMap.fromList + [ (ResultTag 0, 42) + , (ResultTag 1, 4242) + ] + ) + , timingConfig = Shared.proposalTimingConfig + , startingTime = Shared.tmpProposalStartingTime + } + ) + (Vote (ResultTag 0)) + (ScriptContext (Proposal.voteOnProposal (ResultTag 0) 27) (Spending Proposal.proposalRef)) + , validatorSucceedsWith + "stake" + (stakeValidator Shared.stake) + ( StakeDatum + (Tagged 27) + signer + [ ProposalLock (ResultTag 0) (ProposalId 0) + , ProposalLock (ResultTag 2) (ProposalId 1) + ] + ) + (PermitVote $ ProposalLock (ResultTag 0) (ProposalId 42)) + (ScriptContext (Proposal.voteOnProposal (ResultTag 0) 27) (Spending Proposal.stakeRef)) + ] ] ] diff --git a/agora-testlib/Test/Util.hs b/agora-testlib/Test/Util.hs index 74e8ac6..4d6f733 100644 --- a/agora-testlib/Test/Util.hs +++ b/agora-testlib/Test/Util.hs @@ -38,6 +38,8 @@ module Test.Util ( toDatum, toDatumHash, datumPair, + closedBoundedInterval, + updateMap, ) where -------------------------------------------------------------------------------- @@ -62,9 +64,12 @@ import Plutarch.Crypto (pblake2b_256) import Plutarch.Evaluate (evalScript) import Plutarch.Lift (PUnsafeLiftDecl (PLifted)) import Plutus.V1.Ledger.Contexts (ScriptContext) +import Plutus.V1.Ledger.Interval as PlutusTx import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash), Script) +import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.Builtins qualified as PlutusTx import PlutusTx.IsData qualified as PlutusTx +import PlutusTx.Ord qualified as PlutusTx -------------------------------------------------------------------------------- @@ -231,3 +236,20 @@ toDatumHash datum = plift $ pblake2b_256 # pconstant (ByteString.Lazy.toStrict $ serialise $ PlutusTx.toData datum) + +-------------------------------------------------------------------------------- + +-- | Create a closed bounded `Interval`. +closedBoundedInterval :: PlutusTx.Ord a => a -> a -> PlutusTx.Interval a +closedBoundedInterval from to = PlutusTx.intersection (PlutusTx.from from) (PlutusTx.to to) + +-------------------------------------------------------------------------------- + +updateMap :: Eq k => (v -> Maybe v) -> k -> AssocMap.Map k v -> AssocMap.Map k v +updateMap f k = + AssocMap.mapMaybeWithKey + ( \k' v -> + if k' == k + then f v + else Just v + ) diff --git a/agora/Agora/Governor/Scripts.hs b/agora/Agora/Governor/Scripts.hs index d1b176e..0b41352 100644 --- a/agora/Agora/Governor/Scripts.hs +++ b/agora/Agora/Governor/Scripts.hs @@ -736,7 +736,7 @@ governorValidator gov = tmpTimingConfig :: ProposalTimingConfig tmpTimingConfig = ProposalTimingConfig - { draftTime = 0 + { draftTime = 50 , votingTime = 1000 , lockingTime = 2000 , executingTime = 3000 diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 7656303..73de60b 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -230,24 +230,18 @@ proposalValidator proposal = -- TODO: maybe we can move this outside of the pmatch block. -- Filter out own output with own address and PST. - ownOutput <- - tclet $ - mustBePJust # "Own output not found" #$ pfind - # plam - ( \input -> unTermCont $ do - inputF <- tcont $ pletFields @'["address", "value"] input - pure $ - inputF.address #== ownAddress - #&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1 - ) - # pfromData txInfoF.outputs + let ownOutput = + mustBePJust # "Own output not found" #$ pfind + # plam + ( \input -> unTermCont $ do + inputF <- tcont $ pletFields @'["address", "value"] input + pure $ + inputF.address #== ownAddress + #&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1 + ) + # pfromData txInfoF.outputs - ownOutputF <- tcont $ pletFields @'["datumHash", "value"] ownOutput - - -- TODO: is this really necessary? - tcassert "Own output value should be correct" $ ownOutputF.value #== pdata txOutF.value - - let proposalOut :: Term _ PProposalDatum + proposalOut :: Term _ PProposalDatum proposalOut = mustFindDatum' # (pfield @"datumHash" # ownOutput) # txInfoF.datums let -- Update the vote counter of the proposal, and leave other stuff as is. From dfe4bba15f66717e06a8f17131674b5ce15f3d24 Mon Sep 17 00:00:00 2001 From: fanghr Date: Thu, 19 May 2022 13:58:12 +0800 Subject: [PATCH 08/14] ensure the new proposal lock is placed on the stake --- agora/Agora/Proposal/Scripts.hs | 5 +++-- agora/Agora/Stake/Scripts.hs | 29 ++++++++++++++++++++++++++--- 2 files changed, 29 insertions(+), 5 deletions(-) diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 73de60b..dc85b71 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -271,8 +271,8 @@ proposalValidator proposal = tcassert "Invalid output proposal" $ proposalOut #== expectedProposalOut -- We validate the output stake datum here as well: We need the vote option - -- to create a proper 'ProposalLock'. However the vote option is encoded - -- in the proposal redeemer, which is invisible for the stake validator. + -- to create a valid 'ProposalLock', however the vote option is encoded + -- in the proposal redeemer, which is invisible for the stake validator. let stakeOutput = mustBePJust # "Stake output not found" @@ -292,6 +292,7 @@ proposalValidator proposal = ( #vote .= pdata voteFor .& #proposalTag .= proposalF.proposalId ) + -- Prepend the new lock to existing locks expectedProposalLocks = pcons # pdata newProposalLock diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 74494e8..aaf114b 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -7,6 +7,7 @@ Plutus Scripts for Stakes. -} module Agora.Stake.Scripts (stakePolicy, stakeValidator) where +import Agora.Record (mkRecordConstr, (.&), (.=)) import Agora.SafeMoney (GTTag) import Agora.Stake import Agora.Utils ( @@ -222,7 +223,7 @@ stakeValidator stake = -- TODO: Use PTryFrom let stakeDatum' :: Term _ PStakeDatum stakeDatum' = pfromData $ punsafeCoerce datum - stakeDatum <- tcont $ pletFields @'["owner", "stakedAmount"] stakeDatum' + stakeDatum <- tcont $ pletFields @'["owner", "stakedAmount", "lockedBy"] stakeDatum' PSpending txOutRef <- tcmatch $ pfromData ctx.purpose @@ -291,7 +292,7 @@ stakeValidator stake = pure $ popaque (pconstant ()) -------------------------------------------------------------------------- - PPermitVote _ -> unTermCont $ do + PPermitVote l -> unTermCont $ do tcassert "Owner signs this transaction" ownerSignsTransaction @@ -301,18 +302,40 @@ stakeValidator stake = tcassert "Proposal ST spent" $ spentProposalST #== 1 + -- Update the stake datum, but only the 'lockedBy' field. + + let -- We actually don't know whether the given lock is valid or not. + -- This is checked in the proposal validator. + newLock = pfield @"lock" # l + -- Prepend the new lock to the existing locks. + expectedLocks = pcons # newLock # stakeDatum.lockedBy + + expectedDatum <- + tclet $ + pdata $ + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeDatum.stakedAmount + .& #owner .= stakeDatum.owner + .& #lockedBy .= pdata expectedLocks + ) + tcassert "A UTXO must exist with the correct output" $ + -- FIXME: no need to pass the whole txInfo to 'anyOutput'. anyOutput @PStakeDatum # txInfo #$ plam $ \value address newStakeDatum' -> let isScriptAddress = pdata address #== ownAddress - _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' + correctOutputDatum = pdata newStakeDatum' #== expectedDatum + -- TODO: Is this correct? I think We only need to ensure + -- correct amount of GT/SST in the continuing output. valueCorrect = pdata continuingValue #== pdata value in pif isScriptAddress ( foldl1 (#&&) [ ptraceIfFalse "valueCorrect" valueCorrect + , ptraceIfFalse "datumCorrect" correctOutputDatum ] ) (pcon PFalse) From 3f5707eb86e0c5316601b9149b4a2e40a34ea21a Mon Sep 17 00:00:00 2001 From: fanghr Date: Thu, 19 May 2022 17:10:33 +0800 Subject: [PATCH 09/14] some doc for the proposal voting sample --- agora-sample/Sample/Proposal.hs | 26 +++++++++++++++++--------- agora-test/Spec/Proposal.hs | 20 ++++++++++++++++++-- 2 files changed, 35 insertions(+), 11 deletions(-) diff --git a/agora-sample/Sample/Proposal.hs b/agora-sample/Sample/Proposal.hs index 7763f42..c476ec3 100644 --- a/agora-sample/Sample/Proposal.hs +++ b/agora-sample/Sample/Proposal.hs @@ -12,6 +12,7 @@ module Sample.Proposal ( proposalRef, stakeRef, voteOnProposal, + VotingParameters (..), ) where -------------------------------------------------------------------------------- @@ -246,12 +247,19 @@ cosignProposal newSigners = , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" } -{- | A valid transaction of voting on a propsal. +-------------------------------------------------------------------------------- - -- TODO: docs --} -voteOnProposal :: ResultTag -> Integer -> TxInfo -voteOnProposal voteFor voteCount = +-- | Parameters for creating a voting transaction. +data VotingParameters = VotingParameters + { voteFor :: ResultTag + -- ^ The outcome the transaction is voting for. + , voteCount :: Integer + -- ^ The count of votes. + } + +-- | Create a valid transaction that votes on a propsal, given the parameters. +voteOnProposal :: VotingParameters -> TxInfo +voteOnProposal params = let pst = Value.singleton proposalPolicySymbol "" 1 sst = Value.assetClassValue stakeAssetClass 1 @@ -313,7 +321,7 @@ voteOnProposal voteFor voteCount = stakeInputDatum' :: StakeDatum stakeInputDatum' = StakeDatum - { stakedAmount = Tagged voteCount + { stakedAmount = Tagged params.voteCount , owner = stakeOwner , lockedBy = existingLocks } @@ -323,14 +331,14 @@ voteOnProposal voteFor voteCount = stakeInput = TxOut { txOutAddress = stakeAddress - , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) voteCount + , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) params.voteCount , txOutDatumHash = Just $ toDatumHash stakeInputDatum } --- updatedVotes :: AssocMap.Map ResultTag Integer - updatedVotes = updateMap (Just . (+ voteCount)) voteFor initialVotes + updatedVotes = updateMap (Just . (+ params.voteCount)) params.voteFor initialVotes --- @@ -351,7 +359,7 @@ voteOnProposal voteFor voteCount = -- Off-chain code should do exactly like this: prepend new lock to the list. updatedLocks :: [ProposalLock] - updatedLocks = ProposalLock voteFor proposalInputDatum'.proposalId : existingLocks + updatedLocks = ProposalLock params.voteFor proposalInputDatum'.proposalId : existingLocks --- diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs index 3ed1e4e..a78d693 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-test/Spec/Proposal.hs @@ -122,7 +122,15 @@ tests = } ) (Vote (ResultTag 0)) - (ScriptContext (Proposal.voteOnProposal (ResultTag 0) 27) (Spending Proposal.proposalRef)) + ( ScriptContext + ( Proposal.voteOnProposal + Proposal.VotingParameters + { Proposal.voteFor = ResultTag 0 + , Proposal.voteCount = 27 + } + ) + (Spending Proposal.proposalRef) + ) , validatorSucceedsWith "stake" (stakeValidator Shared.stake) @@ -134,7 +142,15 @@ tests = ] ) (PermitVote $ ProposalLock (ResultTag 0) (ProposalId 42)) - (ScriptContext (Proposal.voteOnProposal (ResultTag 0) 27) (Spending Proposal.stakeRef)) + ( ScriptContext + ( Proposal.voteOnProposal + Proposal.VotingParameters + { Proposal.voteFor = ResultTag 0 + , Proposal.voteCount = 27 + } + ) + (Spending Proposal.stakeRef) + ) ] ] ] From bce9b45c253fa7550d0630585f3199b370a84d2c Mon Sep 17 00:00:00 2001 From: fanghr Date: Fri, 20 May 2022 01:10:24 +0800 Subject: [PATCH 10/14] add missing doc strings --- agora-sample/Sample/Shared.hs | 5 ++++- agora-testlib/Test/Util.hs | 4 ++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/agora-sample/Sample/Shared.hs b/agora-sample/Sample/Shared.hs index 46cc0d3..adaed30 100644 --- a/agora-sample/Sample/Shared.hs +++ b/agora-sample/Sample/Shared.hs @@ -199,7 +199,10 @@ proposalTimingConfig = , executingTime = 3000 } --- FIXME: should be removed. +{- | Hard coded starting time of every propoal. + This will be calculated by the governor in the future. + FIXME: Remove this. +-} tmpProposalStartingTime :: ProposalStartingTime tmpProposalStartingTime = ProposalStartingTime 0 diff --git a/agora-testlib/Test/Util.hs b/agora-testlib/Test/Util.hs index 4d6f733..624d728 100644 --- a/agora-testlib/Test/Util.hs +++ b/agora-testlib/Test/Util.hs @@ -245,6 +245,10 @@ closedBoundedInterval from to = PlutusTx.intersection (PlutusTx.from from) (Plut -------------------------------------------------------------------------------- +{- | / O(n) /. The expression @'updateMap' f k v@ will update the value @x@ at key @k@. + If @f x@ is Nothing, the key-value pair will be deleted from the map, otherwise the + value will be updated. +-} updateMap :: Eq k => (v -> Maybe v) -> k -> AssocMap.Map k v -> AssocMap.Map k v updateMap f k = AssocMap.mapMaybeWithKey From cdffbeffc97c40f2c104be330402275df9159b0b Mon Sep 17 00:00:00 2001 From: fanghr Date: Fri, 20 May 2022 03:15:21 +0800 Subject: [PATCH 11/14] add a property test for `pupdate` and `updateMap` --- agora-test/Spec/Utils.hs | 88 ++++++++++++++++++++++++++++++++++++-- agora-testlib/Test/Util.hs | 2 +- agora.cabal | 1 + 3 files changed, 87 insertions(+), 4 deletions(-) diff --git a/agora-test/Spec/Utils.hs b/agora-test/Spec/Utils.hs index e255cf2..fef48c4 100644 --- a/agora-test/Spec/Utils.hs +++ b/agora-test/Spec/Utils.hs @@ -9,17 +9,33 @@ module Spec.Utils (tests) where -------------------------------------------------------------------------------- -import Agora.Utils (phalve, pisUniq, pmergeBy, pmsort, pnubSort) +import Agora.Utils (phalve, pisUniq, pmergeBy, pmsort, pnubSort, pupdate) -------------------------------------------------------------------------------- import Data.List (nub, sort) -import Data.Set as S +import Data.Map qualified as M +import Data.Set qualified as S -------------------------------------------------------------------------------- +import Control.Monad.Cont (cont, runCont) import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.QuickCheck ( + Arbitrary (arbitrary), + Property, + Testable (property), + elements, + forAll, + suchThat, + testProperty, + (.&&.), + ) +import Test.Util (updateMap) + +-------------------------------------------------------------------------------- + +import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- @@ -30,6 +46,7 @@ tests = , testProperty "'phalve' splits a list in half as expected" prop_halveCorrect , testProperty "'pnubSort' sorts a list and remove duplicate elements" prop_nubSortProperly , testProperty "'pisUniq' can tell whether all elements in a list are unique" prop_uniqueList + , testProperty "'pupdate' updates assoc maps as 'updateMap' does" prop_updateAssocMapParity ] -------------------------------------------------------------------------------- @@ -142,3 +159,68 @@ prop_uniqueList l = isUnique == expected -- isUnique = plift $ pisUniq # pconstant l + +{- | Test the parity between 'updateMap' and 'pupdate', + also ensure they both work correctly. +-} +prop_updateAssocMapParity :: Property +prop_updateAssocMapParity = + runCont + ( do + -- Generate a bunch unique keys. + keys <- + cont $ + forAll $ + arbitrary @(S.Set Integer) `suchThat` (not . S.null) + + -- Generate key-value pairs. + kvPairs <- cont $ forAll $ mapM (\k -> (k,) <$> (arbitrary @Integer)) $ S.toList keys + + let initialMap = AssocMap.fromList kvPairs + + pinitialMap :: Term _ _ + pinitialMap = phoistAcyclic $ pconstant initialMap + + referenceMap = M.fromList kvPairs + + let pupdatedValue :: Maybe Integer -> Term _ (PMaybe PInteger) + pupdatedValue updatedValue = phoistAcyclic $ case updatedValue of + Nothing -> pcon PNothing + Just v -> pcon $ PJust $ pconstant v + + -- Given the key and the updated value, test the parity + parity key updatedValue = + let native = updateMap (const updatedValue) key initialMap + + plutarch :: AssocMap.Map Integer Integer + plutarch = + plift $ + pupdate + # plam (\_ -> pupdatedValue updatedValue) + # pconstant key + # pinitialMap + + expected = + AssocMap.fromList $ + M.toList $ + M.update (const updatedValue) key referenceMap + in expected == native + && expected == plutarch + + -- Select a key, generate a maybe value. + -- The value at the key should be set to the new value or removed. + (targetKey, _) <- cont $ forAll $ elements kvPairs + updatedValue <- cont $ forAll $ arbitrary @(Maybe Integer) + + -- Now what if the key doesn't exist in our map? + nonexistentKey <- + cont $ + forAll $ + arbitrary @Integer `suchThat` (\k -> not $ S.member k keys) + + pure + ( property (parity targetKey updatedValue) + .&&. property (parity nonexistentKey updatedValue) + ) + ) + id diff --git a/agora-testlib/Test/Util.hs b/agora-testlib/Test/Util.hs index 624d728..ab750d1 100644 --- a/agora-testlib/Test/Util.hs +++ b/agora-testlib/Test/Util.hs @@ -246,7 +246,7 @@ closedBoundedInterval from to = PlutusTx.intersection (PlutusTx.from from) (Plut -------------------------------------------------------------------------------- {- | / O(n) /. The expression @'updateMap' f k v@ will update the value @x@ at key @k@. - If @f x@ is Nothing, the key-value pair will be deleted from the map, otherwise the + If @f x@ is Nothing, the key-value pair will be deleted from the map, otherwise the value will be updated. -} updateMap :: Eq k => (v -> Maybe v) -> k -> AssocMap.Map k v -> AssocMap.Map k v diff --git a/agora.cabal b/agora.cabal index 6d34d9c..7d01530 100644 --- a/agora.cabal +++ b/agora.cabal @@ -114,6 +114,7 @@ common test-deps , agora , apropos , apropos-tx + , mtl , QuickCheck , quickcheck-instances , tasty From 9549fae0df940adb7ec7adf0f7f8a08d4a2d29ca Mon Sep 17 00:00:00 2001 From: fanghr Date: Fri, 20 May 2022 16:02:06 +0800 Subject: [PATCH 12/14] fix misleading assert messages && add some comments --- agora-sample/Sample/Proposal.hs | 4 ++++ agora/Agora/Proposal/Scripts.hs | 12 ++++++------ agora/Agora/Stake/Scripts.hs | 2 -- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/agora-sample/Sample/Proposal.hs b/agora-sample/Sample/Proposal.hs index c476ec3..8e00803 100644 --- a/agora-sample/Sample/Proposal.hs +++ b/agora-sample/Sample/Proposal.hs @@ -374,6 +374,10 @@ voteOnProposal params = stakeOutput = stakeInput { txOutDatumHash = Just $ toDatumHash stakeOutputDatum + -- We won't include the minimum Ada in the output value + -- due to how we check the output value in the stake validator. + -- The implementation is correct though, it should work in a + -- real on-chain environment. } --- diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index dc85b71..3fe0244 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -199,14 +199,14 @@ proposalValidator proposal = PProposalVotes voteMap <- tcmatch proposalF.votes voteFor <- tclet $ pfromData $ pfield @"resultTag" # r - tcassert "Invalid vote option" $ + tcassert "Vote option should be valid" $ pisJust #$ plookup # voteFor # voteMap -- Find the input stake, the amount of new votes should be the 'stakedAmount'. let stakeInput = pfield @"resolved" #$ mustBePJust - # "Stake input not found" + # "Stake input should be present" #$ pfind # plam ( \(pfromData . (pfield @"value" #) . (pfield @"resolved" #) -> value) -> @@ -220,7 +220,7 @@ proposalValidator proposal = stakeInF <- tcont $ pletFields @'["stakedAmount", "lockedBy", "owner"] stakeIn -- Ensure that no lock with the current proposal id has been put on the stake. - tcassert "Cannot vote on the a proposal using the same stake twice" $ + tcassert "Same stake shouldn't vote on the same propsoal twice" $ pnot #$ pany # plam ( \((pfield @"proposalTag" #) . pfromData -> pid) -> @@ -231,7 +231,7 @@ proposalValidator proposal = -- TODO: maybe we can move this outside of the pmatch block. -- Filter out own output with own address and PST. let ownOutput = - mustBePJust # "Own output not found" #$ pfind + mustBePJust # "Own output should be present" #$ pfind # plam ( \input -> unTermCont $ do inputF <- tcont $ pletFields @'["address", "value"] input @@ -268,14 +268,14 @@ proposalValidator proposal = .& #startingTime .= proposalF.startingTime ) - tcassert "Invalid output proposal" $ proposalOut #== expectedProposalOut + tcassert "Output proposal should be valid" $ proposalOut #== expectedProposalOut -- We validate the output stake datum here as well: We need the vote option -- to create a valid 'ProposalLock', however the vote option is encoded -- in the proposal redeemer, which is invisible for the stake validator. let stakeOutput = - mustBePJust # "Stake output not found" + mustBePJust # "Stake output should be present" #$ pfind # plam ( \(pfromData . (pfield @"value" #) -> value) -> diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index aaf114b..da9da7f 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -327,8 +327,6 @@ stakeValidator stake = $ \value address newStakeDatum' -> let isScriptAddress = pdata address #== ownAddress correctOutputDatum = pdata newStakeDatum' #== expectedDatum - -- TODO: Is this correct? I think We only need to ensure - -- correct amount of GT/SST in the continuing output. valueCorrect = pdata continuingValue #== pdata value in pif isScriptAddress From db92986c6d06e57cc1d5f5bfeb4f6224b4c1b696 Mon Sep 17 00:00:00 2001 From: fanghr Date: Fri, 20 May 2022 16:34:03 +0800 Subject: [PATCH 13/14] pull own output filtering out of the pmatch block --- agora/Agora/Proposal/Scripts.hs | 40 +++++++++++++++++++-------------- 1 file changed, 23 insertions(+), 17 deletions(-) diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 3fe0244..282ba26 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -186,6 +186,28 @@ proposalValidator proposal = currentTime <- tclet $ currentProposalTime # txInfoF.validRange + -- Filter out own output with own address and PST. + -- Delay the evaluation cause in some cases there won't be any continuing output. + ownOutputD <- + tclet $ + pdelay $ + mustBePJust # "Own output should be present" #$ pfind + # plam + ( \input -> unTermCont $ do + inputF <- tcont $ pletFields @'["address", "value"] input + pure $ + inputF.address #== ownAddress + #&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1 + ) + # pfromData txInfoF.outputs + + proposalOutD <- + tclet $ + pdelay $ + mustFindDatum' @PProposalDatum + # (pfield @"datumHash" # pforce ownOutputD) + # txInfoF.datums + pure $ pmatch proposalRedeemer $ \case PVote r -> unTermCont $ do @@ -228,22 +250,6 @@ proposalValidator proposal = ) # pfromData stakeInF.lockedBy - -- TODO: maybe we can move this outside of the pmatch block. - -- Filter out own output with own address and PST. - let ownOutput = - mustBePJust # "Own output should be present" #$ pfind - # plam - ( \input -> unTermCont $ do - inputF <- tcont $ pletFields @'["address", "value"] input - pure $ - inputF.address #== ownAddress - #&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1 - ) - # pfromData txInfoF.outputs - - proposalOut :: Term _ PProposalDatum - proposalOut = mustFindDatum' # (pfield @"datumHash" # ownOutput) # txInfoF.datums - let -- Update the vote counter of the proposal, and leave other stuff as is. expectedNewVotes = pmatch (pfromData proposalF.votes) $ \(PProposalVotes m) -> pcon $ @@ -268,7 +274,7 @@ proposalValidator proposal = .& #startingTime .= proposalF.startingTime ) - tcassert "Output proposal should be valid" $ proposalOut #== expectedProposalOut + tcassert "Output proposal should be valid" $ pforce proposalOutD #== expectedProposalOut -- We validate the output stake datum here as well: We need the vote option -- to create a valid 'ProposalLock', however the vote option is encoded From ccf56f58d1f367af79f081eeb2d842fe67b4f41a Mon Sep 17 00:00:00 2001 From: fanghr Date: Fri, 20 May 2022 17:09:22 +0800 Subject: [PATCH 14/14] add min ada to both stake input and output --- agora-sample/Sample/Proposal.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/agora-sample/Sample/Proposal.hs b/agora-sample/Sample/Proposal.hs index 8e00803..de52379 100644 --- a/agora-sample/Sample/Proposal.hs +++ b/agora-sample/Sample/Proposal.hs @@ -331,7 +331,12 @@ voteOnProposal params = stakeInput = TxOut { txOutAddress = stakeAddress - , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) params.voteCount + , txOutValue = + mconcat + [ sst + , Value.assetClassValue (untag stake.gtClassRef) params.voteCount + , minAda + ] , txOutDatumHash = Just $ toDatumHash stakeInputDatum } @@ -374,10 +379,6 @@ voteOnProposal params = stakeOutput = stakeInput { txOutDatumHash = Just $ toDatumHash stakeOutputDatum - -- We won't include the minimum Ada in the output value - -- due to how we check the output value in the stake validator. - -- The implementation is correct though, it should work in a - -- real on-chain environment. } ---