From a293f7acc3aa6012ab7f0d9e0f2b6cf8fdaea016 Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Sat, 2 Jul 2022 21:03:13 +0800 Subject: [PATCH 1/6] enable `-Wunused-do-bind` --- agora.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/agora.cabal b/agora.cabal index 73adc2a..d20cf60 100644 --- a/agora.cabal +++ b/agora.cabal @@ -16,7 +16,7 @@ common lang -Wno-unused-do-bind -Wno-partial-type-signatures -Wmissing-export-lists -Wincomplete-record-updates -Wmissing-deriving-strategies -Wno-name-shadowing -Wunused-foralls - -fprint-explicit-foralls -fprint-explicit-kinds + -fprint-explicit-foralls -fprint-explicit-kinds -Wunused-do-bind mixins: base hiding (Prelude), From 95410ce2542fec98361b124bdce7b76105dc70ab Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Tue, 28 Jun 2022 22:38:44 +0800 Subject: [PATCH 2/6] partially fix cosigning logic; improve performance --- agora/Agora/Proposal/Scripts.hs | 584 ++++++++++++++++++-------------- agora/Agora/Stake.hs | 79 +---- bench.csv | 38 +-- 3 files changed, 346 insertions(+), 355 deletions(-) diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index c15aefb..c9ebf9b 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -30,7 +30,6 @@ import Agora.Stake ( PProposalLock (..), PStakeDatum (..), PStakeUsage (..), - findStakeOwnedBy, pgetStakeUsage, ) import Agora.Utils ( @@ -39,25 +38,27 @@ import Agora.Utils ( mustFindDatum', ) import Plutarch.Api.V1 ( + PDatumHash, PMintingPolicy, PScriptContext (PScriptContext), PScriptPurpose (PMinting, PSpending), PTxInfo (PTxInfo), + PTxOut, PValidator, ) import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf) import Plutarch.Api.V1.ScriptContext ( pfindTxInByTxOutRef, pisTokenSpent, + ptryFindDatum, ptxSignedBy, - pvalueSpent, ) import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (psymbolValueOf) import Plutarch.Extra.Comonad (pextract) import Plutarch.Extra.IsData (pmatchEnum) -import Plutarch.Extra.List (pisUniqBy) +import Plutarch.Extra.List (pisUniqBy, pmapMaybe, pmsortBy) import Plutarch.Extra.Map (plookup, pupdate) -import Plutarch.Extra.Maybe (pisJust) +import Plutarch.Extra.Maybe (pfromDJust, pfromJust, pisJust) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.TermCont ( pguardC, @@ -193,7 +194,6 @@ proposalValidator proposal = let stCurrencySymbol = pconstant $ getMintingPolicySymbol (proposalPolicy proposal.governorSTAssetClass) - valueSpent <- pletC $ pvalueSpent # txInfoF.inputs signedBy <- pletC $ ptxSignedBy # txInfoF.signatories @@ -236,159 +236,93 @@ proposalValidator proposal = # txInfoF.datums proposalUnchanged <- pletC $ proposalOut #== proposalDatum + -------------------------------------------------------------------------- - -- Find the stake input and stake output by SST. + + -- Find the stake inputs/outputs by SST. let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass stakeSTAssetClass <- pletC $ passetClass # pconstant stakeSym # pconstant stakeTn - spentStakeST <- - pletC $ passetClassValueOf # valueSpent # stakeSTAssetClass - let stakeInput = - pfield @"resolved" - #$ mustBePJust - # "Stake input should be present" - #$ pfind - # plam - ( \(pfromData . (pfield @"value" #) . (pfield @"resolved" #) -> value) -> - passetClassValueOf # value # stakeSTAssetClass #== 1 + filterStakeDatumHash :: Term _ (PAsData PTxOut :--> PMaybe (PAsData PDatumHash)) <- + pletC $ + plam $ \(pfromData -> txOut) -> unTermCont $ do + txOutF <- pletFieldsC @'["value", "datumHash"] txOut + pure $ + pif + (passetClassValueOf # txOutF.value # stakeSTAssetClass #== 1) + ( let datumHash = pfromDJust # txOutF.datumHash + in pcon $ PJust $ pdata datumHash ) - # pfromData txInfoF.inputs + (pcon PNothing) - stakeIn <- pletC $ mustFindDatum' @PStakeDatum # (pfield @"datumHash" # stakeInput) # txInfoF.datums - stakeInF <- pletFieldsC @'["stakedAmount", "lockedBy", "owner"] stakeIn + stakeInputDatumHashes <- + pletC $ + pmapMaybe @PBuiltinList + # plam ((filterStakeDatumHash #) . (pfield @"resolved" #)) + # txInfoF.inputs - let stakeOutput = - mustBePJust # "Stake output should be present" - #$ pfind - # plam - ( \(pfromData . (pfield @"value" #) -> value) -> - passetClassValueOf # value # stakeSTAssetClass #== 1 - ) - # pfromData txInfoF.outputs + stakeOutputDatumHashes <- + pletC $ + pmapMaybe @PBuiltinList + # filterStakeDatumHash + # txInfoF.outputs - stakeOut <- pletC $ mustFindDatum' @PStakeDatum # (pfield @"datumHash" # stakeOutput) # txInfoF.datums + stakeInputNum <- pletC $ plength # stakeInputDatumHashes - stakeUnchanged <- pletC $ stakeIn #== stakeOut + pguardC "Every stake input should have a correspoding output" $ + stakeInputNum #== plength # stakeOutputDatumHashes -------------------------------------------------------------------------- pure $ pmatch proposalRedeemer $ \case - PVote r -> unTermCont $ do - pguardC "Input proposal must be in VotingReady state" $ - proposalF.status #== pconstant VotingReady - - pguardC "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 <- pmatchC proposalF.votes - voteFor <- pletC $ pfromData $ pfield @"resultTag" # r - - pguardC "Vote option should be valid" $ - pisJust #$ plookup # voteFor # voteMap - - -- Ensure that no lock with the current proposal id has been put on the stake. - pguardC "Same stake shouldn't vote on the same proposal twice" $ - pnot #$ pany - # plam - ( \((pfield @"proposalTag" #) . pfromData -> pid) -> - pid #== proposalF.proposalId - ) - # pfromData stakeInF.lockedBy - - let -- The amount of new votes should be the 'stakedAmount'. - -- 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 -> unTermCont $ do - PDiscrete v <- pmatchC stakeInF.stakedAmount - pure $ pcon $ PJust $ votes + (pextract # v) - ) - # voteFor - # m - expectedProposalOut = - mkRecordConstr - PProposalDatum - ( #proposalId .= proposalF.proposalId - .& #effects .= proposalF.effects - .& #status .= proposalF.status - .& #cosigners .= proposalF.cosigners - .& #thresholds .= proposalF.thresholds - .& #votes .= pdata expectedNewVotes - .& #timingConfig .= proposalF.timingConfig - .& #startingTime .= proposalF.startingTime - ) - - pguardC "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 newProposalLock = - mkRecordConstr - PProposalLock - ( #vote .= pdata voteFor - .& #proposalTag .= proposalF.proposalId - ) - -- Prepend the new lock to existing locks - expectedProposalLocks = - pcons - # pdata newProposalLock - # pfromData stakeInF.lockedBy - expectedStakeOut = - mkRecordConstr - PStakeDatum - ( #stakedAmount .= stakeInF.stakedAmount - .& #owner .= stakeInF.owner - .& #lockedBy .= pdata expectedProposalLocks - ) - - pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut - - pure $ popaque (pconstant ()) - -------------------------------------------------------------------------- PCosign r -> unTermCont $ do - pguardC "Stake should not change" stakeUnchanged + pguardC "Should be in draft state" $ + proposalF.status #== pconstant Draft newSigs <- pletC $ pfield @"newCosigners" # r - pguardC "Cosigners are unique" $ - pisUniqBy - # phoistAcyclic (plam (#==)) - # phoistAcyclic (plam $ \(pfromData -> x) (pfromData -> y) -> x #< y) - # newSigs - pguardC "Signed by all new cosigners" $ pall # signedBy # newSigs - pguardC "As many new cosigners as Stake datums" $ - spentStakeST #== plength # newSigs + pguardC "As many new cosigners as stake datums" $ + plength # stakeInputDatumHashes #== plength # newSigs + + updatedSigs <- pletC $ pconcat # newSigs # proposalF.cosigners + + -- Cannot cosign a proposal with a single stake more than once. + pguardC "Cosigners are unique" $ + pisUniqBy + # phoistAcyclic (plam (#==)) + # phoistAcyclic + ( plam + ( \(pfromData -> x) + (pfromData -> y) -> x #< y + ) + ) + # updatedSigs + + let inputStakeOwners = + pmap + # plam + ( \(pfromData -> dh) -> + pfield @"owner" + #$ pfromJust + #$ ptryFindDatum + @(PAsData PStakeDatum) + # dh + # txInfoF.datums + ) + # stakeInputDatumHashes pguardC "All new cosigners are witnessed by their Stake datums" $ pall - # plam - ( \sig -> - pmatch - ( findStakeOwnedBy # stakeSTAssetClass - # pfromData sig - # txInfoF.datums - # txInfoF.inputs - ) - $ \case - PNothing -> pcon PFalse - PJust _ -> pcon PTrue - ) + # plam (\sig -> pelem # sig # inputStakeOwners) # newSigs - let updatedSigs = pconcat # newSigs # proposalF.cosigners - expectedDatum = + let expectedDatum = mkRecordConstr PProposalDatum ( #proposalId .= proposalF.proposalId @@ -404,47 +338,97 @@ proposalValidator proposal = pguardC "Signatures are correctly added to cosignature list" $ proposalOut #== expectedDatum + -- The following code ensures that all the stake datums are not + -- changed. + -- + -- TODO: This is quite inefficient (O(nlogn)) but for now we don't + -- have a nice way to check this. In plutus v2 we'll have map of + -- (Script -> Redeemer) in ScriptContext, which should be the + -- straight up solution. + let sortDatumHashes = + phoistAcyclic $ + pmsortBy + # phoistAcyclic + ( plam + ( \(pfromData -> l) + (pfromData -> r) -> l #< r + ) + ) + + sortedStakeInputDatumHashes = + sortDatumHashes # stakeInputDatumHashes + + sortedStakeOutputDatumHashes = + sortDatumHashes # stakeOutputDatumHashes + + pguardC "All stake datum are unchanged" $ + plistEquals + # sortedStakeInputDatumHashes + # sortedStakeOutputDatumHashes + pure $ popaque (pconstant ()) - -------------------------------------------------------------------------- - PUnlock r -> unTermCont $ do - -- At draft stage, the votes should be empty. - pguardC "Shouldn't retract votes from a draft proposal" $ - pnot #$ proposalF.status #== pconstantData Draft - -- This is the vote option we're retracting from. - retractFrom <- pletC $ pfield @"resultTag" # r + ------------------------------------------------------------------------ + _ -> unTermCont $ do + pguardC "Can only deal with one stake" $ + stakeInputNum #== 1 - -- Determine if the input stake is actually locked by this proposal. - stakeUsage <- pletC $ pgetStakeUsage # stakeInF.lockedBy # proposalF.proposalId + let stakeInputHash = pfromData $ phead # stakeInputDatumHashes + stakeOutputHash = pfromData $ phead # stakeOutputDatumHashes - pguardC "Stake input relevant" $ - pmatch stakeUsage $ \case - PDidNothing -> - ptraceIfFalse "Stake should be relevant" $ - pconstant False - PCreated -> - ptraceIfFalse "Removing creator's locks means status is Finished" $ - proposalF.status #== pconstantData Finished - PVotedFor rt -> - ptraceIfFalse "Result tag should match the one given in the redeemer" $ - rt #== retractFrom - - -- The count of removing votes is equal to the 'stakeAmount' of input stake. - retractCount <- + stakeIn :: Term _ PStakeDatum <- pletC $ - pmatch stakeInF.stakedAmount $ \(PDiscrete v) -> pextract # v + pfromData $ + pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums + stakeInF <- pletFieldsC @'["stakedAmount", "lockedBy", "owner"] stakeIn - -- The votes can only change when the proposal still allows voting. - let shouldUpdateVotes = - proposalF.status #== pconstantData VotingReady - #&& pnot # (pcon PCreated #== stakeUsage) + stakeOut :: Term _ PStakeDatum <- + pletC $ + pfromData $ + pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums - pguardC "Proposal output correct" $ - pif - shouldUpdateVotes - ( let -- Remove votes and leave other parts of the proposal as it. - expectedVotes = pretractVotes # retractFrom # retractCount # proposalF.votes + ---------------------------------------------------------------------- + pure $ + pmatch proposalRedeemer $ \case + PVote r -> unTermCont $ do + pguardC "Input proposal must be in VotingReady state" $ + proposalF.status #== pconstant VotingReady + + pguardC "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 <- pmatchC proposalF.votes + voteFor <- pletC $ pfromData $ pfield @"resultTag" # r + + pguardC "Vote option should be valid" $ + pisJust #$ plookup # voteFor # voteMap + + -- Ensure that no lock with the current proposal id has been put on the stake. + pguardC "Same stake shouldn't vote on the same proposal twice" $ + pnot #$ pany + # plam + ( \((pfield @"proposalTag" #) . pfromData -> pid) -> + pid #== proposalF.proposalId + ) + # pfromData stakeInF.lockedBy + + let -- The amount of new votes should be the 'stakedAmount'. + -- 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 -> unTermCont $ do + PDiscrete v <- pmatchC stakeInF.stakedAmount + pure $ pcon $ PJust $ votes + (pextract # v) + ) + # voteFor + # m expectedProposalOut = mkRecordConstr PProposalDatum @@ -453,122 +437,206 @@ proposalValidator proposal = .& #status .= proposalF.status .& #cosigners .= proposalF.cosigners .& #thresholds .= proposalF.thresholds - .& #votes .= pdata expectedVotes + .& #votes .= pdata expectedNewVotes .& #timingConfig .= proposalF.timingConfig .& #startingTime .= proposalF.startingTime ) - in ptraceIfFalse "Update votes" $ - expectedProposalOut #== proposalOut - ) - -- No change to the proposal is allowed. - $ ptraceIfFalse "Proposal unchanged" proposalUnchanged - -- At last, we ensure that all locks belong to this proposal will be removed. - stakeOutputLocks <- pletC $ pfield @"lockedBy" # stakeOut + pguardC "Output proposal should be valid" $ proposalOut #== expectedProposalOut - let templateStakeOut = - mkRecordConstr - PStakeDatum - ( #stakedAmount .= stakeInF.stakedAmount - .& #owner .= stakeInF.owner - .& #lockedBy .= stakeOutputLocks - ) + -- 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. - pguardC "Only locks updated in the output stake" $ - templateStakeOut #== stakeOut + let newProposalLock = + mkRecordConstr + PProposalLock + ( #vote .= pdata voteFor + .& #proposalTag .= proposalF.proposalId + ) + -- Prepend the new lock to existing locks + expectedProposalLocks = + pcons + # pdata newProposalLock + # pfromData stakeInF.lockedBy + expectedStakeOut = + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeInF.stakedAmount + .& #owner .= stakeInF.owner + .& #lockedBy .= pdata expectedProposalLocks + ) - pguardC "All relevant locks removed from the stake" $ - pgetStakeUsage # pfromData stakeOutputLocks - # proposalF.proposalId #== pcon PDidNothing + pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut - pure $ popaque (pconstant ()) - -------------------------------------------------------------------------- - PAdvanceProposal _r -> unTermCont $ do - pguardC "Stake should not change" stakeUnchanged + pure $ popaque (pconstant ()) + -------------------------------------------------------------------------- - proposalOutStatus <- pletC $ pfield @"status" # proposalOut + PUnlock r -> unTermCont $ do + -- At draft stage, the votes should be empty. + pguardC "Shouldn't retract votes from a draft proposal" $ + pnot #$ proposalF.status #== pconstantData Draft - let -- Only the status of proposals should be updated in this case. - templateProposalOut = - mkRecordConstr - PProposalDatum - ( #proposalId .= proposalF.proposalId - .& #effects .= proposalF.effects - .& #status .= proposalOutStatus - .& #cosigners .= proposalF.cosigners - .& #thresholds .= proposalF.thresholds - .& #votes .= proposalF.votes - .& #timingConfig .= proposalF.timingConfig - .& #startingTime .= proposalF.startingTime - ) + -- This is the vote option we're retracting from. + retractFrom <- pletC $ pfield @"resultTag" # r - pguardC "Only status changes in the output proposal" $ - templateProposalOut #== proposalOut + -- Determine if the input stake is actually locked by this proposal. + stakeUsage <- pletC $ pgetStakeUsage # stakeInF.lockedBy # proposalF.proposalId - inDraftPeriod <- pletC $ isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime - inVotingPeriod <- pletC $ isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime - inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime - inExecutionPeriod <- pletC $ isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime + pguardC "Stake input relevant" $ + pmatch stakeUsage $ \case + PDidNothing -> + ptraceIfFalse "Stake should be relevant" $ + pconstant False + PCreated -> + ptraceIfFalse "Removing creator's locks means status is Finished" $ + proposalF.status #== pconstantData Finished + PVotedFor rt -> + ptraceIfFalse "Result tag should match the one given in the redeemer" $ + rt #== retractFrom - proposalStatus <- pletC $ pto $ pfromData proposalF.status + -- The count of removing votes is equal to the 'stakeAmount' of input stake. + retractCount <- + pletC $ + pmatch stakeInF.stakedAmount $ \(PDiscrete v) -> pextract # v - -- Check the timings. - let isFinished = proposalF.status #== pconstantData Finished + -- The votes can only change when the proposal still allows voting. + let shouldUpdateVotes = + proposalF.status #== pconstantData VotingReady + #&& pnot # (pcon PCreated #== stakeUsage) - notTooLate = pmatchEnum proposalStatus $ \case - Draft -> inDraftPeriod - -- Can only advance after the voting period is over. - VotingReady -> inLockedPeriod - Locked -> inExecutionPeriod - _ -> pconstant False + pguardC "Proposal output correct" $ + pif + shouldUpdateVotes + ( let -- Remove votes and leave other parts of the proposal as it. + expectedVotes = pretractVotes # retractFrom # retractCount # proposalF.votes - notTooEarly = pmatchEnum (pto $ pfromData proposalF.status) $ \case - VotingReady -> pnot # inVotingPeriod - Locked -> pnot # inLockedPeriod - _ -> pconstant True + expectedProposalOut = + mkRecordConstr + PProposalDatum + ( #proposalId .= proposalF.proposalId + .& #effects .= proposalF.effects + .& #status .= proposalF.status + .& #cosigners .= proposalF.cosigners + .& #thresholds .= proposalF.thresholds + .& #votes .= pdata expectedVotes + .& #timingConfig .= proposalF.timingConfig + .& #startingTime .= proposalF.startingTime + ) + in ptraceIfFalse "Update votes" $ + expectedProposalOut #== proposalOut + ) + -- No change to the proposal is allowed. + $ ptraceIfFalse "Proposal unchanged" proposalUnchanged - pguardC "Cannot advance ahead of time" notTooEarly - pguardC "Finished proposals cannot be advanced" $ pnot # isFinished + -- At last, we ensure that all locks belong to this proposal will be removed. + stakeOutputLocks <- pletC $ pfield @"lockedBy" # stakeOut - thresholdsF <- pletFieldsC @'["execute"] proposalF.thresholds + let templateStakeOut = + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeInF.stakedAmount + .& #owner .= stakeInF.owner + .& #lockedBy .= stakeOutputLocks + ) - pure $ - pif - notTooLate - -- On time: advance to next status. - ( pmatchEnum proposalStatus $ \case - Draft -> unTermCont $ do - -- TODO: Perform other necessary checks. + pguardC "Only locks updated in the output stake" $ + templateStakeOut #== stakeOut - -- 'Draft' -> 'VotingReady' - pguardC "Proposal status set to VotingReady" $ - proposalOutStatus #== pconstantData VotingReady + pguardC "All relevant locks removed from the stake" $ + pgetStakeUsage # pfromData stakeOutputLocks + # proposalF.proposalId #== pcon PDidNothing - pure $ popaque (pconstant ()) - VotingReady -> unTermCont $ do - -- 'VotingReady' -> 'Locked' - pguardC "Proposal status set to Locked" $ - proposalOutStatus #== pconstantData Locked + pure $ popaque (pconstant ()) + ------------------------------------------------------------------ + PAdvanceProposal _ -> unTermCont $ do + pguardC "Stake should not change" $ + stakeInputHash #== stakeOutputHash - pguardC "Winner outcome not found" $ - pisJust #$ pwinner' # proposalF.votes - #$ punsafeCoerce - $ pfromData thresholdsF.execute + proposalOutStatus <- pletC $ pfield @"status" # proposalOut - pure $ popaque (pconstant ()) - Locked -> unTermCont $ do - -- 'Locked' -> 'Finished' - pguardC "Proposal status set to Finished" $ - proposalOutStatus #== pconstantData Finished + let -- Only the status of proposals should be updated in this case. + templateProposalOut = + mkRecordConstr + PProposalDatum + ( #proposalId .= proposalF.proposalId + .& #effects .= proposalF.effects + .& #status .= proposalOutStatus + .& #cosigners .= proposalF.cosigners + .& #thresholds .= proposalF.thresholds + .& #votes .= proposalF.votes + .& #timingConfig .= proposalF.timingConfig + .& #startingTime .= proposalF.startingTime + ) - -- TODO: Perform other necessary checks. - pure $ popaque (pconstant ()) - _ -> popaque (pconstant ()) - ) - -- Too late: failed proposal, status set to 'Finished'. - ( popaque $ - ptraceIfFalse "Proposal should fail: not on time" $ - proposalOutStatus #== pconstantData Finished - -- TODO: Should check that the GST is not moved - -- if the proposal is in 'Locked' state. - ) + pguardC "Only status changes in the output proposal" $ + templateProposalOut #== proposalOut + + inDraftPeriod <- pletC $ isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime + inVotingPeriod <- pletC $ isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime + inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime + inExecutionPeriod <- pletC $ isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime + + proposalStatus <- pletC $ pto $ pfromData proposalF.status + + -- Check the timings. + let isFinished = proposalF.status #== pconstantData Finished + + notTooLate = pmatchEnum proposalStatus $ \case + Draft -> inDraftPeriod + -- Can only advance after the voting period is over. + VotingReady -> inLockedPeriod + Locked -> inExecutionPeriod + _ -> pconstant False + + notTooEarly = pmatchEnum (pto $ pfromData proposalF.status) $ \case + VotingReady -> pnot # inVotingPeriod + Locked -> pnot # inLockedPeriod + _ -> pconstant True + + pguardC "Cannot advance ahead of time" notTooEarly + pguardC "Finished proposals cannot be advanced" $ pnot # isFinished + + thresholdsF <- pletFieldsC @'["execute"] proposalF.thresholds + + pure $ + pif + notTooLate + -- On time: advance to next status. + ( pmatchEnum proposalStatus $ \case + Draft -> unTermCont $ do + -- TODO: Perform other necessary checks. + + -- 'Draft' -> 'VotingReady' + pguardC "Proposal status set to VotingReady" $ + proposalOutStatus #== pconstantData VotingReady + + pure $ popaque (pconstant ()) + VotingReady -> unTermCont $ do + -- 'VotingReady' -> 'Locked' + pguardC "Proposal status set to Locked" $ + proposalOutStatus #== pconstantData Locked + + pguardC "Winner outcome not found" $ + pisJust #$ pwinner' # proposalF.votes + #$ punsafeCoerce + $ pfromData thresholdsF.execute + + pure $ popaque (pconstant ()) + Locked -> unTermCont $ do + -- 'Locked' -> 'Finished' + pguardC "Proposal status set to Finished" $ + proposalOutStatus #== pconstantData Finished + + -- TODO: Perform other necessary checks. + pure $ popaque (pconstant ()) + _ -> popaque (pconstant ()) + ) + -- Too late: failed proposal, status set to 'Finished'. + ( popaque $ + ptraceIfFalse "Proposal should fail: not on time" $ + proposalOutStatus #== pconstantData Finished + -- TODO: Should check that the GST is not moved + -- if the proposal is in 'Locked' state. + ) + _ -> popaque (pconstant ()) diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index a4fded9..b5f5e16 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -22,7 +22,6 @@ module Agora.Stake ( -- * Utility functions stakeLocked, - findStakeOwnedBy, pgetStakeUsage, ) where @@ -33,16 +32,8 @@ import Data.Tagged (Tagged (..)) import GHC.Generics qualified as GHC import Generics.SOP (Generic, HasDatatypeInfo, I (I)) import Plutarch.Api.V1 ( - PDatum, - PDatumHash, - PMaybeData (PDJust, PDNothing), PPubKeyHash, - PTuple, - PTxInInfo (PTxInInfo), - PTxOut (PTxOut), ) -import Plutarch.Api.V1.AssetClass (PAssetClass, passetClassValueOf) -import Plutarch.Api.V1.ScriptContext (ptryFindDatum) import Plutarch.DataRepr ( DerivePConstantViaData (..), PDataFields, @@ -54,8 +45,7 @@ import Plutarch.Extra.IsData ( ) import Plutarch.Extra.List (pmapMaybe, pnotNull) import Plutarch.Extra.Other (DerivePNewtype' (..)) -import Plutarch.Extra.TermCont (pletC, pletFieldsC, pmatchC) -import Plutarch.Internal (punsafeCoerce) +import Plutarch.Extra.TermCont (pletFieldsC) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.SafeMoney (PDiscrete) import PlutusLedgerApi.V1 (PubKeyHash) @@ -327,73 +317,6 @@ stakeLocked = phoistAcyclic $ locks = pfield @"lockedBy" # stakeDatum in pnotNull # locks -{- | Find a stake owned by a particular PK. - - @since 0.1.0 --} -findStakeOwnedBy :: - Term - s - ( PAssetClass - :--> PPubKeyHash - :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) - :--> PBuiltinList (PAsData PTxInInfo) - :--> PMaybe (PAsData PStakeDatum) - ) -findStakeOwnedBy = phoistAcyclic $ - plam $ \ac pk datums inputs -> - pmatch (pfind # (isInputStakeOwnedBy # ac # pk # datums) # inputs) $ \case - PNothing -> pcon PNothing - PJust (pfromData -> v) -> unTermCont $ do - let txOut = pfield @"resolved" # pto v - txOutF <- pletFieldsC @'["datumHash"] $ txOut - pure $ - pmatch txOutF.datumHash $ \case - PDNothing _ -> pcon PNothing - PDJust ((pfield @"_0" #) -> dh) -> - ptryFindDatum @(PAsData PStakeDatum) # dh # datums - -{- | Check if a StakeDatum is owned by a particular public key. - - @since 0.1.0 --} -stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool) -stakeDatumOwnedBy = - phoistAcyclic $ - plam $ \pk stakeDatum -> - pletFields @'["owner"] (pto stakeDatum) $ \stakeDatumF -> - stakeDatumF.owner #== pdata pk - -{- | Does the input have a `Stake` owned by a particular PK? - - @since 0.1.0 --} -isInputStakeOwnedBy :: - Term - _ - ( PAssetClass :--> PPubKeyHash - :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) - :--> PAsData PTxInInfo - :--> PBool - ) -isInputStakeOwnedBy = - plam $ \ac ss datums txInInfo' -> unTermCont $ do - PTxInInfo ((pfield @"resolved" #) -> txOut) <- pmatchC $ pfromData txInInfo' - PTxOut txOut' <- pmatchC txOut - txOutF <- pletFieldsC @'["value", "datumHash"] txOut' - outStakeST <- pletC $ passetClassValueOf # txOutF.value # ac - pure $ - pmatch txOutF.datumHash $ \case - PDNothing _ -> pcon PFalse - PDJust ((pfield @"_0" #) -> datumHash) -> - pif - (outStakeST #== 1) - ( pmatch (ptryFindDatum @(PAsData PStakeDatum) # datumHash # datums) $ \case - PNothing -> pcon PFalse - PJust v -> stakeDatumOwnedBy # ss # pfromData (punsafeCoerce v) - ) - (pcon PFalse) - {- | Represent the usage of a stake on a particular proposal. A stake can be used to either create or vote on a proposal. diff --git a/bench.csv b/bench.csv index c8b0da0..e5bdec1 100644 --- a/bench.csv +++ b/bench.csv @@ -8,24 +8,24 @@ Agora/Stake/policy/stakeCreation,50939580,148729,2387 Agora/Stake/validator/stakeDepositWithdraw deposit,181581435,493259,4413 Agora/Stake/validator/stakeDepositWithdraw withdraw,181581435,493259,4401 Agora/Proposal/policy/proposalCreation,23140177,69194,1515 -Agora/Proposal/validator/cosignature/proposal,312261341,886430,8188 -Agora/Proposal/validator/cosignature/stake,125315872,312659,4942 -Agora/Proposal/validator/voting/proposal,268025219,751750,8106 -Agora/Proposal/validator/voting/stake,120122971,320497,4899 -Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,263397893,738746,8013 -Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,278686368,780686,8022 -Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,267078383,746859,8022 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished,262901404,737844,8015 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished,264319938,741149,8016 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished,265450916,743553,8016 -"Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady",276198245,772878,8066 -"Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished",246477596,697110,8068 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished",242771264,688789,8070 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked",242771264,688789,8070 -"Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady",2814657239,7934307,29173 -"Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished",2488302451,7053012,29357 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished",2379658464,6713247,29341 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked",2379658464,6713247,29341 +Agora/Proposal/validator/cosignature/proposal,242933842,689669,8224 +Agora/Proposal/validator/cosignature/stake,124072228,314923,4942 +Agora/Proposal/validator/voting/proposal,236945537,666233,8142 +Agora/Proposal/validator/voting/stake,131045998,349073,4899 +Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,237984765,667020,8049 +Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,253273240,708960,8058 +Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,241665255,675133,8058 +Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished,237488276,666118,8051 +Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished,238906810,669423,8052 +Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished,240037788,671827,8052 +"Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady",240815652,676043,8102 +"Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished",211095003,600275,8104 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished",207388671,591954,8106 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked",207388671,591954,8106 +"Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady",1770480224,5186822,29209 +"Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished",1444125436,4305527,29393 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished",1335481449,3965762,29377 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked",1335481449,3965762,29377 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,806 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 Agora/Treasury/Validator/Positive/Allows for effect changes,31556709,81546,1452 @@ -33,5 +33,5 @@ Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,80 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 Agora/Governor/policy/GST minting,51007235,144191,2034 Agora/Governor/validator/proposal creation,309689999,834675,9064 -Agora/Governor/validator/GATs minting,418560845,1137908,9187 +Agora/Governor/validator/GATs minting,421016677,1141838,9187 Agora/Governor/validator/mutate governor state,88986020,248491,8662 From ae0e78976a944ff953fc02e9ce7f805ac5a496d8 Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Sat, 2 Jul 2022 18:46:14 +0800 Subject: [PATCH 3/6] check cosign stakes while advancing from draft --- agora/Agora/Proposal.hs | 6 +- agora/Agora/Proposal/Scripts.hs | 699 +++++++++++++++++--------------- agora/Agora/Utils.hs | 48 +++ bench.csv | 38 +- 4 files changed, 445 insertions(+), 346 deletions(-) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 7f5ea2a..922c3ac 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -283,6 +283,8 @@ data ProposalDatum = ProposalDatum -- ^ The status the proposal is in. , cosigners :: [PubKeyHash] -- ^ Who created the proposal initially, and who cosigned it later. + -- + -- This list should be sorted in **ascending** order. , thresholds :: ProposalThresholds -- ^ Thresholds copied over on initialization. , votes :: ProposalVotes @@ -321,7 +323,9 @@ data ProposalRedeemer -- -- This is particularly used in the 'Draft' 'ProposalStatus', -- where matching 'Agora.Stake.Stake's can be called to advance the proposal, - -- provided enough GT is shared among them. + -- provided enough GT is shared among them. + -- + -- This list should be sorted in ascending order. Cosign [PubKeyHash] | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'. Unlock ResultTag diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index c9ebf9b..d31646a 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -36,6 +36,8 @@ import Agora.Utils ( getMintingPolicySymbol, mustBePJust, mustFindDatum', + pisUniq', + pltAsData, ) import Plutarch.Api.V1 ( PDatumHash, @@ -56,7 +58,7 @@ import Plutarch.Api.V1.ScriptContext ( import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (psymbolValueOf) import Plutarch.Extra.Comonad (pextract) import Plutarch.Extra.IsData (pmatchEnum) -import Plutarch.Extra.List (pisUniqBy, pmapMaybe, pmsortBy) +import Plutarch.Extra.List (pmapMaybe, pmergeBy, pmsortBy) import Plutarch.Extra.Map (plookup, pupdate) import Plutarch.Extra.Maybe (pfromDJust, pfromJust, pisJust) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) @@ -192,6 +194,10 @@ proposalValidator proposal = ownAddress <- pletC $ txOutF.address + thresholdsF <- pletFieldsC @'["execute", "create", "vote"] proposalF.thresholds + + currentStatus <- pletC $ pfromData $ proposalF.status + let stCurrencySymbol = pconstant $ getMintingPolicySymbol (proposalPolicy proposal.governorSTAssetClass) @@ -237,6 +243,29 @@ proposalValidator proposal = proposalUnchanged <- pletC $ proposalOut #== proposalDatum + proposalOutStatus <- + pletC $ + pfromData $ + pfield @"status" # proposalOut + + onlyStatusChanged <- + pletC $ + -- Only the status of proposals is updated. + + -- Only the status of proposals is updated. + proposalOut + #== mkRecordConstr + PProposalDatum + ( #proposalId .= proposalF.proposalId + .& #effects .= proposalF.effects + .& #status .= pdata proposalOutStatus + .& #cosigners .= proposalF.cosigners + .& #thresholds .= proposalF.thresholds + .& #votes .= proposalF.votes + .& #timingConfig .= proposalF.timingConfig + .& #startingTime .= proposalF.startingTime + ) + -------------------------------------------------------------------------- -- Find the stake inputs/outputs by SST. @@ -274,369 +303,387 @@ proposalValidator proposal = pguardC "Every stake input should have a correspoding output" $ stakeInputNum #== plength # stakeOutputDatumHashes - -------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + + let acceptMultipleStakes = pmatch proposalRedeemer $ \case + PCosign _ -> pconstant True + PAdvanceProposal _ -> + currentStatus #== pconstant Draft + _ -> pconstant False pure $ - pmatch proposalRedeemer $ \case - PCosign r -> unTermCont $ do - pguardC "Should be in draft state" $ - proposalF.status #== pconstant Draft + popaque $ + pif + acceptMultipleStakes + ( unTermCont $ do + -- The following code ensures that all the stake datums are not + -- changed. + -- + -- TODO: This is quite inefficient (O(nlogn)) but for now we don't + -- have a nice way to check this. In plutus v2 we'll have map of + -- (Script -> Redeemer) in ScriptContext, which should be the + -- straight up solution. + let sortDatumHashes = phoistAcyclic $ pmsortBy # pltAsData - newSigs <- pletC $ pfield @"newCosigners" # r + sortedStakeInputDatumHashes = + sortDatumHashes # stakeInputDatumHashes - pguardC "Signed by all new cosigners" $ - pall # signedBy # newSigs + sortedStakeOutputDatumHashes = + sortDatumHashes # stakeOutputDatumHashes - pguardC "As many new cosigners as stake datums" $ - plength # stakeInputDatumHashes #== plength # newSigs + pguardC "All stake datum are unchanged" $ + plistEquals + # sortedStakeInputDatumHashes + # sortedStakeOutputDatumHashes - updatedSigs <- pletC $ pconcat # newSigs # proposalF.cosigners - - -- Cannot cosign a proposal with a single stake more than once. - pguardC "Cosigners are unique" $ - pisUniqBy - # phoistAcyclic (plam (#==)) - # phoistAcyclic - ( plam - ( \(pfromData -> x) - (pfromData -> y) -> x #< y - ) - ) - # updatedSigs - - let inputStakeOwners = - pmap - # plam - ( \(pfromData -> dh) -> - pfield @"owner" - #$ pfromJust - #$ ptryFindDatum - @(PAsData PStakeDatum) - # dh - # txInfoF.datums - ) - # stakeInputDatumHashes - - pguardC "All new cosigners are witnessed by their Stake datums" $ - pall - # plam (\sig -> pelem # sig # inputStakeOwners) - # newSigs - - let expectedDatum = - mkRecordConstr - PProposalDatum - ( #proposalId .= proposalF.proposalId - .& #effects .= proposalF.effects - .& #status .= proposalF.status - .& #cosigners .= pdata updatedSigs - .& #thresholds .= proposalF.thresholds - .& #votes .= proposalF.votes - .& #timingConfig .= proposalF.timingConfig - .& #startingTime .= proposalF.startingTime - ) - - pguardC "Signatures are correctly added to cosignature list" $ - proposalOut #== expectedDatum - - -- The following code ensures that all the stake datums are not - -- changed. - -- - -- TODO: This is quite inefficient (O(nlogn)) but for now we don't - -- have a nice way to check this. In plutus v2 we'll have map of - -- (Script -> Redeemer) in ScriptContext, which should be the - -- straight up solution. - let sortDatumHashes = - phoistAcyclic $ - pmsortBy - # phoistAcyclic - ( plam - ( \(pfromData -> l) - (pfromData -> r) -> l #< r - ) - ) - - sortedStakeInputDatumHashes = - sortDatumHashes # stakeInputDatumHashes - - sortedStakeOutputDatumHashes = - sortDatumHashes # stakeOutputDatumHashes - - pguardC "All stake datum are unchanged" $ - plistEquals - # sortedStakeInputDatumHashes - # sortedStakeOutputDatumHashes - - pure $ popaque (pconstant ()) - - ------------------------------------------------------------------------ - _ -> unTermCont $ do - pguardC "Can only deal with one stake" $ - stakeInputNum #== 1 - - let stakeInputHash = pfromData $ phead # stakeInputDatumHashes - stakeOutputHash = pfromData $ phead # stakeOutputDatumHashes - - stakeIn :: Term _ PStakeDatum <- - pletC $ - pfromData $ - pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums - stakeInF <- pletFieldsC @'["stakedAmount", "lockedBy", "owner"] stakeIn - - stakeOut :: Term _ PStakeDatum <- - pletC $ - pfromData $ - pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums - - ---------------------------------------------------------------------- - - pure $ - pmatch proposalRedeemer $ \case - PVote r -> unTermCont $ do - pguardC "Input proposal must be in VotingReady state" $ - proposalF.status #== pconstant VotingReady - - pguardC "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 <- pmatchC proposalF.votes - voteFor <- pletC $ pfromData $ pfield @"resultTag" # r - - pguardC "Vote option should be valid" $ - pisJust #$ plookup # voteFor # voteMap - - -- Ensure that no lock with the current proposal id has been put on the stake. - pguardC "Same stake shouldn't vote on the same proposal twice" $ - pnot #$ pany + PPair totalStakedAmount stakeOwners <- + pmatchC $ + pfoldl # plam - ( \((pfield @"proposalTag" #) . pfromData -> pid) -> - pid #== proposalF.proposalId + ( \l dh -> unTermCont $ do + let stake = + pfromData $ + pfromJust + #$ ptryFindDatum + @(PAsData PStakeDatum) + # pfromData dh + # txInfoF.datums + + stakeF <- pletFieldsC @'["stakedAmount", "owner"] stake + + PPair amount owners <- pmatchC l + + let newAmount = amount + punsafeCoerce (pfromData stakeF.stakedAmount) + updatedOwners = pcons # stakeF.owner # owners + + pure $ pcon $ PPair newAmount updatedOwners ) - # pfromData stakeInF.lockedBy + # pcon (PPair (0 :: Term _ PInteger) (pnil @PBuiltinList)) + # stakeInputDatumHashes - let -- The amount of new votes should be the 'stakedAmount'. - -- 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 -> unTermCont $ do - PDiscrete v <- pmatchC stakeInF.stakedAmount - pure $ pcon $ PJust $ votes + (pextract # v) - ) - # voteFor - # m - expectedProposalOut = - mkRecordConstr - PProposalDatum - ( #proposalId .= proposalF.proposalId - .& #effects .= proposalF.effects - .& #status .= proposalF.status - .& #cosigners .= proposalF.cosigners - .& #thresholds .= proposalF.thresholds - .& #votes .= pdata expectedNewVotes - .& #timingConfig .= proposalF.timingConfig - .& #startingTime .= proposalF.startingTime - ) + sortedStakeOwners <- pletC $ pmsortBy # pltAsData # stakeOwners - pguardC "Output proposal should be valid" $ proposalOut #== expectedProposalOut + redeemer <- pmatchC proposalRedeemer - -- 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. + case redeemer of + PCosign r -> do + pguardC "Should be in draft state" $ + currentStatus #== pconstant Draft - let newProposalLock = - mkRecordConstr - PProposalLock - ( #vote .= pdata voteFor - .& #proposalTag .= proposalF.proposalId - ) - -- Prepend the new lock to existing locks - expectedProposalLocks = - pcons - # pdata newProposalLock - # pfromData stakeInF.lockedBy - expectedStakeOut = - mkRecordConstr - PStakeDatum - ( #stakedAmount .= stakeInF.stakedAmount - .& #owner .= stakeInF.owner - .& #lockedBy .= pdata expectedProposalLocks - ) + newSigs <- pletC $ pfield @"newCosigners" # r - pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut + pguardC "Signed by all new cosigners" $ + pall # signedBy # newSigs - pure $ popaque (pconstant ()) - -------------------------------------------------------------------------- + updatedSigs <- + pletC $ + pmergeBy # pltAsData + # newSigs + # proposalF.cosigners - PUnlock r -> unTermCont $ do - -- At draft stage, the votes should be empty. - pguardC "Shouldn't retract votes from a draft proposal" $ - pnot #$ proposalF.status #== pconstantData Draft + pguardC "Cosigners are unique" $ + pisUniq' # updatedSigs - -- This is the vote option we're retracting from. - retractFrom <- pletC $ pfield @"resultTag" # r + pguardC "All new cosigners are witnessed by their Stake datums" $ + plistEquals # sortedStakeOwners # newSigs - -- Determine if the input stake is actually locked by this proposal. - stakeUsage <- pletC $ pgetStakeUsage # stakeInF.lockedBy # proposalF.proposalId + let expectedDatum = + mkRecordConstr + PProposalDatum + ( #proposalId .= proposalF.proposalId + .& #effects .= proposalF.effects + .& #status .= proposalF.status + .& #cosigners .= pdata updatedSigs + .& #thresholds .= proposalF.thresholds + .& #votes .= proposalF.votes + .& #timingConfig .= proposalF.timingConfig + .& #startingTime .= proposalF.startingTime + ) - pguardC "Stake input relevant" $ - pmatch stakeUsage $ \case - PDidNothing -> - ptraceIfFalse "Stake should be relevant" $ - pconstant False - PCreated -> - ptraceIfFalse "Removing creator's locks means status is Finished" $ - proposalF.status #== pconstantData Finished - PVotedFor rt -> - ptraceIfFalse "Result tag should match the one given in the redeemer" $ - rt #== retractFrom + pguardC "Signatures are correctly added to cosignature list" $ + proposalOut #== expectedDatum - -- The count of removing votes is equal to the 'stakeAmount' of input stake. - retractCount <- - pletC $ - pmatch stakeInF.stakedAmount $ \(PDiscrete v) -> pextract # v + pure $ pconstant () - -- The votes can only change when the proposal still allows voting. - let shouldUpdateVotes = - proposalF.status #== pconstantData VotingReady - #&& pnot # (pcon PCreated #== stakeUsage) + ------------------------------------------------------------------ - pguardC "Proposal output correct" $ - pif - shouldUpdateVotes - ( let -- Remove votes and leave other parts of the proposal as it. - expectedVotes = pretractVotes # retractFrom # retractCount # proposalF.votes + PAdvanceProposal _ -> do + inDraftPeriod <- + pletC $ + isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime - expectedProposalOut = - mkRecordConstr - PProposalDatum - ( #proposalId .= proposalF.proposalId - .& #effects .= proposalF.effects - .& #status .= proposalF.status - .& #cosigners .= proposalF.cosigners - .& #thresholds .= proposalF.thresholds - .& #votes .= pdata expectedVotes - .& #timingConfig .= proposalF.timingConfig - .& #startingTime .= proposalF.startingTime - ) - in ptraceIfFalse "Update votes" $ - expectedProposalOut #== proposalOut - ) - -- No change to the proposal is allowed. - $ ptraceIfFalse "Proposal unchanged" proposalUnchanged + pure $ + pif + inDraftPeriod + ( unTermCont $ do + pguardC "More cosigns than minimum amount" $ + punsafeCoerce (pfromData thresholdsF.vote) #< totalStakedAmount - -- At last, we ensure that all locks belong to this proposal will be removed. - stakeOutputLocks <- pletC $ pfield @"lockedBy" # stakeOut - - let templateStakeOut = - mkRecordConstr - PStakeDatum - ( #stakedAmount .= stakeInF.stakedAmount - .& #owner .= stakeInF.owner - .& #lockedBy .= stakeOutputLocks - ) - - pguardC "Only locks updated in the output stake" $ - templateStakeOut #== stakeOut - - pguardC "All relevant locks removed from the stake" $ - pgetStakeUsage # pfromData stakeOutputLocks - # proposalF.proposalId #== pcon PDidNothing - - pure $ popaque (pconstant ()) - ------------------------------------------------------------------ - PAdvanceProposal _ -> unTermCont $ do - pguardC "Stake should not change" $ - stakeInputHash #== stakeOutputHash - - proposalOutStatus <- pletC $ pfield @"status" # proposalOut - - let -- Only the status of proposals should be updated in this case. - templateProposalOut = - mkRecordConstr - PProposalDatum - ( #proposalId .= proposalF.proposalId - .& #effects .= proposalF.effects - .& #status .= proposalOutStatus - .& #cosigners .= proposalF.cosigners - .& #thresholds .= proposalF.thresholds - .& #votes .= proposalF.votes - .& #timingConfig .= proposalF.timingConfig - .& #startingTime .= proposalF.startingTime - ) - - pguardC "Only status changes in the output proposal" $ - templateProposalOut #== proposalOut - - inDraftPeriod <- pletC $ isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime - inVotingPeriod <- pletC $ isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime - inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime - inExecutionPeriod <- pletC $ isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime - - proposalStatus <- pletC $ pto $ pfromData proposalF.status - - -- Check the timings. - let isFinished = proposalF.status #== pconstantData Finished - - notTooLate = pmatchEnum proposalStatus $ \case - Draft -> inDraftPeriod - -- Can only advance after the voting period is over. - VotingReady -> inLockedPeriod - Locked -> inExecutionPeriod - _ -> pconstant False - - notTooEarly = pmatchEnum (pto $ pfromData proposalF.status) $ \case - VotingReady -> pnot # inVotingPeriod - Locked -> pnot # inLockedPeriod - _ -> pconstant True - - pguardC "Cannot advance ahead of time" notTooEarly - pguardC "Finished proposals cannot be advanced" $ pnot # isFinished - - thresholdsF <- pletFieldsC @'["execute"] proposalF.thresholds - - pure $ - pif - notTooLate - -- On time: advance to next status. - ( pmatchEnum proposalStatus $ \case - Draft -> unTermCont $ do - -- TODO: Perform other necessary checks. + pguardC "All new cosigners are witnessed by their Stake datums" $ + plistEquals # sortedStakeOwners # proposalF.cosigners -- 'Draft' -> 'VotingReady' pguardC "Proposal status set to VotingReady" $ - proposalOutStatus #== pconstantData VotingReady + proposalOutStatus #== pconstant VotingReady - pure $ popaque (pconstant ()) + pure $ pconstant () + ) + ( unTermCont $ do + pguardC "Advance to failed state" $ proposalOutStatus #== pconstant Finished + + pure $ pconstant () + ) + + ------------------------------------------------------------------ + + _ -> pure $ pconstant () + ) + ( unTermCont $ do + pguardC "Can only deal with one stake" $ + stakeInputNum #== 1 + + let stakeInputHash = pfromData $ phead # stakeInputDatumHashes + stakeOutputHash = pfromData $ phead # stakeOutputDatumHashes + + stakeIn :: Term _ PStakeDatum <- + pletC $ + pfromData $ + pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums + stakeInF <- pletFieldsC @'["stakedAmount", "lockedBy", "owner"] stakeIn + + stakeOut :: Term _ PStakeDatum <- + pletC $ + pfromData $ + pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums + + redeemer <- pmatchC proposalRedeemer + + case redeemer of + PVote r -> do + pguardC "Input proposal must be in VotingReady state" $ + currentStatus #== pconstant VotingReady + + pguardC "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 <- pmatchC proposalF.votes + voteFor <- pletC $ pfromData $ pfield @"resultTag" # r + + pguardC "Vote option should be valid" $ + pisJust #$ plookup # voteFor # voteMap + + -- Ensure that no lock with the current proposal id has been put on the stake. + pguardC "Same stake shouldn't vote on the same proposal twice" $ + pnot #$ pany + # plam + ( \((pfield @"proposalTag" #) . pfromData -> pid) -> + pid #== proposalF.proposalId + ) + # pfromData stakeInF.lockedBy + + let -- The amount of new votes should be the 'stakedAmount'. + -- 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 -> unTermCont $ do + PDiscrete v <- pmatchC stakeInF.stakedAmount + pure $ pcon $ PJust $ votes + (pextract # v) + ) + # voteFor + # m + expectedProposalOut = + mkRecordConstr + PProposalDatum + ( #proposalId .= proposalF.proposalId + .& #effects .= proposalF.effects + .& #status .= proposalF.status + .& #cosigners .= proposalF.cosigners + .& #thresholds .= proposalF.thresholds + .& #votes .= pdata expectedNewVotes + .& #timingConfig .= proposalF.timingConfig + .& #startingTime .= proposalF.startingTime + ) + + pguardC "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 newProposalLock = + mkRecordConstr + PProposalLock + ( #vote .= pdata voteFor + .& #proposalTag .= proposalF.proposalId + ) + -- Prepend the new lock to existing locks + expectedProposalLocks = + pcons + # pdata newProposalLock + # pfromData stakeInF.lockedBy + expectedStakeOut = + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeInF.stakedAmount + .& #owner .= stakeInF.owner + .& #lockedBy .= pdata expectedProposalLocks + ) + + pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut + + pure $ pconstant () + + ------------------------------------------------------------------ + PUnlock r -> do + -- At draft stage, the votes should be empty. + pguardC "Shouldn't retract votes from a draft proposal" $ + pnot #$ currentStatus #== pconstant Draft + + -- This is the vote option we're retracting from. + retractFrom <- pletC $ pfield @"resultTag" # r + + -- Determine if the input stake is actually locked by this proposal. + stakeUsage <- pletC $ pgetStakeUsage # stakeInF.lockedBy # proposalF.proposalId + + pguardC "Stake input relevant" $ + pmatch stakeUsage $ \case + PDidNothing -> + ptraceIfFalse "Stake should be relevant" $ + pconstant False + PCreated -> + ptraceIfFalse "Removing creator's locks means status is Finished" $ + currentStatus #== pconstant Finished + PVotedFor rt -> + ptraceIfFalse "Result tag should match the one given in the redeemer" $ + rt #== retractFrom + + -- The count of removing votes is equal to the 'stakeAmount' of input stake. + retractCount <- + pletC $ + pmatch stakeInF.stakedAmount $ \(PDiscrete v) -> pextract # v + + -- The votes can only change when the proposal still allows voting. + let shouldUpdateVotes = + currentStatus #== pconstant VotingReady + #&& pnot # (pcon PCreated #== stakeUsage) + + pguardC "Proposal output correct" $ + pif + shouldUpdateVotes + ( let -- Remove votes and leave other parts of the proposal as it. + expectedVotes = pretractVotes # retractFrom # retractCount # proposalF.votes + + expectedProposalOut = + mkRecordConstr + PProposalDatum + ( #proposalId .= proposalF.proposalId + .& #effects .= proposalF.effects + .& #status .= proposalF.status + .& #cosigners .= proposalF.cosigners + .& #thresholds .= proposalF.thresholds + .& #votes .= pdata expectedVotes + .& #timingConfig .= proposalF.timingConfig + .& #startingTime .= proposalF.startingTime + ) + in ptraceIfFalse "Update votes" $ + expectedProposalOut #== proposalOut + ) + -- No change to the proposal is allowed. + $ ptraceIfFalse "Proposal unchanged" proposalUnchanged + + -- At last, we ensure that all locks belong to this proposal will be removed. + stakeOutputLocks <- pletC $ pfield @"lockedBy" # stakeOut + + let templateStakeOut = + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeInF.stakedAmount + .& #owner .= stakeInF.owner + .& #lockedBy .= stakeOutputLocks + ) + + pguardC "Only locks updated in the output stake" $ + templateStakeOut #== stakeOut + + pguardC "All relevant locks removed from the stake" $ + pgetStakeUsage # pfromData stakeOutputLocks + # proposalF.proposalId #== pcon PDidNothing + + pure $ pconstant () + + ------------------------------------------------------------------ + PAdvanceProposal _ -> do + pguardC "Stake should not change" $ + stakeInputHash #== stakeOutputHash + + pguardC + "Only status changes in the output proposal" + onlyStatusChanged + + inVotingPeriod <- pletC $ isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime + inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime + inExecutionPeriod <- pletC $ isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime + + proposalStatus <- pletC $ pto $ pfromData proposalF.status + + -- Check the timings. + let isFinished = currentStatus #== pconstant Finished + + notTooLate = pmatchEnum proposalStatus $ \case + -- Can only advance after the voting period is over. + VotingReady -> inLockedPeriod + Locked -> inExecutionPeriod + _ -> pconstant False + + notTooEarly = pmatchEnum (pto $ pfromData proposalF.status) $ \case + VotingReady -> pnot # inVotingPeriod + Locked -> pnot # inLockedPeriod + _ -> pconstant True + + pguardC "Cannot advance ahead of time" notTooEarly + pguardC "Finished proposals cannot be advanced" $ pnot # isFinished + + let toFailedState = unTermCont $ do + pguardC "Proposal should fail: not on time" $ + proposalOutStatus #== pconstant Finished + + -- TODO: Should check that the GST is not moved + -- if the proposal is in 'Locked' state. + pure $ pconstant () + + toNextState = pmatchEnum proposalStatus $ \case VotingReady -> unTermCont $ do -- 'VotingReady' -> 'Locked' pguardC "Proposal status set to Locked" $ - proposalOutStatus #== pconstantData Locked + proposalOutStatus #== pconstant Locked pguardC "Winner outcome not found" $ pisJust #$ pwinner' # proposalF.votes #$ punsafeCoerce $ pfromData thresholdsF.execute - pure $ popaque (pconstant ()) + pure $ pconstant () Locked -> unTermCont $ do -- 'Locked' -> 'Finished' pguardC "Proposal status set to Finished" $ - proposalOutStatus #== pconstantData Finished + proposalOutStatus #== pconstant Finished -- TODO: Perform other necessary checks. - pure $ popaque (pconstant ()) - _ -> popaque (pconstant ()) - ) - -- Too late: failed proposal, status set to 'Finished'. - ( popaque $ - ptraceIfFalse "Proposal should fail: not on time" $ - proposalOutStatus #== pconstantData Finished - -- TODO: Should check that the GST is not moved - -- if the proposal is in 'Locked' state. - ) - _ -> popaque (pconstant ()) + pure $ pconstant () + _ -> pconstant () + + pure $ + pif + notTooLate + -- On time: advance to next status. + toNextState + -- Too late: failed proposal, status set to 'Finished'. + toFailedState + _ -> pure $ pconstant () + ) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 2b24a50..e8945c2 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -19,6 +19,9 @@ module Agora.Utils ( validatorHashToAddress, isScriptAddress, isPubKey, + pltAsData, + pisUniqBy', + pisUniq', ) where import Plutarch.Api.V1 ( @@ -193,3 +196,48 @@ mustBePDJust = phoistAcyclic $ -} validatorHashToAddress :: ValidatorHash -> Address validatorHashToAddress vh = Address (ScriptCredential vh) Nothing + +{- | Compare two 'PAsData' value, return true if the first one is less than the second one. + + @since 0.2.0 +-} +pltAsData :: + forall (a :: PType) (s :: S). + (POrd a, PIsData a) => + Term s (PAsData a :--> PAsData a :--> PBool) +pltAsData = phoistAcyclic $ + plam $ + \(pfromData -> l) (pfromData -> r) -> l #< r + +{- | Special version of 'pisUniq'', the list elements should have 'PEq' instance. + + @since 0.2.0 +-} +pisUniq' :: + forall (l :: PType -> PType) (a :: PType) (s :: S). + (PEq a, PIsListLike l a) => + Term s (l a :--> PBool) +pisUniq' = phoistAcyclic $ pisUniqBy' # phoistAcyclic (plam (#==)) + +{- | Return true if all the elements in the given list are unique, given the equalator function. + The list is assumed to be ordered. + + @since 0.2.0 +-} +pisUniqBy' :: + forall (l :: PType -> PType) (a :: PType) (s :: S). + (PIsListLike l a) => + Term s ((a :--> a :--> PBool) :--> l a :--> PBool) +pisUniqBy' = phoistAcyclic $ + plam $ \eq l -> + pif (pnull # l) (pconstant True) $ + go # eq # (phead # l) # (ptail # l) + where + go :: Term _ ((a :--> a :--> PBool) :--> a :--> l a :--> PBool) + go = phoistAcyclic $ + pfix #$ plam $ \self' eq x xs -> + plet (self' # eq) $ \self -> + pif (pnull # xs) (pconstant True) $ + plet (phead # xs) $ \x' -> + pif (eq # x # x') (pconstant False) $ + self # x' #$ ptail # xs diff --git a/bench.csv b/bench.csv index e5bdec1..dca4d7b 100644 --- a/bench.csv +++ b/bench.csv @@ -8,24 +8,24 @@ Agora/Stake/policy/stakeCreation,50939580,148729,2387 Agora/Stake/validator/stakeDepositWithdraw deposit,181581435,493259,4413 Agora/Stake/validator/stakeDepositWithdraw withdraw,181581435,493259,4401 Agora/Proposal/policy/proposalCreation,23140177,69194,1515 -Agora/Proposal/validator/cosignature/proposal,242933842,689669,8224 -Agora/Proposal/validator/cosignature/stake,124072228,314923,4942 -Agora/Proposal/validator/voting/proposal,236945537,666233,8142 -Agora/Proposal/validator/voting/stake,131045998,349073,4899 -Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,237984765,667020,8049 -Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,253273240,708960,8058 -Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,241665255,675133,8058 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished,237488276,666118,8051 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished,238906810,669423,8052 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished,240037788,671827,8052 -"Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady",240815652,676043,8102 -"Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished",211095003,600275,8104 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished",207388671,591954,8106 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked",207388671,591954,8106 -"Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady",1770480224,5186822,29209 -"Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished",1444125436,4305527,29393 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished",1335481449,3965762,29377 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked",1335481449,3965762,29377 +Agora/Proposal/validator/cosignature/proposal,240482868,674626,8525 +Agora/Proposal/validator/cosignature/stake,125315872,312659,4942 +Agora/Proposal/validator/voting/proposal,243946100,678901,8443 +Agora/Proposal/validator/voting/stake,120122971,320497,4899 +Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,219342631,620576,8350 +Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,247748475,699343,8359 +Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,236509366,666512,8359 +Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished,214287939,609855,8352 +Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished,233681921,660502,8353 +Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished,234812899,662906,8353 +"Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady",245987595,688711,8403 +"Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished",215263333,612711,8405 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished",212560614,604622,8407 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked",212560614,604622,8407 +"Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady",1775652167,5199490,29510 +"Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished",1448293766,4317963,29694 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished",1340653392,3978430,29678 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked",1340653392,3978430,29678 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,806 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 Agora/Treasury/Validator/Positive/Allows for effect changes,31556709,81546,1452 @@ -33,5 +33,5 @@ Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,80 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 Agora/Governor/policy/GST minting,51007235,144191,2034 Agora/Governor/validator/proposal creation,309689999,834675,9064 -Agora/Governor/validator/GATs minting,421016677,1141838,9187 +Agora/Governor/validator/GATs minting,418560845,1137908,9187 Agora/Governor/validator/mutate governor state,88986020,248491,8662 From d433ab17d6db3a3c493b262f3ab803c6bb28eb37 Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Tue, 5 Jul 2022 07:53:56 +0800 Subject: [PATCH 4/6] `WitnessStake`: accept multiple stakes at input --- agora/Agora/Stake/Scripts.hs | 412 ++++++++++++++++++++--------------- bench.csv | 8 +- 2 files changed, 243 insertions(+), 177 deletions(-) diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index e8b5e46..f947817 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -8,7 +8,18 @@ Plutus Scripts for Stakes. module Agora.Stake.Scripts (stakePolicy, stakeValidator) where import Agora.SafeMoney (GTTag) -import Agora.Stake +import Agora.Stake ( + PStakeDatum (PStakeDatum), + PStakeRedeemer ( + PDepositWithdraw, + PDestroy, + PPermitVote, + PRetractVotes + ), + Stake (gtClassRef, proposalSTClass), + StakeRedeemer (WitnessStake), + stakeLocked, + ) import Agora.Utils ( mustBePJust, mustFindDatum', @@ -18,18 +29,22 @@ import Data.Tagged (Tagged (..), untag) import Plutarch.Api.V1 ( AmountGuarantees (Positive), PCredential (PPubKeyCredential, PScriptCredential), + PDatumHash, PMintingPolicy, PScriptPurpose (PMinting, PSpending), PTokenName, PTxInfo, + PTxOut, PValidator, PValue, mintingPolicySymbol, mkMintingPolicy, ) import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf, pvalueOf) -import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, pisTokenSpent, ptxSignedBy, pvalueSpent) +import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, ptxSignedBy, pvalueSpent) import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pgeqByClass', pgeqBySymbol, psymbolValueOf) +import Plutarch.Extra.List (pmapMaybe, pmsortBy) +import Plutarch.Extra.Maybe (pfromDJust) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC) import Plutarch.Internal (punsafeCoerce) @@ -208,7 +223,15 @@ stakeValidator stake = plam $ \datum redeemer ctx' -> unTermCont $ do ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' txInfo <- pletC $ pfromData ctx.txInfo - txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "signatories", "datums"] txInfo + txInfoF <- + pletFieldsC + @'[ "mint" + , "inputs" + , "outputs" + , "signatories" + , "datums" + ] + txInfo (pfromData -> stakeRedeemer, _) <- ptryFromC redeemer @@ -219,23 +242,25 @@ stakeValidator stake = PSpending txOutRef <- pmatchC $ pfromData ctx.purpose - PJust txInInfo <- pmatchC $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs - ownAddress <- pletC $ pfield @"address" #$ pfield @"resolved" # txInInfo - let continuingValue :: Term _ (PValue _ _) - continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo + PJust ((pfield @"resolved" #) -> resolved) <- + pmatchC $ + pfindTxInByTxOutRef + # (pfield @"_0" # txOutRef) + # txInfoF.inputs + resolvedF <- pletFieldsC @'["address", "value", "datumHash"] resolved -- Whether the owner signs this transaction or not. ownerSignsTransaction <- pletC $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner - stCurrencySymbol <- pletC $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef) + stCurrencySymbol <- + pletC $ + pconstant $ + mintingPolicySymbol $ + mkMintingPolicy (stakePolicy stake.gtClassRef) mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint valueSpent <- pletC $ pvalueSpent # txInfoF.inputs spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent - let AssetClass (propCs, propTn) = stake.proposalSTClass - proposalSTClass = passetClass # pconstant propCs # pconstant propTn - spentProposalST <- pletC $ passetClassValueOf # valueSpent # proposalSTClass - -- Is the stake currently locked? stakeIsLocked <- pletC $ stakeLocked # stakeDatum' @@ -253,196 +278,237 @@ stakeValidator stake = pguardC "Owner signs this transaction" ownerSignsTransaction pure $ popaque (pconstant ()) - -------------------------------------------------------------------------- + ------------------------------------------------------------------------ -- Handle redeemers that require own stake output. + _ -> unTermCont $ do - -- Filter out own output with own address and PST. - ownOutput <- + let AssetClass (propCs, propTn) = stake.proposalSTClass + proposalSTClass = passetClass # pconstant propCs # pconstant propTn + spentProposalST = passetClassValueOf # valueSpent # proposalSTClass + + proposalTokenMoved <- pletC $ spentProposalST #== 1 + + -- Filter out own outputs using own address and ST. + ownOutputs <- pletC $ - mustBePJust # "Own output should be present" #$ pfind + pfilter # plam - ( \input -> unTermCont $ do - inputF <- pletFieldsC @'["address", "value"] input + ( \output -> unTermCont $ do + outputF <- pletFieldsC @'["address", "value"] output + pure $ - inputF.address #== ownAddress - #&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1 + outputF.address #== resolvedF.address + #&& psymbolValueOf # stCurrencySymbol # outputF.value #== 1 ) # pfromData txInfoF.outputs - stakeOut <- - pletC $ - mustFindDatum' @PStakeDatum - # (pfield @"datumHash" # ownOutput) - # txInfoF.datums + let witnessStake = unTermCont $ do + pguardC "Either owner signs the transaction or propsoal token moved" $ + ownerSignsTransaction #|| proposalTokenMoved - ownOutputValue <- - pletC $ - pfield @"value" # ownOutput - - ownOutputValueUnchanged <- - pletC $ - pdata continuingValue #== pdata ownOutputValue - - stakeOutUnchanged <- - pletC $ - pdata stakeOut #== pdata stakeDatum' - - pure $ - pmatch stakeRedeemer $ \case - PRetractVotes l -> unTermCont $ do - pguardC - "Owner signs this transaction" - ownerSignsTransaction - - pguardC "ST at inputs must be 1" $ - spentST #== 1 - - -- This puts trust into the Proposal. The Proposal must necessarily check - -- that this is not abused. - pguardC "Proposal ST spent" $ - spentProposalST #== 1 - - pguardC "A UTXO must exist with the correct output" $ - let expectedLocks = pfield @"locks" # l - - expectedDatum = - mkRecordConstr - PStakeDatum - ( #stakedAmount .= stakeDatum.stakedAmount - .& #owner .= stakeDatum.owner - .& #lockedBy .= expectedLocks + -- FIXME: refactor this with reference input, once it's supported by plutarch. + -- + -- Our goal here is to allow multiple input stakes, and also ensure that every the input stakes has a + -- corresponding output stake, which carries the same value and the same datum as the input stake. + -- + -- Validation strategy I have tried/considered so far: + -- 1. Check that the number of input stakes equals to the number of output stakes, and verify + -- that every input stake has an output stake with the exact same value and datum hash. + -- However this approach has a fatal vulnerability: let's say we have two totally identical stakes, + -- a malicious user can comsume these two stakes and remove GTs from one of them. + -- 2. Perform the same checks as the last approch does, while also checking that every output stake is + -- valid(stakedAmount == actual value). However this requires that all the output stake datum are + -- included in the transaction, and we have to find and go through them one by one to access the + -- 'stakedAmount' fields, meaning that computationally this approach is *very* expensive. + -- 3. The one implemented below. Find all the continuous input/output, sort them by 'datumHash', and + -- ensure that the two sorted lists are equal. + let ownInputs = + pmapMaybe + # plam + ( \input -> plet (pfield @"resolved" # input) $ \resolvedInput -> + let value = pfield @"value" # resolvedInput + in pif + (psymbolValueOf # stCurrencySymbol # value #== 1) + (pcon $ PJust resolvedInput) + (pcon PNothing) ) + # pfromData txInfoF.inputs - valueCorrect = ownOutputValueUnchanged - outputDatumCorrect = stakeOut #== expectedDatum - in foldl1 - (#&&) - [ ptraceIfFalse "valueCorrect" valueCorrect - , ptraceIfFalse "datumCorrect" outputDatumCorrect - ] + sortTxOuts :: Term _ (PBuiltinList (PAsData PTxOut) :--> PBuiltinList (PAsData PTxOut)) + sortTxOuts = + plam + ( pmsortBy + # plam + ( \((getDatumHash #) -> dhX) + ((getDatumHash #) -> dhY) -> dhX #< dhY + ) + # + ) + where + getDatumHash :: Term _ (PAsData PTxOut :--> PDatumHash) + getDatumHash = phoistAcyclic $ plam ((pfromDJust #) . pfromData . (pfield @"datumHash" #)) - pure $ popaque (pconstant ()) - -------------------------------------------------------------------------- - PPermitVote l -> unTermCont $ do - pguardC - "Owner signs this transaction" - ownerSignsTransaction + sortedOwnInputs = sortTxOuts # ownInputs + sortedOwnOutputs = sortTxOuts # ownOutputs - -- This puts trust into the Proposal. The Proposal must necessarily check - -- that this is not abused. - pguardC "Proposal ST spent" $ - spentProposalST #== 1 + pguardC "Every stake inputs has a corresponding unchanged output" $ + plistEquals # sortedOwnInputs # sortedOwnOutputs - -- Update the stake datum, but only the 'lockedBy' field. + pure $ popaque $ pconstant () - 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 <- + let onlyAcceptOneStake = unTermCont $ do + pguardC "ST at inputs must be 1" $ + spentST #== 1 + + ownOutput <- pletC $ pfromData $ phead # ownOutputs + + stakeOut <- pletC $ - mkRecordConstr - PStakeDatum - ( #stakedAmount .= stakeDatum.stakedAmount - .& #owner .= stakeDatum.owner - .& #lockedBy .= pdata expectedLocks - ) + mustFindDatum' @PStakeDatum + # (pfield @"datumHash" # ownOutput) + # txInfoF.datums - pguardC "A UTXO must exist with the correct output" $ - let correctOutputDatum = stakeOut #== expectedDatum - valueCorrect = ownOutputValueUnchanged - in foldl1 - (#&&) - [ ptraceIfFalse "valueCorrect" valueCorrect - , ptraceIfFalse "datumCorrect" correctOutputDatum - ] + ownOutputValue <- + pletC $ + pfield @"value" # ownOutput - pure $ popaque (pconstant ()) - -------------------------------------------------------------------------- - PWitnessStake _ -> unTermCont $ do - pguardC "ST at inputs must be 1" $ - spentST #== 1 + ownOutputValueUnchanged <- + pletC $ + pdata resolvedF.value #== pdata ownOutputValue - let AssetClass (propCs, propTn) = stake.proposalSTClass - propAssetClass = passetClass # pconstant propCs # pconstant propTn - proposalTokenMoved = - pisTokenSpent - # propAssetClass - # txInfoF.inputs + pure $ + pmatch stakeRedeemer $ \case + PRetractVotes l -> unTermCont $ do + pguardC + "Owner signs this transaction" + ownerSignsTransaction - -- In order for cosignature to be witnessed, it must be possible for a - -- proposal to allow this transaction to happen. This puts trust into the Proposal. - -- The Proposal must necessarily check that this is not abused. - pguardC - "Owner signs this transaction OR proposal token is spent" - (ownerSignsTransaction #|| proposalTokenMoved) + -- This puts trust into the Proposal. The Proposal must necessarily check + -- that this is not abused. + pguardC "Proposal ST spent" proposalTokenMoved - pguardC "A UTXO must exist with the correct output" $ - let correctOutputDatum = stakeOutUnchanged - valueCorrect = ownOutputValueUnchanged - in foldl1 - (#&&) - [ ptraceIfFalse "valueCorrect" valueCorrect - , ptraceIfFalse "correctOutputDatum" correctOutputDatum - ] - pure $ popaque (pconstant ()) - -------------------------------------------------------------------------- - PDepositWithdraw r -> unTermCont $ do - pguardC "ST at inputs must be 1" $ - spentST #== 1 - pguardC "Stake unlocked" $ - pnot #$ stakeIsLocked - pguardC - "Owner signs this transaction" - ownerSignsTransaction - pguardC "A UTXO must exist with the correct output" $ - unTermCont $ do - let oldStakedAmount = pfromData $ stakeDatum.stakedAmount - delta = pfromData $ pfield @"delta" # r + pguardC "A UTXO must exist with the correct output" $ + let expectedLocks = pfield @"locks" # l - newStakedAmount <- pletC $ oldStakedAmount + delta + expectedDatum = + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeDatum.stakedAmount + .& #owner .= stakeDatum.owner + .& #lockedBy .= expectedLocks + ) - pguardC "New staked amount shoudl be greater than or equal to 0" $ - zero #<= newStakedAmount + valueCorrect = ownOutputValueUnchanged + outputDatumCorrect = stakeOut #== expectedDatum + in foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + , ptraceIfFalse "datumCorrect" outputDatumCorrect + ] - let expectedDatum = + pure $ popaque (pconstant ()) + + ------------------------------------------------------------ + + PPermitVote l -> unTermCont $ do + pguardC + "Owner signs this transaction" + ownerSignsTransaction + + -- This puts trust into the Proposal. The Proposal must necessarily check + -- that this is not abused. + pguardC "Proposal ST spent" proposalTokenMoved + + -- 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 <- + pletC $ mkRecordConstr PStakeDatum - ( #stakedAmount .= pdata newStakedAmount + ( #stakedAmount .= stakeDatum.stakedAmount .& #owner .= stakeDatum.owner - .& #lockedBy .= stakeDatum.lockedBy + .& #lockedBy .= pdata expectedLocks ) - datumCorrect = stakeOut #== expectedDatum - let valueDelta :: Term _ (PValue _ 'Positive) - valueDelta = pdiscreteValue' stake.gtClassRef # delta + pguardC "A UTXO must exist with the correct output" $ + let correctOutputDatum = stakeOut #== expectedDatum + valueCorrect = ownOutputValueUnchanged + in foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + , ptraceIfFalse "datumCorrect" correctOutputDatum + ] - expectedValue = - continuingValue <> valueDelta + pure $ popaque (pconstant ()) - valueCorrect = - foldr1 - (#&&) - [ pgeqByClass' (AssetClass ("", "")) - # ownOutputValue - # expectedValue - , pgeqByClass' (untag stake.gtClassRef) - # ownOutputValue - # expectedValue - , pgeqBySymbol - # stCurrencySymbol - # ownOutputValue - # expectedValue - ] - -- - pure $ - foldl1 - (#&&) - [ ptraceIfFalse "valueCorrect" valueCorrect - , ptraceIfFalse "datumCorrect" datumCorrect - ] - -- - pure $ popaque (pconstant ()) - _ -> popaque (pconstant ()) + ------------------------------------------------------------ + + PDepositWithdraw r -> unTermCont $ do + pguardC "Stake unlocked" $ + pnot #$ stakeIsLocked + pguardC + "Owner signs this transaction" + ownerSignsTransaction + pguardC "A UTXO must exist with the correct output" $ + unTermCont $ do + let oldStakedAmount = pfromData $ stakeDatum.stakedAmount + delta = pfromData $ pfield @"delta" # r + + newStakedAmount <- pletC $ oldStakedAmount + delta + + pguardC "New staked amount shoudl be greater than or equal to 0" $ + zero #<= newStakedAmount + + let expectedDatum = + mkRecordConstr + PStakeDatum + ( #stakedAmount .= pdata newStakedAmount + .& #owner .= stakeDatum.owner + .& #lockedBy .= stakeDatum.lockedBy + ) + datumCorrect = stakeOut #== expectedDatum + + let valueDelta :: Term _ (PValue _ 'Positive) + valueDelta = pdiscreteValue' stake.gtClassRef # delta + + expectedValue = + resolvedF.value <> valueDelta + + valueCorrect = + foldr1 + (#&&) + [ pgeqByClass' (AssetClass ("", "")) + # ownOutputValue + # expectedValue + , pgeqByClass' (untag stake.gtClassRef) + # ownOutputValue + # expectedValue + , pgeqBySymbol + # stCurrencySymbol + # ownOutputValue + # expectedValue + ] + -- + pure $ + foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + , ptraceIfFalse "datumCorrect" datumCorrect + ] + -- + pure $ popaque (pconstant ()) + _ -> popaque (pconstant ()) + + pure $ + pif + (pdata stakeRedeemer #== pconstantData WitnessStake) + witnessStake + onlyAcceptOneStake diff --git a/bench.csv b/bench.csv index dca4d7b..a596e6f 100644 --- a/bench.csv +++ b/bench.csv @@ -5,13 +5,13 @@ Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,456007605,1104500,3 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,87839169,243032,8561 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,106082031,292993,3609 Agora/Stake/policy/stakeCreation,50939580,148729,2387 -Agora/Stake/validator/stakeDepositWithdraw deposit,181581435,493259,4413 -Agora/Stake/validator/stakeDepositWithdraw withdraw,181581435,493259,4401 +Agora/Stake/validator/stakeDepositWithdraw deposit,180222751,492217,5003 +Agora/Stake/validator/stakeDepositWithdraw withdraw,180222751,492217,4991 Agora/Proposal/policy/proposalCreation,23140177,69194,1515 Agora/Proposal/validator/cosignature/proposal,240482868,674626,8525 -Agora/Proposal/validator/cosignature/stake,125315872,312659,4942 +Agora/Proposal/validator/cosignature/stake,136781411,336612,5528 Agora/Proposal/validator/voting/proposal,243946100,678901,8443 -Agora/Proposal/validator/voting/stake,120122971,320497,4899 +Agora/Proposal/validator/voting/stake,128972262,348186,5489 Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,219342631,620576,8350 Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,247748475,699343,8359 Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,236509366,666512,8359 From 9c8d04dbc6a7dfbe773788d80cb206ba89fba889 Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Tue, 5 Jul 2022 07:55:12 +0800 Subject: [PATCH 5/6] add tests for advancement from draft phrase; refactoring --- .../Sample/Effect/TreasuryWithdrawal.hs | 15 +- agora-specs/Sample/Proposal.hs | 701 ------------------ agora-specs/Sample/Proposal/Advance.hs | 509 +++++++++++++ agora-specs/Sample/Proposal/Cosign.hs | 344 +++++++++ agora-specs/Sample/Proposal/Shared.hs | 42 +- agora-specs/Sample/Proposal/UnlockStake.hs | 77 +- agora-specs/Sample/Proposal/Vote.hs | 249 +++++++ agora-specs/Spec/Proposal.hs | 428 ++++------- agora-testlib/Test/Util.hs | 41 +- agora.cabal | 3 + agora/Agora/Stake/Scripts.hs | 8 +- bench.csv | 63 +- 12 files changed, 1402 insertions(+), 1078 deletions(-) create mode 100644 agora-specs/Sample/Proposal/Advance.hs create mode 100644 agora-specs/Sample/Proposal/Cosign.hs create mode 100644 agora-specs/Sample/Proposal/Vote.hs diff --git a/agora-specs/Sample/Effect/TreasuryWithdrawal.hs b/agora-specs/Sample/Effect/TreasuryWithdrawal.hs index 7c95bc9..724dca9 100644 --- a/agora-specs/Sample/Effect/TreasuryWithdrawal.hs +++ b/agora-specs/Sample/Effect/TreasuryWithdrawal.hs @@ -23,17 +23,13 @@ import Agora.Effect.TreasuryWithdrawal ( TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), treasuryWithdrawalValidator, ) -import Crypto.Hash qualified as Crypto -import Data.ByteArray qualified as BA -import Data.ByteString qualified as BS -import Data.ByteString.Char8 qualified as C (pack) import Plutarch.Api.V1 (mkValidator, validatorHash) import PlutusLedgerApi.V1 ( Address (Address), Credential (..), CurrencySymbol (CurrencySymbol), DatumHash (DatumHash), - PubKeyHash (PubKeyHash), + PubKeyHash, ScriptContext (..), ScriptPurpose (Spending), TokenName (TokenName), @@ -56,10 +52,10 @@ import PlutusLedgerApi.V1 ( Validator, ValidatorHash (ValidatorHash), Value, - toBuiltin, ) import PlutusLedgerApi.V1.Interval qualified as Interval (always) import PlutusLedgerApi.V1.Value qualified as Value (singleton) +import Test.Util (scriptCredentials, userCredentials) -- | A sample Currency Symbol. currSymbol :: CurrencySymbol @@ -69,16 +65,13 @@ currSymbol = CurrencySymbol "12312099" signer :: PubKeyHash signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" -blake2b_224 :: BS.ByteString -> BS.ByteString -blake2b_224 = BS.pack . BA.unpack . Crypto.hashWith Crypto.Blake2b_224 - -- | List of users who the effect will pay to. users :: [Credential] -users = PubKeyCredential . PubKeyHash . toBuiltin . blake2b_224 . C.pack . show <$> ([1 ..] :: [Integer]) +users = userCredentials -- | List of users who the effect will pay to. treasuries :: [Credential] -treasuries = ScriptCredential . ValidatorHash . toBuiltin . blake2b_224 . C.pack . show <$> ([1 ..] :: [Integer]) +treasuries = scriptCredentials inputGAT :: TxInInfo inputGAT = diff --git a/agora-specs/Sample/Proposal.hs b/agora-specs/Sample/Proposal.hs index ac85e7f..6d2d6a9 100644 --- a/agora-specs/Sample/Proposal.hs +++ b/agora-specs/Sample/Proposal.hs @@ -8,17 +8,6 @@ This module tests primarily the happy path for Proposal interactions module Sample.Proposal ( -- * Script contexts proposalCreation, - cosignProposal, - proposalRef, - stakeRef, - voteOnProposal, - VotingParameters (..), - advanceProposalSuccess, - advanceProposalFailureTimeout, - TransitionParameters (..), - advanceFinishedProposal, - advanceProposalInsufficientVotes, - advanceProposalWithInvalidOutputStake, ) where import Agora.Governor (GovernorDatum (..)) @@ -27,78 +16,41 @@ import Agora.Proposal ( ProposalDatum (..), ProposalId (..), ProposalStatus (..), - ProposalThresholds (..), - ProposalVotes (..), ResultTag (..), emptyVotesFor, ) -import Agora.Proposal.Time ( - ProposalStartingTime (ProposalStartingTime), - ProposalTimingConfig (..), - ) -import Agora.Stake ( - ProposalLock (ProposalLock), - Stake (..), - StakeDatum (..), - ) import Data.Default.Class (Default (def)) -import Data.Tagged (Tagged (..), untag) import Plutarch.Context ( - BaseBuilder, MintingBuilder, buildMintingUnsafe, - buildTxInfoUnsafe, input, mint, output, script, signedWith, - timeRange, txId, withDatum, - withRefIndex, withTxId, withValue, ) import PlutusLedgerApi.V1 ( - Datum (Datum), - DatumHash, - POSIXTime, - POSIXTimeRange, - PubKeyHash, ScriptContext (..), - ToData (toBuiltinData), - TxInInfo (TxInInfo), - TxInfo (..), - TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue), - TxOutRef (..), - ValidatorHash, ) import PlutusLedgerApi.V1.Value qualified as Value ( assetClassValue, singleton, ) import PlutusTx.AssocMap qualified as AssocMap -import Sample.Proposal.Shared (proposalRef, stakeRef) import Sample.Shared ( govValidatorHash, - minAda, proposal, proposalPolicySymbol, proposalStartingTimeFromTimeRange, proposalValidatorHash, signer, - signer2, - stake, - stakeAddress, - stakeAssetClass, - stakeValidatorHash, ) import Test.Util ( closedBoundedInterval, - datumPair, - toDatumHash, - updateMap, ) proposalCreation :: ScriptContext @@ -160,656 +112,3 @@ proposalCreation = . withDatum govAfter ] in buildMintingUnsafe builder - --- | This script context should be a valid transaction. -cosignProposal :: [PubKeyHash] -> TxInfo -cosignProposal newSigners = - let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST - effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - proposalBefore :: ProposalDatum - proposalBefore = - ProposalDatum - { proposalId = ProposalId 0 - , effects = effects - , status = Draft - , cosigners = [signer] - , thresholds = def - , votes = emptyVotesFor effects - , timingConfig = def - , startingTime = ProposalStartingTime 0 - } - stakeDatum :: StakeDatum - stakeDatum = StakeDatum (Tagged 50_000_000) signer2 [] - proposalAfter :: ProposalDatum - proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners} - validTimeRange :: POSIXTimeRange - validTimeRange = - closedBoundedInterval - 10 - ((def :: ProposalTimingConfig).draftTime - 10) - builder :: BaseBuilder - builder = - mconcat - [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - , mint st - , mconcat $ signedWith <$> newSigners - , timeRange validTimeRange - , input $ - script proposalValidatorHash - . withValue (st <> Value.singleton "" "" 10_000_000) - . withDatum proposalBefore - . withTxId (txOutRefId proposalRef) - . withRefIndex (txOutRefIdx proposalRef) - , input $ - script stakeValidatorHash - . withValue - ( Value.singleton "" "" 10_000_000 - <> Value.assetClassValue (untag stake.gtClassRef) 50_000_000 - <> Value.assetClassValue stakeAssetClass 1 - ) - . withDatum stakeDatum - . withTxId (txOutRefId stakeRef) - . withRefIndex (txOutRefIdx stakeRef) - , output $ - script proposalValidatorHash - . withValue (st <> Value.singleton "" "" 10_000_000) - . withDatum proposalAfter - , output $ - script stakeValidatorHash - . withValue - ( Value.singleton "" "" 10_000_000 - <> Value.assetClassValue (untag stake.gtClassRef) 50_000_000 - <> Value.assetClassValue stakeAssetClass 1 - ) - . withDatum stakeDatum - ] - in buildTxInfoUnsafe builder - --------------------------------------------------------------------------------- - --- | 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 - - --- - - 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 = def - , votes = ProposalVotes initialVotes - , timingConfig = def - , startingTime = ProposalStartingTime 0 - } - - --- - - existingLocks :: [ProposalLock] - existingLocks = - [ ProposalLock (ResultTag 0) (ProposalId 0) - , ProposalLock (ResultTag 2) (ProposalId 1) - ] - - --- - - stakeInputDatum :: StakeDatum - stakeInputDatum = - StakeDatum - { stakedAmount = Tagged params.voteCount - , owner = stakeOwner - , lockedBy = existingLocks - } - - --- - - updatedVotes :: AssocMap.Map ResultTag Integer - updatedVotes = updateMap (Just . (+ params.voteCount)) params.voteFor initialVotes - - --- - - proposalOutputDatum :: ProposalDatum - proposalOutputDatum = - proposalInputDatum - { votes = ProposalVotes updatedVotes - } - - --- - - -- Off-chain code should do exactly like this: prepend new lock toStatus the list. - updatedLocks :: [ProposalLock] - updatedLocks = ProposalLock params.voteFor proposalInputDatum.proposalId : existingLocks - - --- - - stakeOutputDatum :: StakeDatum - stakeOutputDatum = - stakeInputDatum - { lockedBy = updatedLocks - } - - --- - - validTimeRange = - closedBoundedInterval - ((def :: ProposalTimingConfig).draftTime + 1) - ((def :: ProposalTimingConfig).votingTime - 1) - - builder :: BaseBuilder - builder = - mconcat - [ txId "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c" - , signedWith stakeOwner - , timeRange validTimeRange - , input $ - script proposalValidatorHash - . withValue pst - . withDatum proposalInputDatum - . withTxId (txOutRefId proposalRef) - . withRefIndex (txOutRefIdx proposalRef) - , input $ - script stakeValidatorHash - . withValue - ( sst - <> Value.assetClassValue (untag stake.gtClassRef) params.voteCount - <> minAda - ) - . withDatum stakeInputDatum - . withTxId (txOutRefId stakeRef) - . withRefIndex (txOutRefIdx stakeRef) - , output $ - script proposalValidatorHash - . withValue pst - . withDatum proposalOutputDatum - , output $ - script stakeValidatorHash - . withValue - ( sst - <> Value.assetClassValue (untag stake.gtClassRef) params.voteCount - <> minAda - ) - . withDatum stakeOutputDatum - ] - in buildTxInfoUnsafe builder - --------------------------------------------------------------------------------- - --- | Parameters for state transition of proposals. -data TransitionParameters = TransitionParameters - { -- The initial status of the proposal. - initialProposalStatus :: ProposalStatus - , -- The starting time of the proposal. - proposalStartingTime :: ProposalStartingTime - } - --- | Create a 'TxInfo' that update the status of a proposal. -mkTransitionTxInfo :: - -- | Initial state of the proposal. - ProposalStatus -> - -- | Next state of the proposal. - ProposalStatus -> - -- | Effects. - AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash) -> - -- | Votes. - ProposalVotes -> - -- | Starting time of the proposal. - ProposalStartingTime -> - -- | Valid time range of the transaction. - POSIXTimeRange -> - -- | Whether to add an unchanged stake or not. - Bool -> - TxInfo -mkTransitionTxInfo from to effects votes startingTime validTime shouldAddUnchangedStake = - let pst = Value.singleton proposalPolicySymbol "" 1 - sst = Value.assetClassValue stakeAssetClass 1 - - proposalInputDatum :: ProposalDatum - proposalInputDatum = - ProposalDatum - { proposalId = ProposalId 0 - , effects = effects - , status = from - , cosigners = [signer] - , thresholds = def - , votes = votes - , timingConfig = def - , startingTime = startingTime - } - - proposalOutputDatum :: ProposalDatum - proposalOutputDatum = - proposalInputDatum - { status = to - } - - stakeOwner = signer - stakedAmount = 200 - - existingLocks :: [ProposalLock] - existingLocks = - [ ProposalLock (ResultTag 0) (ProposalId 0) - , ProposalLock (ResultTag 2) (ProposalId 1) - ] - - stakeInputDatum :: StakeDatum - stakeInputDatum = - StakeDatum - { stakedAmount = Tagged stakedAmount - , owner = stakeOwner - , lockedBy = existingLocks - } - - stakeOutputDatum :: StakeDatum - stakeOutputDatum = stakeInputDatum - - stakeBuilder :: BaseBuilder - stakeBuilder = - if shouldAddUnchangedStake - then - mconcat - [ input $ - script stakeValidatorHash - . withValue sst - . withDatum stakeInputDatum - . withTxId (txOutRefId stakeRef) - , output $ - script stakeValidatorHash - . withValue (sst <> minAda) - . withDatum stakeOutputDatum - ] - else mempty - - builder :: BaseBuilder - builder = - mconcat - [ txId "95ba4015e30aef16a3461ea97a779f814aeea6b8009d99a94add4b8293be737a" - , signedWith stakeOwner - , timeRange validTime - , input $ - script proposalValidatorHash - . withValue pst - . withDatum proposalInputDatum - . withTxId (txOutRefId proposalRef) - , output $ - script proposalValidatorHash - . withValue (pst <> minAda) - . withDatum proposalOutputDatum - ] - in buildTxInfoUnsafe $ builder <> stakeBuilder - --- | Wrapper around 'advanceProposalSuccess'', with valid stake. -advanceProposalSuccess :: TransitionParameters -> TxInfo -advanceProposalSuccess ps = advanceProposalSuccess' ps True - -{- | Create a valid 'TxInfo' that advances a proposal, given the parameters. - The second parameter determines wherther valid stake should be included. - - Note that 'TransitionParameters.initialProposalStatus' should not be 'Finished'. --} -advanceProposalSuccess' :: TransitionParameters -> Bool -> TxInfo -advanceProposalSuccess' params = - let -- Status of the output proposal. - toStatus :: ProposalStatus - toStatus = case params.initialProposalStatus of - Draft -> VotingReady - VotingReady -> Locked - Locked -> Finished - Finished -> error "Cannot advance 'Finished' proposal" - - effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - - emptyVotes@(ProposalVotes emptyVotes') = emptyVotesFor effects - - -- Set the vote count of outcome 0 to @def.countingVoting + 1@, - -- meaning that outcome 0 will be the winner. - outcome0WinningVotes = - ProposalVotes $ - updateMap - (\_ -> Just $ untag (def :: ProposalThresholds).execute + 1) - (ResultTag 0) - emptyVotes' - - votes :: ProposalVotes - votes = case params.initialProposalStatus of - Draft -> emptyVotes - -- With sufficient votes - _ -> outcome0WinningVotes - - proposalStartingTime :: POSIXTime - proposalStartingTime = - let (ProposalStartingTime startingTime) = params.proposalStartingTime - in startingTime - - timeRange :: POSIXTimeRange - timeRange = case params.initialProposalStatus of - -- [S + 1, S + D - 1] - Draft -> - closedBoundedInterval - (proposalStartingTime + 1) - (proposalStartingTime + (def :: ProposalTimingConfig).draftTime - 1) - -- [S + D + V + 1, S + D + V + L - 1] - VotingReady -> - closedBoundedInterval - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - + 1 - ) - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - + (def :: ProposalTimingConfig).lockingTime - - 1 - ) - -- [S + D + V + L + 1, S + + D + V + L + E - 1] - Locked -> - closedBoundedInterval - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - + (def :: ProposalTimingConfig).lockingTime - + 1 - ) - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - + (def :: ProposalTimingConfig).lockingTime - + (def :: ProposalTimingConfig).executingTime - 1 - ) - Finished -> error "Cannot advance 'Finished' proposal" - in mkTransitionTxInfo - params.initialProposalStatus - toStatus - effects - votes - params.proposalStartingTime - timeRange - -{- | Create a valid 'TxInfo' that advances a proposal to failed state, given the parameters. - The reason why the proposal fails is the proposal has ran out of time. - Note that 'TransitionParameters.initialProposalStatus' should not be 'Finished'. --} -advanceProposalFailureTimeout :: TransitionParameters -> TxInfo -advanceProposalFailureTimeout params = - let effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - - emptyVotes@(ProposalVotes emptyVotes') = emptyVotesFor effects - - -- Set the vote count of outcome 0 to @def.countingVoting + 1@, - -- meaning that outcome 0 will be the winner. - outcome0WinningVotes = - ProposalVotes $ - updateMap - (\_ -> Just $ untag (def :: ProposalThresholds).vote + 1) - (ResultTag 0) - emptyVotes' - - votes :: ProposalVotes - votes = case params.initialProposalStatus of - Draft -> emptyVotes - -- With sufficient votes - _ -> outcome0WinningVotes - - proposalStartingTime :: POSIXTime - proposalStartingTime = - let (ProposalStartingTime startingTime) = params.proposalStartingTime - in startingTime - - timeRange :: POSIXTimeRange - timeRange = case params.initialProposalStatus of - -- [S + D + 1, S + D + V - 1] - Draft -> - closedBoundedInterval - (proposalStartingTime + (def :: ProposalTimingConfig).draftTime + 1) - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - 1 - ) - -- [S + D + V + L + 1, S + D + V + L + E -1] - VotingReady -> - closedBoundedInterval - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - + (def :: ProposalTimingConfig).lockingTime - + 1 - ) - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - + (def :: ProposalTimingConfig).lockingTime - + (def :: ProposalTimingConfig).executingTime - - 1 - ) - -- [S + D + V + L + E + 1, S + D + V + L + E + 100] - Locked -> - closedBoundedInterval - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - + (def :: ProposalTimingConfig).lockingTime - + (def :: ProposalTimingConfig).executingTime - + 1 - ) - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - + (def :: ProposalTimingConfig).lockingTime - + (def :: ProposalTimingConfig).executingTime - + 100 - ) - Finished -> error "Cannot advance 'Finished' proposal" - in mkTransitionTxInfo - params.initialProposalStatus - Finished - effects - votes - params.proposalStartingTime - timeRange - True - --- | An invalid 'TxInfo' that tries to advance a 'VotingReady' proposal without sufficient votes. -advanceProposalInsufficientVotes :: TxInfo -advanceProposalInsufficientVotes = - let effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - - -- Insufficient votes. - votes = - ProposalVotes - ( AssocMap.fromList - [ (ResultTag 0, 1) - , (ResultTag 1, 0) - ] - ) - - proposalStartingTime = 0 - - -- Valid time range. - -- [S + D + 1, S + V + 10] - timeRange = - closedBoundedInterval - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - + 1 - ) - ( proposalStartingTime - + (def :: ProposalTimingConfig).draftTime - + (def :: ProposalTimingConfig).votingTime - + 10 - ) - in mkTransitionTxInfo - VotingReady - Locked - effects - votes - (ProposalStartingTime proposalStartingTime) - timeRange - True - --- | An invalid 'TxInfo' that tries to advance a 'Finished' proposal. -advanceFinishedProposal :: TxInfo -advanceFinishedProposal = - let effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - - -- Set the vote count of outcome 0 to @def.countingVoting + 1@, - -- meaning that outcome 0 will be the winner. - outcome0WinningVotes = - ProposalVotes $ - AssocMap.fromList - [ (ResultTag 0, untag (def :: ProposalThresholds).vote + 1) - , (ResultTag 1, 0) - ] - - --- - - timeRange = - closedBoundedInterval - ((def :: ProposalTimingConfig).lockingTime + 1) - ((def :: ProposalTimingConfig).executingTime - 1) - in mkTransitionTxInfo - Finished - Finished - effects - outcome0WinningVotes - (ProposalStartingTime 0) - timeRange - True - -{- | An illegal 'TxInfo' that tries to output a changed stake with 'AdvanceProposal'. - From the perspective of stake validator, the transition is totally valid, - so the proposal validator should reject this. --} -advanceProposalWithInvalidOutputStake :: TxInfo -advanceProposalWithInvalidOutputStake = - let templateTxInfo = - advanceProposalSuccess' - TransitionParameters - { initialProposalStatus = VotingReady - , proposalStartingTime = ProposalStartingTime 0 - } - False - - --- - -- Now we create a new lock on an arbitrary stake - - sst = Value.assetClassValue stakeAssetClass 1 - - --- - - stakeOwner = signer - stakedAmount = 200 - - --- - - existingLocks :: [ProposalLock] - existingLocks = - [ ProposalLock (ResultTag 0) (ProposalId 0) - , ProposalLock (ResultTag 2) (ProposalId 1) - ] - - --- - - stakeInputDatum' :: StakeDatum - stakeInputDatum' = - StakeDatum - { stakedAmount = Tagged stakedAmount - , owner = stakeOwner - , lockedBy = existingLocks - } - stakeInputDatum :: Datum - stakeInputDatum = Datum $ toBuiltinData stakeInputDatum' - stakeInput :: TxOut - stakeInput = - TxOut - { txOutAddress = stakeAddress - , txOutValue = - mconcat - [ sst - , Value.assetClassValue (untag stake.gtClassRef) stakedAmount - , minAda - ] - , txOutDatumHash = Just $ toDatumHash stakeInputDatum - } - - --- - - updatedLocks :: [ProposalLock] - updatedLocks = ProposalLock (ResultTag 42) (ProposalId 27) : existingLocks - - --- - - stakeOutputDatum' :: StakeDatum - stakeOutputDatum' = - stakeInputDatum' - { lockedBy = updatedLocks - } - stakeOutputDatum :: Datum - stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum' - stakeOutput :: TxOut - stakeOutput = - stakeInput - { txOutDatumHash = Just $ toDatumHash stakeOutputDatum - } - in templateTxInfo - { txInfoInputs = TxInInfo stakeRef stakeInput : templateTxInfo.txInfoInputs - , txInfoOutputs = stakeOutput : templateTxInfo.txInfoOutputs - , txInfoData = - (datumPair <$> [stakeInputDatum, stakeOutputDatum]) - <> templateTxInfo.txInfoData - , txInfoSignatories = [stakeOwner] - } diff --git a/agora-specs/Sample/Proposal/Advance.hs b/agora-specs/Sample/Proposal/Advance.hs new file mode 100644 index 0000000..ea3aaed --- /dev/null +++ b/agora-specs/Sample/Proposal/Advance.hs @@ -0,0 +1,509 @@ +module Sample.Proposal.Advance ( + advanceToNextStateInTimeParameters, + advanceToFailedStateDueToTimeoutParameters, + insufficientVotesParameters, + insufficientCosignsParameters, + advanceFromFinishedParameters, + invalidOutputStakeParameters, + mkTestTree, + Parameters (..), +) where + +import Agora.Proposal ( + ProposalDatum (..), + ProposalId (ProposalId), + ProposalRedeemer (AdvanceProposal), + ProposalStatus (..), + ProposalThresholds (..), + ProposalVotes (ProposalVotes), + ResultTag (ResultTag), + emptyVotesFor, + ) +import Agora.Proposal.Scripts (proposalValidator) +import Agora.Proposal.Time ( + ProposalStartingTime (ProposalStartingTime), + ProposalTimingConfig ( + draftTime, + executingTime, + lockingTime, + votingTime + ), + ) +import Agora.SafeMoney (GTTag) +import Agora.Stake ( + ProposalLock (ProposalLock), + Stake (gtClassRef), + StakeDatum (..), + StakeRedeemer (WitnessStake), + ) +import Agora.Stake.Scripts (stakeValidator) +import Data.Coerce (coerce) +import Data.Default (def) +import Data.List (sort) +import Data.Tagged (Tagged (..), untag) +import Plutarch.Context ( + BaseBuilder, + buildTxInfoUnsafe, + input, + output, + script, + signedWith, + timeRange, + txId, + withDatum, + withOutRef, + withTxId, + withValue, + ) +import PlutusLedgerApi.V1 ( + DatumHash, + POSIXTime, + POSIXTimeRange, + PubKeyHash, + ScriptContext (ScriptContext), + ScriptPurpose (Spending), + TxInfo, + TxOutRef (TxOutRef), + ValidatorHash, + always, + ) +import PlutusLedgerApi.V1.Value qualified as Value +import PlutusTx.AssocMap qualified as AssocMap +import Sample.Proposal.Shared (proposalTxRef, stakeTxRef, testFunc) +import Sample.Shared ( + minAda, + proposalPolicySymbol, + proposalValidatorHash, + stake, + stakeAssetClass, + stakeValidatorHash, + ) +import Sample.Shared qualified as Shared +import Test.Specification (SpecificationTree, group) +import Test.Util (closedBoundedInterval, pubKeyHashes, sortValue, updateMap) + +-- | Parameters for state transition of proposals. +data Parameters = Parameters + { fromStatus :: ProposalStatus + -- ^ Initial state of the proposal. + , toStatus :: ProposalStatus + -- ^ Next state of the proposal. + , votes :: ProposalVotes + -- ^ Votes. + , includeAllStakes :: Bool + -- ^ Whether to add an extra cosigner without stake or not. + , validTimeRange :: POSIXTimeRange + -- ^ Valid time range of the transaction. + , alterOutputStakes :: Bool + -- ^ Whether to alter th output stakes or not. + , stakeCount :: Integer + -- ^ The number of stakes. + , signByAllCosigners :: Bool + , perStakeGTs :: Tagged GTTag Integer + } + +--- + +proposalRef :: TxOutRef +proposalRef = TxOutRef proposalTxRef 1 + +mkStakeRef :: Int -> TxOutRef +mkStakeRef = TxOutRef stakeTxRef . (+ 2) . fromIntegral + +--- + +defEffects :: AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash) +defEffects = + AssocMap.fromList + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.empty) + ] + +emptyVotes :: ProposalVotes +emptyVotes = emptyVotesFor defEffects + +proposalStartingTime :: POSIXTime +proposalStartingTime = 0 + +--- + +mkProposalInputDatum :: Parameters -> ProposalDatum +mkProposalInputDatum ps = + ProposalDatum + { proposalId = ProposalId 0 + , effects = defEffects + , status = ps.fromStatus + , cosigners = mkStakeOwners ps + , thresholds = def + , votes = ps.votes + , timingConfig = def + , startingTime = ProposalStartingTime proposalStartingTime + } + +mkStakeInputDatums :: Parameters -> [StakeDatum] +mkStakeInputDatums ps = + map + ( \pk -> + StakeDatum + { stakedAmount = ps.perStakeGTs + , owner = pk + , lockedBy = existingLocks + } + ) + $ mkStakeOwners ps + where + existingLocks :: [ProposalLock] + existingLocks = + [ ProposalLock (ResultTag 0) (ProposalId 0) + , ProposalLock (ResultTag 2) (ProposalId 1) + ] + +--- + +proposalScriptPurpose :: ScriptPurpose +proposalScriptPurpose = Spending proposalRef + +mkStakeScriptPurpose :: Int -> ScriptPurpose +mkStakeScriptPurpose = Spending . mkStakeRef + +--- + +proposalRedeemer :: ProposalRedeemer +proposalRedeemer = AdvanceProposal + +stakeRedeemer :: StakeRedeemer +stakeRedeemer = WitnessStake + +--- + +mkStakeOwners :: Parameters -> [PubKeyHash] +mkStakeOwners ps = + sort $ + take + (fromIntegral ps.stakeCount) + pubKeyHashes + +--- + +-- | Create a 'TxInfo' that update the status of a proposal. +advance :: + Parameters -> + TxInfo +advance ps = + let pst = Value.singleton proposalPolicySymbol "" 1 + sst = Value.assetClassValue stakeAssetClass 1 + + proposalInputDatum :: ProposalDatum + proposalInputDatum = + mkProposalInputDatum ps + + proposalOutputDatum :: ProposalDatum + proposalOutputDatum = + proposalInputDatum + { status = ps.toStatus + } + + stakeInputDatums :: [StakeDatum] + stakeInputDatums = mkStakeInputDatums ps + + mkStakeOutputDatum :: StakeDatum -> StakeDatum + mkStakeOutputDatum si = + if ps.alterOutputStakes + then + si + { stakedAmount = ps.perStakeGTs + 1 + } + else si + + stakeValue = + let gts = + if ps.perStakeGTs == 0 + then mempty + else + Value.assetClassValue + (untag stake.gtClassRef) + (untag ps.perStakeGTs) + in sortValue $ + sst <> minAda + <> gts + + stakeBuilder :: BaseBuilder + stakeBuilder = + foldMap + ( \(si, idx) -> + let so = mkStakeOutputDatum si + in mconcat @BaseBuilder + [ input $ + script stakeValidatorHash + . withValue stakeValue + . withDatum si + . withOutRef (mkStakeRef idx) + , output $ + script stakeValidatorHash + . withValue stakeValue + . withDatum so + ] + ) + $ let withIds = zip stakeInputDatums [0 ..] + in if ps.includeAllStakes + then withIds + else [head withIds] + + signBuilder :: BaseBuilder + signBuilder = + let sos = mkStakeOwners ps + in if ps.signByAllCosigners + then foldMap signedWith sos + else signedWith $ head sos + + builder :: BaseBuilder + builder = + mconcat + [ txId "95ba4015e30aef16a3461ea97a779f814aeea6b8009d99a94add4b8293be737a" + , signBuilder + , timeRange ps.validTimeRange + , input $ + script proposalValidatorHash + . withValue pst + . withDatum proposalInputDatum + . withTxId proposalTxRef + , output $ + script proposalValidatorHash + . withValue (pst <> minAda) + . withDatum proposalOutputDatum + ] + in buildTxInfoUnsafe $ builder <> stakeBuilder + +--- + +mkInTimeTimeRange :: ProposalStatus -> POSIXTimeRange +mkInTimeTimeRange advanceFrom = + case advanceFrom of + -- [S + 1, S + D - 1] + Draft -> + closedBoundedInterval + (proposalStartingTime + 1) + (proposalStartingTime + (def :: ProposalTimingConfig).draftTime - 1) + -- [S + D + V + 1, S + D + V + L - 1] + VotingReady -> + closedBoundedInterval + ( proposalStartingTime + + (def :: ProposalTimingConfig).draftTime + + (def :: ProposalTimingConfig).votingTime + + 1 + ) + ( proposalStartingTime + + (def :: ProposalTimingConfig).draftTime + + (def :: ProposalTimingConfig).votingTime + + (def :: ProposalTimingConfig).lockingTime + - 1 + ) + -- [S + D + V + L + 1, S + + D + V + L + E - 1] + Locked -> + closedBoundedInterval + ( proposalStartingTime + + (def :: ProposalTimingConfig).draftTime + + (def :: ProposalTimingConfig).votingTime + + (def :: ProposalTimingConfig).lockingTime + + 1 + ) + ( proposalStartingTime + + (def :: ProposalTimingConfig).draftTime + + (def :: ProposalTimingConfig).votingTime + + (def :: ProposalTimingConfig).lockingTime + + (def :: ProposalTimingConfig).executingTime - 1 + ) + Finished -> error "Cannot advance 'Finished' proposal" + +mkTooLateTimeRange :: ProposalStatus -> POSIXTimeRange +mkTooLateTimeRange advanceFrom = + case advanceFrom of + -- [S + D + 1, S + D + V - 1] + Draft -> + closedBoundedInterval + (proposalStartingTime + (def :: ProposalTimingConfig).draftTime + 1) + ( proposalStartingTime + + (def :: ProposalTimingConfig).draftTime + + (def :: ProposalTimingConfig).votingTime - 1 + ) + -- [S + D + V + L + 1, S + D + V + L + E -1] + VotingReady -> + closedBoundedInterval + ( proposalStartingTime + + (def :: ProposalTimingConfig).draftTime + + (def :: ProposalTimingConfig).votingTime + + (def :: ProposalTimingConfig).lockingTime + + 1 + ) + ( proposalStartingTime + + (def :: ProposalTimingConfig).draftTime + + (def :: ProposalTimingConfig).votingTime + + (def :: ProposalTimingConfig).lockingTime + + (def :: ProposalTimingConfig).executingTime + - 1 + ) + -- [S + D + V + L + E + 1, S + D + V + L + E + 100] + Locked -> + closedBoundedInterval + ( proposalStartingTime + + (def :: ProposalTimingConfig).draftTime + + (def :: ProposalTimingConfig).votingTime + + (def :: ProposalTimingConfig).lockingTime + + (def :: ProposalTimingConfig).executingTime + + 1 + ) + ( proposalStartingTime + + (def :: ProposalTimingConfig).draftTime + + (def :: ProposalTimingConfig).votingTime + + (def :: ProposalTimingConfig).lockingTime + + (def :: ProposalTimingConfig).executingTime + + 100 + ) + Finished -> error "Cannot advance 'Finished' proposal" + +--- + +getNextState :: ProposalStatus -> ProposalStatus +getNextState = \case + Draft -> VotingReady + VotingReady -> Locked + Locked -> Finished + Finished -> error "Cannot advance 'Finished' proposal" + +--- + +advanceToNextStateInTimeParameters :: Int -> [Parameters] +advanceToNextStateInTimeParameters nCosigners = + map + ( \from -> + let -- Set the vote count of outcome 0 to @def.countingVoting + 1@, + -- meaning that outcome 0 will be the winner. + outcome0WinningVotes = + ProposalVotes $ + updateMap + (\_ -> Just $ untag (def :: ProposalThresholds).execute + 1) + (ResultTag 0) + (coerce emptyVotes) + + votes = case from of + Draft -> emptyVotes + -- With sufficient votes + _ -> outcome0WinningVotes + + includeAllStakes = case from of + Draft -> True + _ -> False + + signByAllCosigners = case from of + Draft -> True + _ -> False + in Parameters + { fromStatus = from + , toStatus = getNextState from + , votes = votes + , includeAllStakes = includeAllStakes + , validTimeRange = mkInTimeTimeRange from + , alterOutputStakes = False + , stakeCount = fromIntegral nCosigners + , signByAllCosigners = signByAllCosigners + , perStakeGTs = + (def :: ProposalThresholds).vote + `div` fromIntegral nCosigners + 1 + } + ) + [Draft, VotingReady, Locked] + +advanceToFailedStateDueToTimeoutParameters :: Int -> [Parameters] +advanceToFailedStateDueToTimeoutParameters nCosigners = + map + ( \from -> + Parameters + { fromStatus = from + , toStatus = Finished + , votes = emptyVotes + , includeAllStakes = False + , validTimeRange = mkTooLateTimeRange from + , alterOutputStakes = False + , stakeCount = fromIntegral nCosigners + , signByAllCosigners = False + , perStakeGTs = 1 + } + ) + [Draft, VotingReady, Locked] + +insufficientVotesParameters :: Parameters +insufficientVotesParameters = + let votes = emptyVotes + from = VotingReady + to = getNextState from + in Parameters + { fromStatus = from + , toStatus = to + , votes = votes + , includeAllStakes = False + , validTimeRange = mkInTimeTimeRange from + , alterOutputStakes = False + , stakeCount = 1 + , signByAllCosigners = True + , perStakeGTs = 20 + } + +insufficientCosignsParameters :: Int -> Parameters +insufficientCosignsParameters nCosigners = + (\ps -> ps {perStakeGTs = 0}) $ + head $ + advanceToNextStateInTimeParameters nCosigners + +advanceFromFinishedParameters :: Parameters +advanceFromFinishedParameters = + Parameters + { fromStatus = Finished + , toStatus = Finished + , votes = emptyVotes + , includeAllStakes = False + , validTimeRange = always + , alterOutputStakes = False + , stakeCount = 1 + , signByAllCosigners = True + , perStakeGTs = 20 + } + +invalidOutputStakeParameters :: Int -> [Parameters] +invalidOutputStakeParameters nCosigners = + (\ps -> ps {alterOutputStakes = True}) + <$> advanceToNextStateInTimeParameters nCosigners + +--- + +mkTestTree :: String -> Parameters -> Bool -> SpecificationTree +mkTestTree name ps isValidForProposalValidator = group name [proposal, stake] + where + txInfo = advance ps + + proposal = + let proposalInputDatum = mkProposalInputDatum ps + in testFunc + isValidForProposalValidator + "propsoal" + (proposalValidator Shared.proposal) + proposalInputDatum + proposalRedeemer + ( ScriptContext + txInfo + proposalScriptPurpose + ) + + stake = + let idx = 0 + stakeInputDatum = mkStakeInputDatums ps !! idx + isValid = not $ ps.alterOutputStakes + in testFunc + isValid + "stake" + (stakeValidator Shared.stake) + stakeInputDatum + stakeRedeemer + ( ScriptContext + txInfo + (mkStakeScriptPurpose idx) + ) diff --git a/agora-specs/Sample/Proposal/Cosign.hs b/agora-specs/Sample/Proposal/Cosign.hs new file mode 100644 index 0000000..f04535a --- /dev/null +++ b/agora-specs/Sample/Proposal/Cosign.hs @@ -0,0 +1,344 @@ +module Sample.Proposal.Cosign ( + Parameters (..), + validCosignNParameters, + duplicateCosignersParameters, + statusNotDraftCosignNParameters, + invalidStakeOutputParameters, + mkTestTree, +) where + +import Agora.Proposal ( + ProposalDatum (..), + ProposalId (ProposalId), + ProposalRedeemer (Cosign), + ProposalStatus (..), + ResultTag (ResultTag), + emptyVotesFor, + ) +import Agora.Proposal.Scripts (proposalValidator) +import Agora.Proposal.Time ( + ProposalStartingTime (ProposalStartingTime), + ProposalTimingConfig (draftTime), + ) +import Agora.SafeMoney (GTTag) +import Agora.Stake ( + Stake (gtClassRef), + StakeDatum (StakeDatum, owner), + StakeRedeemer (WitnessStake), + stakedAmount, + ) +import Agora.Stake.Scripts (stakeValidator) +import Data.Coerce (coerce) +import Data.Default (def) +import Data.List (sort) +import Data.Tagged (Tagged, untag) +import Plutarch.Context ( + BaseBuilder, + buildTxInfoUnsafe, + input, + output, + script, + signedWith, + timeRange, + txId, + withDatum, + withRefIndex, + withTxId, + withValue, + ) +import PlutusLedgerApi.V1 ( + POSIXTimeRange, + PubKeyHash, + ScriptContext (ScriptContext), + ScriptPurpose (Spending), + TxInfo, + TxOutRef (..), + Value, + ) +import PlutusLedgerApi.V1.Value qualified as Value +import PlutusTx.AssocMap qualified as AssocMap +import Sample.Proposal.Shared (proposalTxRef, stakeTxRef, testFunc) +import Sample.Shared ( + minAda, + proposalPolicySymbol, + proposalValidatorHash, + signer, + stake, + stakeAssetClass, + stakeValidatorHash, + ) +import Sample.Shared qualified as Shared +import Test.Specification ( + SpecificationTree, + group, + ) +import Test.Util (closedBoundedInterval, pubKeyHashes, sortValue) + +-- | Parameters for cosigning a proposal. +data Parameters = Parameters + { newCosigners :: [PubKeyHash] + -- ^ New cosigners to be added, and the owners of the generated stakes. + , proposalStatus :: ProposalStatus + -- ^ Current state of the proposal. + , alterOutputStakes :: Bool + -- ^ Whether to generate invalid stake outputs. + -- In particular, the 'stakedAmount' of all the stake datums will be set to zero. + } + +-- | Owner of the creator stake, doesn't really matter in this case. +proposalCreator :: PubKeyHash +proposalCreator = signer + +-- | The amount of GTs every generated stake has, doesn't really matter in this case. +perStakedGTs :: Tagged GTTag Integer +perStakedGTs = 5 + +{- | Create input proposal datum given the parameters. + In particular, 'status' is set to 'proposalStstus'. +-} +mkProposalInputDatum :: Parameters -> ProposalDatum +mkProposalInputDatum ps = + let effects = + AssocMap.fromList + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.empty) + ] + in ProposalDatum + { proposalId = ProposalId 0 + , effects = effects + , status = ps.proposalStatus + , cosigners = [proposalCreator] + , thresholds = def + , votes = emptyVotesFor effects + , timingConfig = def + , startingTime = ProposalStartingTime 0 + } + +{- | Create the output proposal datum given the parameters. + The 'newCosigners' is added to the exisiting list of cosigners, note the said list should be sorted in + ascending order. +-} +mkProposalOutputDatum :: Parameters -> ProposalDatum +mkProposalOutputDatum ps = + let inputDatum = mkProposalInputDatum ps + in inputDatum + { cosigners = sort $ inputDatum.cosigners <> ps.newCosigners + } + +-- | Create all the input stakes given the parameters. +mkStakeInputDatums :: Parameters -> [StakeDatum] +mkStakeInputDatums = fmap (\pk -> StakeDatum perStakedGTs pk []) . newCosigners + +-- | Create a 'TxInfo' that tries to cosign a proposal with new cosigners. +cosign :: Parameters -> TxInfo +cosign ps = buildTxInfoUnsafe builder + where + pst = Value.singleton proposalPolicySymbol "" 1 + sst = Value.assetClassValue stakeAssetClass 1 + + --- + + stakeInputDatums :: [StakeDatum] + stakeInputDatums = mkStakeInputDatums ps + + stakeValue :: Value + stakeValue = + sortValue $ + minAda + <> Value.assetClassValue + (untag stake.gtClassRef) + (untag perStakedGTs) + <> sst + + stakeBuilder :: BaseBuilder + stakeBuilder = + foldMap + ( \(stakeDatum, refIdx) -> + let stakeOutputDatum = + if ps.alterOutputStakes + then stakeDatum {stakedAmount = 0} + else stakeDatum + in mconcat @BaseBuilder + [ input $ + script stakeValidatorHash + . withValue stakeValue + . withDatum stakeDatum + . withTxId stakeTxRef + . withRefIndex refIdx + , output $ + script stakeValidatorHash + . withValue stakeValue + . withDatum stakeOutputDatum + , signedWith stakeDatum.owner + ] + ) + $ zip + stakeInputDatums + [2 ..] + + --- + + proposalInputDatum :: ProposalDatum + proposalInputDatum = mkProposalInputDatum ps + + proposalOutputDatum :: ProposalDatum + proposalOutputDatum = mkProposalOutputDatum ps + + proposalBuilder :: BaseBuilder + proposalBuilder = + mconcat + [ input $ + script proposalValidatorHash + . withValue pst + . withDatum proposalInputDatum + . withTxId proposalTxRef + . withRefIndex proposalRefIdx + , output $ + script proposalValidatorHash + . withValue (sortValue (pst <> minAda)) + . withDatum proposalOutputDatum + ] + + validTimeRange :: POSIXTimeRange + validTimeRange = + closedBoundedInterval + (coerce proposalInputDatum.startingTime + 1) + ( coerce proposalInputDatum.startingTime + + proposalInputDatum.timingConfig.draftTime - 1 + ) + + --- + + builder :: BaseBuilder + builder = + mconcat + [ txId "05c67819fc3381a2052b929ab439244b7b5fe3b3bd07f2134055bbbb21bd9e52" + , timeRange validTimeRange + , proposalBuilder + , stakeBuilder + ] + +-- | Reference index of the proposal UTXO. +proposalRefIdx :: Integer +proposalRefIdx = 1 + +-- | Spend the proposal ST. +proposalScriptPurpose :: ScriptPurpose +proposalScriptPurpose = + Spending + ( TxOutRef + proposalTxRef + proposalRefIdx + ) + +-- | Consume the given stake. +mkStakeScriptPurpose :: Int -> ScriptPurpose +mkStakeScriptPurpose idx = + Spending $ + TxOutRef + stakeTxRef + $ proposalRefIdx + 1 + fromIntegral idx + +-- | Create a proposal redeemer which cosigns with the new cosginers. +mkProposalRedeemer :: Parameters -> ProposalRedeemer +mkProposalRedeemer (sort . newCosigners -> cs) = Cosign cs + +-- | Stake redeemer for cosuming all the stakes generated in the module. +stakeRedeemer :: StakeRedeemer +stakeRedeemer = WitnessStake + +--- + +-- | Create a valid parameters that cosign the proposal with a given number of cosigners. +validCosignNParameters :: Int -> Parameters +validCosignNParameters n + | n > 0 = + Parameters + { newCosigners = take n pubKeyHashes + , proposalStatus = Draft + , alterOutputStakes = False + } + | otherwise = error "Number of cosigners should be positive" + +--- + +{- | Parameters that make 'cosign' yield duplicate cosigners. + Invalid for the ptoposal validator, perfectly valid for stake validator. +-} +duplicateCosignersParameters :: Parameters +duplicateCosignersParameters = + Parameters + { newCosigners = [proposalCreator] + , proposalStatus = Draft + , alterOutputStakes = False + } + +--- + +{- | Generate a list of parameters that sets proposal status to something other than 'Draft'. + Invalid for the ptoposal validator, perfectly valid for stake validator. +-} +statusNotDraftCosignNParameters :: Int -> [Parameters] +statusNotDraftCosignNParameters n = + map + ( \st -> + Parameters + { newCosigners = take n pubKeyHashes + , proposalStatus = st + , alterOutputStakes = False + } + ) + [VotingReady, Locked, Finished] + +--- + +{- | Parameters thet change the output stake datums. + Invalid for both proposal validator and stake validator. +-} +invalidStakeOutputParameters :: Parameters +invalidStakeOutputParameters = + (validCosignNParameters 2) + { alterOutputStakes = True + } + +--- + +-- | Create a test tree given the parameters. Both the proposal validator and stake validator will be run. +mkTestTree :: + -- | The name of the test group. + String -> + Parameters -> + -- | Are the parameters valid for the proposal validator? + Bool -> + SpecificationTree +mkTestTree name ps isValid = group name [proposal, stake] + where + txInfo = cosign ps + + proposal = + let proposalInputDatum = mkProposalInputDatum ps + in testFunc + isValid + "propsoal" + (proposalValidator Shared.proposal) + proposalInputDatum + (mkProposalRedeemer ps) + ( ScriptContext + txInfo + proposalScriptPurpose + ) + + stake = + let idx = 0 + stakeInputDatum = mkStakeInputDatums ps !! idx + isValid = not ps.alterOutputStakes + in testFunc + isValid + "stake" + (stakeValidator Shared.stake) + stakeInputDatum + stakeRedeemer + ( ScriptContext + txInfo + (mkStakeScriptPurpose idx) + ) diff --git a/agora-specs/Sample/Proposal/Shared.hs b/agora-specs/Sample/Proposal/Shared.hs index 1a2ee64..17028ee 100644 --- a/agora-specs/Sample/Proposal/Shared.hs +++ b/agora-specs/Sample/Proposal/Shared.hs @@ -1,9 +1,39 @@ -module Sample.Proposal.Shared (proposalRef, stakeRef) where +module Sample.Proposal.Shared (proposalTxRef, stakeTxRef, testFunc) where -import PlutusLedgerApi.V1 (TxOutRef (..)) +import Plutarch.Api.V1 (PValidator) +import Plutarch.Lift (PUnsafeLiftDecl (..)) +import PlutusLedgerApi.V1 (ScriptContext, ToData, TxId) +import Test.Specification ( + SpecificationTree, + validatorFailsWith, + validatorSucceedsWith, + ) -proposalRef :: TxOutRef -proposalRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1 +-- | 'TxId' of all the propsoal inputs in the samples. +proposalTxRef :: TxId +proposalTxRef = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" -stakeRef :: TxOutRef -stakeRef = TxOutRef "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" 0 +-- | 'TxId' of all the stake inputs in the samples. +stakeTxRef :: TxId +stakeTxRef = "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" + +-- | Get the test function given whether a test case is valid. +testFunc :: + forall {datum :: PType} {redeemer :: PType}. + ( PUnsafeLiftDecl datum + , PUnsafeLiftDecl redeemer + , ToData (PLifted datum) + , ToData (PLifted redeemer) + ) => + -- | Should the validator pass? + Bool -> + String -> + ClosedTerm PValidator -> + PLifted datum -> + PLifted redeemer -> + ScriptContext -> + SpecificationTree +testFunc isValid = + if isValid + then validatorSucceedsWith + else validatorFailsWith diff --git a/agora-specs/Sample/Proposal/UnlockStake.hs b/agora-specs/Sample/Proposal/UnlockStake.hs index d8ac396..da8b4e5 100644 --- a/agora-specs/Sample/Proposal/UnlockStake.hs +++ b/agora-specs/Sample/Proposal/UnlockStake.hs @@ -11,6 +11,33 @@ module Sample.Proposal.UnlockStake ( -------------------------------------------------------------------------------- +import Agora.Proposal ( + ProposalDatum (..), + ProposalId (..), + ProposalRedeemer (Unlock), + ProposalStatus (..), + ProposalVotes (..), + ResultTag (..), + ) +import Agora.Proposal.Scripts (proposalValidator) +import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime)) +import Agora.Stake (ProposalLock (ProposalLock), Stake (..), StakeDatum (..)) +import Control.Monad (join) +import Data.Coerce (coerce) +import Data.Default.Class (Default (def)) +import Data.Tagged (Tagged (..), untag) +import Plutarch.Context ( + BaseBuilder, + buildTxInfoUnsafe, + input, + output, + script, + txId, + withDatum, + withRefIndex, + withTxId, + withValue, + ) import PlutusLedgerApi.V1 ( DatumHash, ScriptContext (..), @@ -21,19 +48,7 @@ import PlutusLedgerApi.V1 ( ) import PlutusLedgerApi.V1.Value qualified as Value import PlutusTx.AssocMap qualified as AssocMap - --------------------------------------------------------------------------------- - -import Agora.Proposal ( - ProposalDatum (..), - ProposalId (..), - ProposalRedeemer (Unlock), - ProposalStatus (..), - ProposalVotes (..), - ResultTag (..), - ) -import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime)) -import Agora.Stake (ProposalLock (ProposalLock), Stake (..), StakeDatum (..)) +import Sample.Proposal.Shared (proposalTxRef, stakeTxRef, testFunc) import Sample.Shared ( minAda, proposalPolicySymbol, @@ -43,19 +58,9 @@ import Sample.Shared ( stakeAssetClass, stakeValidatorHash, ) -import Test.Util (sortValue, updateMap) - --------------------------------------------------------------------------------- - -import Agora.Proposal.Scripts (proposalValidator) -import Control.Monad (join) -import Data.Coerce (coerce) -import Data.Default.Class (Default (def)) -import Data.Tagged (Tagged (..), untag) -import Plutarch.Context (BaseBuilder, buildTxInfoUnsafe, input, output, script, txId, withDatum, withRefIndex, withTxId, withValue) -import Sample.Proposal.Shared (proposalRef, stakeRef) import Sample.Shared qualified as Shared -import Test.Specification (SpecificationTree, validatorFailsWith, validatorSucceedsWith) +import Test.Specification (SpecificationTree) +import Test.Util (sortValue, updateMap) -------------------------------------------------------------------------------- @@ -223,8 +228,8 @@ unlockStake p = script proposalValidatorHash . withValue pst . withDatum i - . withTxId (txOutRefId proposalRef) - . withRefIndex (txOutRefIdx proposalRef + coerce i.proposalId) + . withTxId proposalTxRef + . withRefIndex (coerce i.proposalId + 2) , output $ script proposalValidatorHash . withValue (sortValue $ pst <> minAda) @@ -249,8 +254,8 @@ unlockStake p = script stakeValidatorHash . withValue stakeValue . withDatum sInDatum - . withTxId (txOutRefId stakeRef) - . withRefIndex (txOutRefIdx stakeRef) + . withTxId stakeTxRef + . withRefIndex 1 , output $ script stakeValidatorHash . withValue stakeValue @@ -271,6 +276,14 @@ mkProposalValidatorTestCase p shouldSucceed = let datum = mkProposalInputDatum p $ ProposalId 0 redeemer = Unlock (ResultTag 0) name = show p - scriptContext = ScriptContext (unlockStake p) (Spending proposalRef) - f = if shouldSucceed then validatorSucceedsWith else validatorFailsWith - in f name (proposalValidator Shared.proposal) datum redeemer scriptContext + scriptContext = + ScriptContext + (unlockStake p) + (Spending (TxOutRef proposalTxRef 2)) + in testFunc + shouldSucceed + name + (proposalValidator Shared.proposal) + datum + redeemer + scriptContext diff --git a/agora-specs/Sample/Proposal/Vote.hs b/agora-specs/Sample/Proposal/Vote.hs new file mode 100644 index 0000000..f06ac7e --- /dev/null +++ b/agora-specs/Sample/Proposal/Vote.hs @@ -0,0 +1,249 @@ +module Sample.Proposal.Vote ( + validVoteParameters, + mkTestTree, +) where + +import Agora.Proposal ( + ProposalDatum (..), + ProposalId (ProposalId), + ProposalRedeemer (Vote), + ProposalStatus (VotingReady), + ProposalVotes (ProposalVotes), + ResultTag (ResultTag), + ) +import Agora.Proposal.Scripts (proposalValidator) +import Agora.Proposal.Time ( + ProposalStartingTime (ProposalStartingTime), + ProposalTimingConfig (draftTime, votingTime), + ) +import Agora.Stake ( + ProposalLock (ProposalLock), + Stake (gtClassRef), + StakeDatum (..), + StakeRedeemer (PermitVote), + ) +import Agora.Stake.Scripts (stakeValidator) +import Data.Default (Default (def)) +import Data.Tagged (Tagged (Tagged), untag) +import Plutarch.Context ( + BaseBuilder, + buildTxInfoUnsafe, + input, + output, + script, + signedWith, + timeRange, + txId, + withDatum, + withOutRef, + withValue, + ) +import PlutusLedgerApi.V1 ( + PubKeyHash, + ScriptContext (..), + ScriptPurpose (Spending), + TxInfo, + TxOutRef (TxOutRef), + ) +import PlutusLedgerApi.V1.Value qualified as Value +import PlutusTx.AssocMap qualified as AssocMap +import Sample.Proposal.Shared (proposalTxRef, stakeTxRef, testFunc) +import Sample.Shared ( + minAda, + proposalPolicySymbol, + proposalValidatorHash, + signer, + stake, + stakeAssetClass, + stakeValidatorHash, + ) +import Sample.Shared qualified as Shared +import Test.Specification ( + SpecificationTree, + group, + validatorSucceedsWith, + ) +import Test.Util (closedBoundedInterval, sortValue, updateMap) + +proposalRef :: TxOutRef +proposalRef = TxOutRef proposalTxRef 0 + +stakeRef :: TxOutRef +stakeRef = TxOutRef stakeTxRef 1 + +-- | Parameters for creating a voting transaction. +data Parameters = Parameters + { voteFor :: ResultTag + -- ^ The outcome the transaction is voting for. + , voteCount :: Integer + -- ^ The count of votes. + } + +stakeOwner :: PubKeyHash +stakeOwner = signer + +initialVotes :: AssocMap.Map ResultTag Integer +initialVotes = + AssocMap.fromList + [ (ResultTag 0, 42) + , (ResultTag 1, 4242) + ] + +proposalInputDatum :: ProposalDatum +proposalInputDatum = + ProposalDatum + { proposalId = ProposalId 42 + , effects = + AssocMap.fromList + [ (ResultTag 0, AssocMap.empty) + , (ResultTag 1, AssocMap.empty) + ] + , status = VotingReady + , cosigners = [stakeOwner] + , thresholds = def + , votes = ProposalVotes initialVotes + , timingConfig = def + , startingTime = ProposalStartingTime 0 + } + +existingLocks :: [ProposalLock] +existingLocks = + [ ProposalLock (ResultTag 0) (ProposalId 0) + , ProposalLock (ResultTag 2) (ProposalId 1) + ] + +mkStakeInputDatum :: Parameters -> StakeDatum +mkStakeInputDatum params = + StakeDatum + { stakedAmount = Tagged params.voteCount + , owner = stakeOwner + , lockedBy = existingLocks + } + +mkProposalRedeemer :: Parameters -> ProposalRedeemer +mkProposalRedeemer = Vote . voteFor + +mkNewLock :: Parameters -> ProposalLock +mkNewLock ps = ProposalLock ps.voteFor proposalInputDatum.proposalId + +mkStakeRedeemer :: Parameters -> StakeRedeemer +mkStakeRedeemer = PermitVote . mkNewLock + +-- | Create a valid transaction that votes on a propsal, given the parameters. +vote :: Parameters -> TxInfo +vote params = + let pst = Value.singleton proposalPolicySymbol "" 1 + sst = Value.assetClassValue stakeAssetClass 1 + + --- + + stakeInputDatum = mkStakeInputDatum params + + --- + + updatedVotes :: AssocMap.Map ResultTag Integer + updatedVotes = updateMap (Just . (+ params.voteCount)) params.voteFor initialVotes + + --- + + proposalOutputDatum :: ProposalDatum + proposalOutputDatum = + proposalInputDatum + { votes = ProposalVotes updatedVotes + } + + --- + + -- Off-chain code should do exactly like this: prepend new lock toStatus the list. + updatedLocks :: [ProposalLock] + updatedLocks = mkNewLock params : existingLocks + + --- + + stakeOutputDatum :: StakeDatum + stakeOutputDatum = + stakeInputDatum + { lockedBy = updatedLocks + } + + --- + + validTimeRange = + closedBoundedInterval + ((def :: ProposalTimingConfig).draftTime + 1) + ((def :: ProposalTimingConfig).votingTime - 1) + + --- + + stakeValue = + sortValue $ + sst + <> Value.assetClassValue (untag stake.gtClassRef) params.voteCount + <> minAda + + builder :: BaseBuilder + builder = + mconcat + [ txId "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c" + , signedWith stakeOwner + , timeRange validTimeRange + , input $ + script proposalValidatorHash + . withValue pst + . withDatum proposalInputDatum + . withOutRef proposalRef + , input $ + script stakeValidatorHash + . withValue stakeValue + . withDatum stakeInputDatum + . withOutRef stakeRef + , output $ + script proposalValidatorHash + . withValue pst + . withDatum proposalOutputDatum + , output $ + script stakeValidatorHash + . withValue stakeValue + . withDatum stakeOutputDatum + ] + in buildTxInfoUnsafe builder + +--- + +validVoteParameters :: Parameters +validVoteParameters = + Parameters + { voteFor = ResultTag 0 + , voteCount = 27 + } + +--- + +mkTestTree :: String -> Parameters -> Bool -> SpecificationTree +mkTestTree name ps isValid = group name [proposal, stake] + where + txInfo = vote ps + + proposal = + testFunc + isValid + "propsoal" + (proposalValidator Shared.proposal) + proposalInputDatum + (mkProposalRedeemer ps) + ( ScriptContext + txInfo + (Spending proposalRef) + ) + + stake = + let stakeInputDatum = mkStakeInputDatum ps + in validatorSucceedsWith + "stake" + (stakeValidator Shared.stake) + stakeInputDatum + (mkStakeRedeemer ps) + ( ScriptContext + txInfo + (Spending stakeRef) + ) diff --git a/agora-specs/Spec/Proposal.hs b/agora-specs/Spec/Proposal.hs index 41234a1..a3c54df 100644 --- a/agora-specs/Spec/Proposal.hs +++ b/agora-specs/Spec/Proposal.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} - {- | Module : Spec.Proposal Maintainer : emi@haskell.fyi @@ -11,45 +9,19 @@ module Spec.Proposal (specs) where import Agora.Proposal ( Proposal (..), - ProposalDatum (..), - ProposalId (ProposalId), - ProposalRedeemer (..), ProposalStatus (..), - ProposalThresholds (..), - ProposalVotes (ProposalVotes), - ResultTag (ResultTag), - cosigners, - effects, - emptyVotesFor, - proposalId, - status, - thresholds, - votes, ) -import Agora.Proposal.Scripts (proposalPolicy, proposalValidator) -import Agora.Proposal.Time ( - ProposalStartingTime (ProposalStartingTime), - ) -import Agora.Stake ( - ProposalLock (ProposalLock), - StakeDatum (StakeDatum), - StakeRedeemer (PermitVote, WitnessStake), - ) -import Agora.Stake.Scripts (stakeValidator) -import Data.Default.Class (Default (def)) -import Data.Tagged (Tagged (Tagged), untag) -import PlutusLedgerApi.V1 (ScriptContext (..), ScriptPurpose (..)) -import PlutusTx.AssocMap qualified as AssocMap +import Agora.Proposal.Scripts (proposalPolicy) import Sample.Proposal qualified as Proposal +import Sample.Proposal.Advance qualified as Advance +import Sample.Proposal.Cosign qualified as Cosign import Sample.Proposal.UnlockStake qualified as UnlockStake -import Sample.Shared (signer, signer2) -import Sample.Shared qualified as Shared (proposal, stake) +import Sample.Proposal.Vote qualified as Vote +import Sample.Shared qualified as Shared (proposal) import Test.Specification ( SpecificationTree, group, policySucceedsWith, - validatorFailsWith, - validatorSucceedsWith, ) -- | Stake specs. @@ -67,279 +39,133 @@ specs = "validator" [ group "cosignature" - [ validatorSucceedsWith - "proposal" - (proposalValidator Shared.proposal) - ( ProposalDatum - { proposalId = ProposalId 0 - , effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - , status = Draft - , cosigners = [signer] - , thresholds = def - , votes = - emptyVotesFor $ - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - , timingConfig = def - , startingTime = ProposalStartingTime 0 - } - ) - (Cosign [signer2]) - (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.proposalRef)) - , validatorSucceedsWith - "stake" - (stakeValidator Shared.stake) - (StakeDatum (Tagged 50_000_000) signer2 []) - WitnessStake - (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef)) - ] + $ let cosignerCases = [1, 5, 10] + + mkLegalGroup nCosigners = + Cosign.mkTestTree + ("with " <> show nCosigners <> " cosigners") + (Cosign.validCosignNParameters nCosigners) + True + legalGroup = + group "legal" $ + map mkLegalGroup cosignerCases + + mkIllegalStatusNotDraftGroup nCosigners = + group ("with " <> show nCosigners <> " cosigners") $ + map + ( \ps -> + Cosign.mkTestTree + ("status: " <> show ps.proposalStatus) + ps + False + ) + (Cosign.statusNotDraftCosignNParameters nCosigners) + illegalStatusNotDraftGroup = + group "proposal status not Draft" $ + map mkIllegalStatusNotDraftGroup cosignerCases + + illegalGroup = + group + "illegal" + [ Cosign.mkTestTree + "duplicate cosigners" + Cosign.duplicateCosignersParameters + False + , Cosign.mkTestTree + "altered output stake" + Cosign.invalidStakeOutputParameters + False + , illegalStatusNotDraftGroup + ] + in [legalGroup, illegalGroup] , group "voting" - [ validatorSucceedsWith - "proposal" - (proposalValidator Shared.proposal) - ( ProposalDatum - { proposalId = ProposalId 42 - , effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) + [ Vote.mkTestTree "legal" Vote.validVoteParameters True + -- TODO: add negative test cases + ] + , group "advancing" $ + let mkFromDraft nCosigners = + let name = "with " <> show nCosigners <> " cosigner(s)" + + legalGroup = + group + "legal" + [ Advance.mkTestTree + "to next state" + ( head $ + Advance.advanceToNextStateInTimeParameters + nCosigners + ) + True + , Advance.mkTestTree + "to failed state" + ( head $ + Advance.advanceToFailedStateDueToTimeoutParameters + nCosigners + ) + True ] - , status = VotingReady - , cosigners = [signer] - , thresholds = def - , votes = - ProposalVotes - ( AssocMap.fromList - [ (ResultTag 0, 42) - , (ResultTag 1, 4242) - ] + + illegalGroup = + group + "illegal" + [ Advance.mkTestTree + "insufficient cosigns" + (Advance.insufficientCosignsParameters nCosigners) + False + , Advance.mkTestTree + "invalid stake output" + (head $ Advance.invalidOutputStakeParameters nCosigners) + False + ] + in group name [legalGroup, illegalGroup] + + draftGroup = group "from draft" $ map mkFromDraft [1, 5, 10] + + legalGroup = + group + "legal" + [ group "advance to next state" $ + map + ( \ps -> + let name = "from: " <> show ps.fromStatus + in Advance.mkTestTree name ps True ) - , timingConfig = def - , startingTime = ProposalStartingTime 0 - } - ) - (Vote (ResultTag 0)) - ( ScriptContext - ( Proposal.voteOnProposal - Proposal.VotingParameters - { Proposal.voteFor = ResultTag 0 - , Proposal.voteCount = 27 - } - ) - (Spending Proposal.proposalRef) - ) - , validatorSucceedsWith - "stake" - (stakeValidator Shared.stake) - ( StakeDatum - (Tagged 27) - signer - [ ProposalLock (ResultTag 0) (ProposalId 0) - , ProposalLock (ResultTag 2) (ProposalId 1) + (tail $ Advance.advanceToNextStateInTimeParameters 1) + , group "advance to failed state" $ + map + ( \ps -> + let name = "from: " <> show ps.fromStatus + in Advance.mkTestTree name ps True + ) + (tail $ Advance.advanceToFailedStateDueToTimeoutParameters 1) ] - ) - (PermitVote $ ProposalLock (ResultTag 0) (ProposalId 42)) - ( ScriptContext - ( Proposal.voteOnProposal - Proposal.VotingParameters - { Proposal.voteFor = ResultTag 0 - , Proposal.voteCount = 27 - } - ) - (Spending Proposal.stakeRef) - ) - ] - , group - "advancing" - [ group "successfully advance to next state" $ - map - ( \(name, initialState) -> - validatorSucceedsWith - name - (proposalValidator Shared.proposal) - ( ProposalDatum - { proposalId = ProposalId 0 - , effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - , status = initialState - , cosigners = [signer] - , thresholds = def - , votes = - ProposalVotes - ( AssocMap.fromList - [ - ( ResultTag 0 - , case initialState of - Draft -> 0 - _ -> untag (def :: ProposalThresholds).execute + 1 - ) - , (ResultTag 1, 0) - ] - ) - , timingConfig = def - , startingTime = ProposalStartingTime 0 - } - ) - AdvanceProposal - ( ScriptContext - ( Proposal.advanceProposalSuccess - Proposal.TransitionParameters - { Proposal.initialProposalStatus = initialState - , Proposal.proposalStartingTime = ProposalStartingTime 0 - } - ) - (Spending Proposal.proposalRef) - ) - ) - [ ("Draft -> VotringReady", Draft) - , ("VotingReady -> Locked", VotingReady) - , ("Locked -> Finished", Locked) - ] - , group "successfully advance to failed state: timeout" $ - map - ( \(name, initialState) -> - validatorSucceedsWith - name - (proposalValidator Shared.proposal) - ( ProposalDatum - { proposalId = ProposalId 0 - , effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - , status = initialState - , cosigners = [signer] - , thresholds = def - , votes = - ProposalVotes - ( AssocMap.fromList - [ - ( ResultTag 0 - , case initialState of - Draft -> 0 - _ -> untag (def :: ProposalThresholds).vote + 1 - ) - , (ResultTag 1, 0) - ] - ) - , timingConfig = def - , startingTime = ProposalStartingTime 0 - } - ) - AdvanceProposal - ( ScriptContext - ( Proposal.advanceProposalFailureTimeout - Proposal.TransitionParameters - { Proposal.initialProposalStatus = initialState - , Proposal.proposalStartingTime = ProposalStartingTime 0 - } - ) - (Spending Proposal.proposalRef) - ) - ) - [ ("Draft -> Finished", Draft) - , ("VotingReady -> Finished", VotingReady) - , ("Locked -> Finished", Locked) - ] - , validatorFailsWith - "illegal: insufficient votes" - (proposalValidator Shared.proposal) - ( ProposalDatum - { proposalId = ProposalId 0 - , effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - , status = VotingReady - , cosigners = [signer] - , thresholds = def - , votes = - ProposalVotes - ( AssocMap.fromList - [ (ResultTag 0, 1) - , (ResultTag 1, 0) - ] - ) - , timingConfig = def - , startingTime = ProposalStartingTime 0 - } - ) - AdvanceProposal - ( ScriptContext - Proposal.advanceProposalInsufficientVotes - (Spending Proposal.proposalRef) - ) - , validatorFailsWith - "illegal: initial state is Finished" - (proposalValidator Shared.proposal) - ( ProposalDatum - { proposalId = ProposalId 0 - , effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - , status = Finished - , cosigners = [signer] - , thresholds = def - , votes = - ProposalVotes - ( AssocMap.fromList - [ (ResultTag 0, untag (def :: ProposalThresholds).vote + 1) - , (ResultTag 1, 0) - ] - ) - , timingConfig = def - , startingTime = ProposalStartingTime 0 - } - ) - AdvanceProposal - ( ScriptContext - Proposal.advanceFinishedProposal - (Spending Proposal.proposalRef) - ) - , validatorFailsWith - "illegal: with stake input" - (proposalValidator Shared.proposal) - ( ProposalDatum - { proposalId = ProposalId 0 - , effects = - AssocMap.fromList - [ (ResultTag 0, AssocMap.empty) - , (ResultTag 1, AssocMap.empty) - ] - , status = VotingReady - , cosigners = [signer] - , thresholds = def - , votes = - ProposalVotes - ( AssocMap.fromList - [ (ResultTag 0, 0) - , (ResultTag 1, 0) - ] - ) - , timingConfig = def - , startingTime = ProposalStartingTime 0 - } - ) - AdvanceProposal - ( ScriptContext - Proposal.advanceProposalWithInvalidOutputStake - (Spending Proposal.proposalRef) - ) - ] + + illegalGroup = + group + "illegal" + [ Advance.mkTestTree + "insufficient votes" + Advance.insufficientVotesParameters + False + , Advance.mkTestTree + "initial state is Finished" + Advance.advanceFromFinishedParameters + False + , group + "invalid stake output" + $ do + nStake <- [1, 5] + ps <- tail $ Advance.invalidOutputStakeParameters nStake + + let name = + "from " <> show ps.fromStatus <> "with " + <> show nStake + <> " stakes" + + pure $ Advance.mkTestTree name ps False + ] + in [draftGroup, legalGroup, illegalGroup] , group "unlocking" $ do proposalCount <- [1, 42] diff --git a/agora-testlib/Test/Util.hs b/agora-testlib/Test/Util.hs index 78600a5..b610dd7 100644 --- a/agora-testlib/Test/Util.hs +++ b/agora-testlib/Test/Util.hs @@ -13,22 +13,24 @@ module Test.Util ( updateMap, sortMap, sortValue, + blake2b_224, + pubKeyHashes, + userCredentials, + scriptCredentials, ) where -------------------------------------------------------------------------------- -import Prelude - --------------------------------------------------------------------------------- - import Codec.Serialise (serialise) -import Data.ByteString.Lazy qualified as ByteString.Lazy - --------------------------------------------------------------------------------- - +import Crypto.Hash qualified as Crypto import Data.Bifunctor (second) +import Data.ByteArray qualified as BA +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as C +import Data.ByteString.Lazy qualified as ByteString.Lazy import Data.List (sortOn) import Plutarch.Crypto (pblake2b_256) +import PlutusLedgerApi.V1 (Credential (PubKeyCredential, ScriptCredential), PubKeyHash (..), ValidatorHash (ValidatorHash)) import PlutusLedgerApi.V1.Interval qualified as PlutusTx import PlutusLedgerApi.V1.Scripts (Datum (Datum), DatumHash (DatumHash)) import PlutusLedgerApi.V1.Value (Value (..)) @@ -36,6 +38,7 @@ import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.Builtins qualified as PlutusTx import PlutusTx.IsData qualified as PlutusTx import PlutusTx.Ord qualified as PlutusTx +import Prelude -------------------------------------------------------------------------------- @@ -106,3 +109,25 @@ sortValue = . fmap (second sortMap) . AssocMap.toList . getValue + +-------------------------------------------------------------------------------- + +-- | Compute the hash of a given byte string using blake2b_224 algorithm. +blake2b_224 :: BS.ByteString -> BS.ByteString +blake2b_224 = BS.pack . BA.unpack . Crypto.hashWith Crypto.Blake2b_224 + +-- | An infinite list of blake2b_224 hashes. +blake2b_224Hashes :: [BS.ByteString] +blake2b_224Hashes = blake2b_224 . C.pack . show @Integer <$> [0 ..] + +-- | An infinite list of *valid* 'PubKeyHash'. +pubKeyHashes :: [PubKeyHash] +pubKeyHashes = PubKeyHash . PlutusTx.toBuiltin <$> blake2b_224Hashes + +-- | An infinite list of *valid* user credentials. +userCredentials :: [Credential] +userCredentials = PubKeyCredential <$> pubKeyHashes + +-- | An infinite list of *valid* script credentials. +scriptCredentials :: [Credential] +scriptCredentials = ScriptCredential . ValidatorHash . PlutusTx.toBuiltin <$> blake2b_224Hashes diff --git a/agora.cabal b/agora.cabal index d20cf60..08f9e99 100644 --- a/agora.cabal +++ b/agora.cabal @@ -189,8 +189,11 @@ library agora-specs Sample.Effect.TreasuryWithdrawal Sample.Governor Sample.Proposal + Sample.Proposal.Advance + Sample.Proposal.Cosign Sample.Proposal.Shared Sample.Proposal.UnlockStake + Sample.Proposal.Vote Sample.Shared Sample.Stake Sample.Treasury diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index f947817..7138d26 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -313,13 +313,13 @@ stakeValidator stake = -- -- Validation strategy I have tried/considered so far: -- 1. Check that the number of input stakes equals to the number of output stakes, and verify - -- that every input stake has an output stake with the exact same value and datum hash. - -- However this approach has a fatal vulnerability: let's say we have two totally identical stakes, - -- a malicious user can comsume these two stakes and remove GTs from one of them. + -- that there's an output stake with the exact same value and datum hash as the stake being + -- validated , However this approach has a fatal vulnerability: let's say we have two totally + -- identical stakes, a malicious user can comsume these two stakes and remove GTs from one of them. -- 2. Perform the same checks as the last approch does, while also checking that every output stake is -- valid(stakedAmount == actual value). However this requires that all the output stake datum are -- included in the transaction, and we have to find and go through them one by one to access the - -- 'stakedAmount' fields, meaning that computationally this approach is *very* expensive. + -- 'stakedAmount' fields, meaning that computationally this approach is *very* expensive. -- 3. The one implemented below. Find all the continuous input/output, sort them by 'datumHash', and -- ensure that the two sorted lists are equal. let ownInputs = diff --git a/bench.csv b/bench.csv index a596e6f..1a8900e 100644 --- a/bench.csv +++ b/bench.csv @@ -8,24 +8,57 @@ Agora/Stake/policy/stakeCreation,50939580,148729,2387 Agora/Stake/validator/stakeDepositWithdraw deposit,180222751,492217,5003 Agora/Stake/validator/stakeDepositWithdraw withdraw,180222751,492217,4991 Agora/Proposal/policy/proposalCreation,23140177,69194,1515 -Agora/Proposal/validator/cosignature/proposal,240482868,674626,8525 -Agora/Proposal/validator/cosignature/stake,136781411,336612,5528 -Agora/Proposal/validator/voting/proposal,243946100,678901,8443 -Agora/Proposal/validator/voting/stake,128972262,348186,5489 -Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,219342631,620576,8350 -Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,247748475,699343,8359 -Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,236509366,666512,8359 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished,214287939,609855,8352 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished,233681921,660502,8353 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished,234812899,662906,8353 +Agora/Proposal/validator/cosignature/legal/with 1 cosigners/propsoal,237484909,663370,8471 +Agora/Proposal/validator/cosignature/legal/with 1 cosigners/stake,123296365,319226,5470 +Agora/Proposal/validator/cosignature/legal/with 5 cosigners/propsoal,675336848,1882805,11101 +Agora/Proposal/validator/cosignature/legal/with 5 cosigners/stake,554091553,1461634,7980 +Agora/Proposal/validator/cosignature/legal/with 10 cosigners/propsoal,1336993992,3667352,14389 +Agora/Proposal/validator/cosignature/legal/with 10 cosigners/stake,1102063894,2914419,11117 +Agora/Proposal/validator/cosignature/illegal/duplicate cosigners/stake,123296365,319226,5470 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: VotingReady/stake,123296365,319226,5470 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: Locked/stake,123296365,319226,5470 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: Finished/stake,123296365,319226,5470 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: VotingReady/stake,554091553,1461634,7980 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: Locked/stake,554091553,1461634,7980 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: Finished/stake,554091553,1461634,7980 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: VotingReady/stake,1102063894,2914419,11117 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: Locked/stake,1102063894,2914419,11117 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: Finished/stake,1102063894,2914419,11117 +Agora/Proposal/validator/voting/legal/propsoal,247594094,689025,8443 +Agora/Proposal/validator/voting/legal/stake,141390725,374830,5489 +Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to next state/propsoal,222990625,630700,8426 +Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to next state/stake,123296365,319226,5467 +Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to failed state/propsoal,217935933,619979,8428 +Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to failed state/stake,123296365,319226,5469 +Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/illegal/insufficient cosigns/stake,117222929,305504,5397 +Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to next state/propsoal,600833052,1725797,11249 +Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to next state/stake,526604275,1381680,8170 +Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to failed state/propsoal,240305281,682043,8789 +Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to failed state/stake,123296365,319226,5710 +Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/illegal/insufficient cosigns/stake,445454241,1167344,7819 +Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to next state/propsoal,1164574757,3363392,14778 +Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to next state/stake,1154814568,3068129,11548 +Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to failed state/propsoal,268266966,759623,9242 +Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to failed state/stake,123296365,319226,6012 +Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/illegal/insufficient cosigns/stake,1024215053,2732615,10845 +Agora/Proposal/validator/advancing/legal/advance to next state/from: VotingReady/propsoal,251396469,709467,8435 +Agora/Proposal/validator/advancing/legal/advance to next state/from: VotingReady/stake,123296365,319226,5474 +Agora/Proposal/validator/advancing/legal/advance to next state/from: Locked/propsoal,240157360,676636,8435 +Agora/Proposal/validator/advancing/legal/advance to next state/from: Locked/stake,123296365,319226,5474 +Agora/Proposal/validator/advancing/legal/advance to failed state/from: VotingReady/propsoal,237329915,670626,8429 +Agora/Proposal/validator/advancing/legal/advance to failed state/from: VotingReady/stake,123296365,319226,5470 +Agora/Proposal/validator/advancing/legal/advance to failed state/from: Locked/propsoal,238460893,673030,8429 +Agora/Proposal/validator/advancing/legal/advance to failed state/from: Locked/stake,123296365,319226,5470 +Agora/Proposal/validator/advancing/illegal/insufficient votes/stake,123296365,319226,5470 +Agora/Proposal/validator/advancing/illegal/initial state is Finished/stake,123296365,319226,5462 "Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady",245987595,688711,8403 "Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished",215263333,612711,8405 "Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished",212560614,604622,8407 "Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked",212560614,604622,8407 -"Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady",1775652167,5199490,29510 -"Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished",1448293766,4317963,29694 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished",1340653392,3978430,29678 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked",1340653392,3978430,29678 +"Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady",1775652167,5199490,29511 +"Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished",1448293766,4317963,29695 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished",1340653392,3978430,29679 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked",1340653392,3978430,29679 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,806 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 Agora/Treasury/Validator/Positive/Allows for effect changes,31556709,81546,1452 @@ -33,5 +66,5 @@ Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,80 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 Agora/Governor/policy/GST minting,51007235,144191,2034 Agora/Governor/validator/proposal creation,309689999,834675,9064 -Agora/Governor/validator/GATs minting,418560845,1137908,9187 +Agora/Governor/validator/GATs minting,421016677,1141838,9187 Agora/Governor/validator/mutate governor state,88986020,248491,8662 From f00cc6247609be1238ea6c6ffaa87cd1341223df Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Wed, 6 Jul 2022 21:55:39 +0800 Subject: [PATCH 6/6] apply Emily's suggestions --- agora/Agora/Proposal/Scripts.hs | 537 ++++++++++++++++---------------- agora/Agora/Stake/Scripts.hs | 17 +- bench.csv | 108 +++---- 3 files changed, 334 insertions(+), 328 deletions(-) diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index d31646a..85ec3f1 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -42,6 +42,7 @@ import Agora.Utils ( import Plutarch.Api.V1 ( PDatumHash, PMintingPolicy, + PPubKeyHash, PScriptContext (PScriptContext), PScriptPurpose (PMinting, PSpending), PTxInfo (PTxInfo), @@ -305,198 +306,272 @@ proposalValidator proposal = ---------------------------------------------------------------------------- - let acceptMultipleStakes = pmatch proposalRedeemer $ \case - PCosign _ -> pconstant True - PAdvanceProposal _ -> - currentStatus #== pconstant Draft - _ -> pconstant False + withMultipleStakes' :: + Term + _ + ( ( PInteger + :--> PBuiltinList (PAsData PPubKeyHash) + :--> PUnit + ) + :--> PUnit + ) <- + pletC $ + plam $ \validationLogic -> unTermCont $ do + -- The following code ensures that all the stake datums are not + -- changed. + -- + -- TODO: This is quite inefficient (O(nlogn)) but for now we don't + -- have a nice way to check this. In plutus v2 we'll have map of + -- (Script -> Redeemer) in ScriptContext, which should be the + -- straight up solution. + let sortDatumHashes = phoistAcyclic $ pmsortBy # pltAsData + + sortedStakeInputDatumHashes = + sortDatumHashes # stakeInputDatumHashes + + sortedStakeOutputDatumHashes = + sortDatumHashes # stakeOutputDatumHashes + + pguardC "All stake datum are unchanged" $ + plistEquals + # sortedStakeInputDatumHashes + # sortedStakeOutputDatumHashes + + PPair totalStakedAmount stakeOwners <- + pmatchC $ + pfoldl + # plam + ( \l dh -> unTermCont $ do + let stake = + pfromData $ + pfromJust + #$ ptryFindDatum + @(PAsData PStakeDatum) + # pfromData dh + # txInfoF.datums + + stakeF <- pletFieldsC @'["stakedAmount", "owner"] stake + + PPair amount owners <- pmatchC l + + let newAmount = amount + punsafeCoerce (pfromData stakeF.stakedAmount) + updatedOwners = pcons # stakeF.owner # owners + + pure $ pcon $ PPair newAmount updatedOwners + ) + # pcon (PPair (0 :: Term _ PInteger) (pnil @PBuiltinList)) + # stakeInputDatumHashes + + sortedStakeOwners <- pletC $ pmsortBy # pltAsData # stakeOwners + + pure $ validationLogic # totalStakedAmount # sortedStakeOwners + + withSingleStake' :: + Term + _ + ( ( PStakeDatum :--> PStakeDatum :--> PBool :--> PUnit + ) + :--> PUnit + ) <- pletC $ + plam $ \validationLogic -> unTermCont $ do + pguardC "Can only deal with one stake" $ + stakeInputNum #== 1 + + stakeInputHash <- pletC $ pfromData $ phead # stakeInputDatumHashes + stakeOutputHash <- pletC $ pfromData $ phead # stakeOutputDatumHashes + + stakeIn :: Term _ PStakeDatum <- + pletC $ + pfromData $ + pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums + + stakeOut :: Term _ PStakeDatum <- + pletC $ + pfromData $ + pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums + + stakeUnchanged <- pletC $ stakeInputHash #== stakeOutputHash + + pure $ validationLogic # stakeIn # stakeOut # stakeUnchanged + + let withMultipleStakes val = + withMultipleStakes' #$ plam $ + \totalStakedAmount + sortedStakeOwner -> + unTermCont $ + val totalStakedAmount sortedStakeOwner + + withSingleStake val = + withSingleStake' #$ plam $ \stakeIn stakeOut stakeUnchange -> unTermCont $ do + stakeInF <- pletFieldsC @'["stakedAmount", "lockedBy", "owner"] stakeIn + + val stakeInF stakeOut stakeUnchange pure $ popaque $ - pif - acceptMultipleStakes - ( unTermCont $ do - -- The following code ensures that all the stake datums are not - -- changed. - -- - -- TODO: This is quite inefficient (O(nlogn)) but for now we don't - -- have a nice way to check this. In plutus v2 we'll have map of - -- (Script -> Redeemer) in ScriptContext, which should be the - -- straight up solution. - let sortDatumHashes = phoistAcyclic $ pmsortBy # pltAsData + pmatch proposalRedeemer $ \case + PCosign r -> withMultipleStakes $ \_ sortedStakeOwners -> do + pguardC "Should be in draft state" $ + currentStatus #== pconstant Draft - sortedStakeInputDatumHashes = - sortDatumHashes # stakeInputDatumHashes + newSigs <- pletC $ pfield @"newCosigners" # r - sortedStakeOutputDatumHashes = - sortDatumHashes # stakeOutputDatumHashes + pguardC "Signed by all new cosigners" $ + pall # signedBy # newSigs - pguardC "All stake datum are unchanged" $ - plistEquals - # sortedStakeInputDatumHashes - # sortedStakeOutputDatumHashes + updatedSigs <- + pletC $ + pmergeBy # pltAsData + # newSigs + # proposalF.cosigners - PPair totalStakedAmount stakeOwners <- - pmatchC $ - pfoldl - # plam - ( \l dh -> unTermCont $ do - let stake = - pfromData $ - pfromJust - #$ ptryFindDatum - @(PAsData PStakeDatum) - # pfromData dh - # txInfoF.datums + pguardC "Cosigners are unique" $ + pisUniq' # updatedSigs - stakeF <- pletFieldsC @'["stakedAmount", "owner"] stake + pguardC "All new cosigners are witnessed by their Stake datums" $ + plistEquals # sortedStakeOwners # newSigs - PPair amount owners <- pmatchC l + let expectedDatum = + mkRecordConstr + PProposalDatum + ( #proposalId .= proposalF.proposalId + .& #effects .= proposalF.effects + .& #status .= proposalF.status + .& #cosigners .= pdata updatedSigs + .& #thresholds .= proposalF.thresholds + .& #votes .= proposalF.votes + .& #timingConfig .= proposalF.timingConfig + .& #startingTime .= proposalF.startingTime + ) - let newAmount = amount + punsafeCoerce (pfromData stakeF.stakedAmount) - updatedOwners = pcons # stakeF.owner # owners + pguardC "Signatures are correctly added to cosignature list" $ + proposalOut #== expectedDatum - pure $ pcon $ PPair newAmount updatedOwners - ) - # pcon (PPair (0 :: Term _ PInteger) (pnil @PBuiltinList)) - # stakeInputDatumHashes + pure $ pconstant () - sortedStakeOwners <- pletC $ pmsortBy # pltAsData # stakeOwners + ---------------------------------------------------------------------- - redeemer <- pmatchC proposalRedeemer + PVote r -> withSingleStake $ \stakeInF stakeOut _ -> do + pguardC "Input proposal must be in VotingReady state" $ + currentStatus #== pconstant VotingReady - case redeemer of - PCosign r -> do - pguardC "Should be in draft state" $ - currentStatus #== pconstant Draft + pguardC "Proposal time should be wthin the voting period" $ + isVotingPeriod # proposalF.timingConfig + # proposalF.startingTime + # currentTime - newSigs <- pletC $ pfield @"newCosigners" # r + -- Ensure the transaction is voting to a valid 'ResultTag'(outcome). + PProposalVotes voteMap <- pmatchC proposalF.votes + voteFor <- pletC $ pfromData $ pfield @"resultTag" # r - pguardC "Signed by all new cosigners" $ - pall # signedBy # newSigs + pguardC "Vote option should be valid" $ + pisJust #$ plookup # voteFor # voteMap - updatedSigs <- - pletC $ - pmergeBy # pltAsData - # newSigs - # proposalF.cosigners + -- Ensure that no lock with the current proposal id has been put on the stake. + pguardC "Same stake shouldn't vote on the same proposal twice" $ + pnot #$ pany + # plam + ( \((pfield @"proposalTag" #) . pfromData -> pid) -> + pid #== proposalF.proposalId + ) + # pfromData stakeInF.lockedBy - pguardC "Cosigners are unique" $ - pisUniq' # updatedSigs - - pguardC "All new cosigners are witnessed by their Stake datums" $ - plistEquals # sortedStakeOwners # newSigs - - let expectedDatum = - mkRecordConstr - PProposalDatum - ( #proposalId .= proposalF.proposalId - .& #effects .= proposalF.effects - .& #status .= proposalF.status - .& #cosigners .= pdata updatedSigs - .& #thresholds .= proposalF.thresholds - .& #votes .= proposalF.votes - .& #timingConfig .= proposalF.timingConfig - .& #startingTime .= proposalF.startingTime + let -- The amount of new votes should be the 'stakedAmount'. + -- 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 -> unTermCont $ do + PDiscrete v <- pmatchC stakeInF.stakedAmount + pure $ pcon $ PJust $ votes + (pextract # v) ) + # voteFor + # m + expectedProposalOut = + mkRecordConstr + PProposalDatum + ( #proposalId .= proposalF.proposalId + .& #effects .= proposalF.effects + .& #status .= proposalF.status + .& #cosigners .= proposalF.cosigners + .& #thresholds .= proposalF.thresholds + .& #votes .= pdata expectedNewVotes + .& #timingConfig .= proposalF.timingConfig + .& #startingTime .= proposalF.startingTime + ) - pguardC "Signatures are correctly added to cosignature list" $ - proposalOut #== expectedDatum + pguardC "Output proposal should be valid" $ proposalOut #== expectedProposalOut - pure $ pconstant () + -- 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 newProposalLock = + mkRecordConstr + PProposalLock + ( #vote .= pdata voteFor + .& #proposalTag .= proposalF.proposalId + ) + -- Prepend the new lock to existing locks + expectedProposalLocks = + pcons + # pdata newProposalLock + # pfromData stakeInF.lockedBy + expectedStakeOut = + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeInF.stakedAmount + .& #owner .= stakeInF.owner + .& #lockedBy .= pdata expectedProposalLocks + ) - PAdvanceProposal _ -> do - inDraftPeriod <- - pletC $ - isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime + pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut - pure $ - pif - inDraftPeriod - ( unTermCont $ do - pguardC "More cosigns than minimum amount" $ - punsafeCoerce (pfromData thresholdsF.vote) #< totalStakedAmount + pure $ pconstant () - pguardC "All new cosigners are witnessed by their Stake datums" $ - plistEquals # sortedStakeOwners # proposalF.cosigners + ---------------------------------------------------------------------- - -- 'Draft' -> 'VotingReady' - pguardC "Proposal status set to VotingReady" $ - proposalOutStatus #== pconstant VotingReady + PUnlock r -> withSingleStake $ \stakeInF stakeOut _ -> do + -- At draft stage, the votes should be empty. + pguardC "Shouldn't retract votes from a draft proposal" $ + pnot #$ currentStatus #== pconstant Draft - pure $ pconstant () - ) - ( unTermCont $ do - pguardC "Advance to failed state" $ proposalOutStatus #== pconstant Finished + -- This is the vote option we're retracting from. + retractFrom <- pletC $ pfield @"resultTag" # r - pure $ pconstant () - ) + -- Determine if the input stake is actually locked by this proposal. + stakeUsage <- pletC $ pgetStakeUsage # stakeInF.lockedBy # proposalF.proposalId - ------------------------------------------------------------------ + pguardC "Stake input relevant" $ + pmatch stakeUsage $ \case + PDidNothing -> + ptraceIfFalse "Stake should be relevant" $ + pconstant False + PCreated -> + ptraceIfFalse "Removing creator's locks means status is Finished" $ + currentStatus #== pconstant Finished + PVotedFor rt -> + ptraceIfFalse "Result tag should match the one given in the redeemer" $ + rt #== retractFrom - _ -> pure $ pconstant () - ) - ( unTermCont $ do - pguardC "Can only deal with one stake" $ - stakeInputNum #== 1 + -- The count of removing votes is equal to the 'stakeAmount' of input stake. + retractCount <- + pletC $ + pmatch stakeInF.stakedAmount $ \(PDiscrete v) -> pextract # v - let stakeInputHash = pfromData $ phead # stakeInputDatumHashes - stakeOutputHash = pfromData $ phead # stakeOutputDatumHashes + -- The votes can only change when the proposal still allows voting. + let shouldUpdateVotes = + currentStatus #== pconstant VotingReady + #&& pnot # (pcon PCreated #== stakeUsage) - stakeIn :: Term _ PStakeDatum <- - pletC $ - pfromData $ - pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums - stakeInF <- pletFieldsC @'["stakedAmount", "lockedBy", "owner"] stakeIn + pguardC "Proposal output correct" $ + pif + shouldUpdateVotes + ( let -- Remove votes and leave other parts of the proposal as it. + expectedVotes = pretractVotes # retractFrom # retractCount # proposalF.votes - stakeOut :: Term _ PStakeDatum <- - pletC $ - pfromData $ - pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums - - redeemer <- pmatchC proposalRedeemer - - case redeemer of - PVote r -> do - pguardC "Input proposal must be in VotingReady state" $ - currentStatus #== pconstant VotingReady - - pguardC "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 <- pmatchC proposalF.votes - voteFor <- pletC $ pfromData $ pfield @"resultTag" # r - - pguardC "Vote option should be valid" $ - pisJust #$ plookup # voteFor # voteMap - - -- Ensure that no lock with the current proposal id has been put on the stake. - pguardC "Same stake shouldn't vote on the same proposal twice" $ - pnot #$ pany - # plam - ( \((pfield @"proposalTag" #) . pfromData -> pid) -> - pid #== proposalF.proposalId - ) - # pfromData stakeInF.lockedBy - - let -- The amount of new votes should be the 'stakedAmount'. - -- 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 -> unTermCont $ do - PDiscrete v <- pmatchC stakeInF.stakedAmount - pure $ pcon $ PJust $ votes + (pextract # v) - ) - # voteFor - # m expectedProposalOut = mkRecordConstr PProposalDatum @@ -505,122 +580,60 @@ proposalValidator proposal = .& #status .= proposalF.status .& #cosigners .= proposalF.cosigners .& #thresholds .= proposalF.thresholds - .& #votes .= pdata expectedNewVotes + .& #votes .= pdata expectedVotes .& #timingConfig .= proposalF.timingConfig .& #startingTime .= proposalF.startingTime ) + in ptraceIfFalse "Update votes" $ + expectedProposalOut #== proposalOut + ) + -- No change to the proposal is allowed. + $ ptraceIfFalse "Proposal unchanged" proposalUnchanged - pguardC "Output proposal should be valid" $ proposalOut #== expectedProposalOut + -- At last, we ensure that all locks belong to this proposal will be removed. + stakeOutputLocks <- pletC $ pfield @"lockedBy" # stakeOut - -- 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 templateStakeOut = + mkRecordConstr + PStakeDatum + ( #stakedAmount .= stakeInF.stakedAmount + .& #owner .= stakeInF.owner + .& #lockedBy .= stakeOutputLocks + ) - let newProposalLock = - mkRecordConstr - PProposalLock - ( #vote .= pdata voteFor - .& #proposalTag .= proposalF.proposalId - ) - -- Prepend the new lock to existing locks - expectedProposalLocks = - pcons - # pdata newProposalLock - # pfromData stakeInF.lockedBy - expectedStakeOut = - mkRecordConstr - PStakeDatum - ( #stakedAmount .= stakeInF.stakedAmount - .& #owner .= stakeInF.owner - .& #lockedBy .= pdata expectedProposalLocks - ) + pguardC "Only locks updated in the output stake" $ + templateStakeOut #== stakeOut - pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut + pguardC "All relevant locks removed from the stake" $ + pgetStakeUsage # pfromData stakeOutputLocks + # proposalF.proposalId #== pcon PDidNothing - pure $ pconstant () + pure $ pconstant () - ------------------------------------------------------------------ - PUnlock r -> do - -- At draft stage, the votes should be empty. - pguardC "Shouldn't retract votes from a draft proposal" $ - pnot #$ currentStatus #== pconstant Draft + ---------------------------------------------------------------------- - -- This is the vote option we're retracting from. - retractFrom <- pletC $ pfield @"resultTag" # r + PAdvanceProposal _ -> + let fromDraft = withMultipleStakes $ \totalStakedAmount sortedStakeOwners -> + pmatchC (isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime) >>= \case + PTrue -> do + pguardC "More cosigns than minimum amount" $ + punsafeCoerce (pfromData thresholdsF.vote) #< totalStakedAmount - -- Determine if the input stake is actually locked by this proposal. - stakeUsage <- pletC $ pgetStakeUsage # stakeInF.lockedBy # proposalF.proposalId + pguardC "All new cosigners are witnessed by their Stake datums" $ + plistEquals # sortedStakeOwners # proposalF.cosigners - pguardC "Stake input relevant" $ - pmatch stakeUsage $ \case - PDidNothing -> - ptraceIfFalse "Stake should be relevant" $ - pconstant False - PCreated -> - ptraceIfFalse "Removing creator's locks means status is Finished" $ - currentStatus #== pconstant Finished - PVotedFor rt -> - ptraceIfFalse "Result tag should match the one given in the redeemer" $ - rt #== retractFrom + -- 'Draft' -> 'VotingReady' + pguardC "Proposal status set to VotingReady" $ + proposalOutStatus #== pconstant VotingReady - -- The count of removing votes is equal to the 'stakeAmount' of input stake. - retractCount <- - pletC $ - pmatch stakeInF.stakedAmount $ \(PDiscrete v) -> pextract # v + pure $ pconstant () + PFalse -> do + pguardC "Advance to failed state" $ proposalOutStatus #== pconstant Finished - -- The votes can only change when the proposal still allows voting. - let shouldUpdateVotes = - currentStatus #== pconstant VotingReady - #&& pnot # (pcon PCreated #== stakeUsage) + pure $ pconstant () - pguardC "Proposal output correct" $ - pif - shouldUpdateVotes - ( let -- Remove votes and leave other parts of the proposal as it. - expectedVotes = pretractVotes # retractFrom # retractCount # proposalF.votes - - expectedProposalOut = - mkRecordConstr - PProposalDatum - ( #proposalId .= proposalF.proposalId - .& #effects .= proposalF.effects - .& #status .= proposalF.status - .& #cosigners .= proposalF.cosigners - .& #thresholds .= proposalF.thresholds - .& #votes .= pdata expectedVotes - .& #timingConfig .= proposalF.timingConfig - .& #startingTime .= proposalF.startingTime - ) - in ptraceIfFalse "Update votes" $ - expectedProposalOut #== proposalOut - ) - -- No change to the proposal is allowed. - $ ptraceIfFalse "Proposal unchanged" proposalUnchanged - - -- At last, we ensure that all locks belong to this proposal will be removed. - stakeOutputLocks <- pletC $ pfield @"lockedBy" # stakeOut - - let templateStakeOut = - mkRecordConstr - PStakeDatum - ( #stakedAmount .= stakeInF.stakedAmount - .& #owner .= stakeInF.owner - .& #lockedBy .= stakeOutputLocks - ) - - pguardC "Only locks updated in the output stake" $ - templateStakeOut #== stakeOut - - pguardC "All relevant locks removed from the stake" $ - pgetStakeUsage # pfromData stakeOutputLocks - # proposalF.proposalId #== pcon PDidNothing - - pure $ pconstant () - - ------------------------------------------------------------------ - PAdvanceProposal _ -> do - pguardC "Stake should not change" $ - stakeInputHash #== stakeOutputHash + fromOther = withSingleStake $ \_ _ stakeUnchanged -> do + pguardC "Stake should not change" stakeUnchanged pguardC "Only status changes in the output proposal" @@ -655,6 +668,7 @@ proposalValidator proposal = -- TODO: Should check that the GST is not moved -- if the proposal is in 'Locked' state. + pure $ pconstant () toNextState = pmatchEnum proposalStatus $ \case @@ -685,5 +699,4 @@ proposalValidator proposal = toNextState -- Too late: failed proposal, status set to 'Finished'. toFailedState - _ -> pure $ pconstant () - ) + in pif (currentStatus #== pconstant Draft) fromDraft fromOther diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 7138d26..f84ec33 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -25,6 +25,7 @@ import Agora.Utils ( mustFindDatum', pvalidatorHashToTokenName, ) +import Data.Function (on) import Data.Tagged (Tagged (..), untag) import Plutarch.Api.V1 ( AmountGuarantees (Positive), @@ -303,10 +304,10 @@ stakeValidator stake = # pfromData txInfoF.outputs let witnessStake = unTermCont $ do - pguardC "Either owner signs the transaction or propsoal token moved" $ + pguardC "Either owner signs the transaction or proposal token moved" $ ownerSignsTransaction #|| proposalTokenMoved - -- FIXME: refactor this with reference input, once it's supported by plutarch. + -- FIXME: remove this once we have reference input. -- -- Our goal here is to allow multiple input stakes, and also ensure that every the input stakes has a -- corresponding output stake, which carries the same value and the same datum as the input stake. @@ -335,15 +336,7 @@ stakeValidator stake = # pfromData txInfoF.inputs sortTxOuts :: Term _ (PBuiltinList (PAsData PTxOut) :--> PBuiltinList (PAsData PTxOut)) - sortTxOuts = - plam - ( pmsortBy - # plam - ( \((getDatumHash #) -> dhX) - ((getDatumHash #) -> dhY) -> dhX #< dhY - ) - # - ) + sortTxOuts = phoistAcyclic $ plam (pmsortBy # plam ((#<) `on` (getDatumHash #)) #) where getDatumHash :: Term _ (PAsData PTxOut :--> PDatumHash) getDatumHash = phoistAcyclic $ plam ((pfromDJust #) . pfromData . (pfield @"datumHash" #)) @@ -464,7 +457,7 @@ stakeValidator stake = newStakedAmount <- pletC $ oldStakedAmount + delta - pguardC "New staked amount shoudl be greater than or equal to 0" $ + pguardC "New staked amount should be greater than or equal to 0" $ zero #<= newStakedAmount let expectedDatum = diff --git a/bench.csv b/bench.csv index 1a8900e..7e8faf7 100644 --- a/bench.csv +++ b/bench.csv @@ -5,60 +5,60 @@ Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,456007605,1104500,3 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,87839169,243032,8561 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,106082031,292993,3609 Agora/Stake/policy/stakeCreation,50939580,148729,2387 -Agora/Stake/validator/stakeDepositWithdraw deposit,180222751,492217,5003 -Agora/Stake/validator/stakeDepositWithdraw withdraw,180222751,492217,4991 +Agora/Stake/validator/stakeDepositWithdraw deposit,150745141,416137,4995 +Agora/Stake/validator/stakeDepositWithdraw withdraw,150745141,416137,4983 Agora/Proposal/policy/proposalCreation,23140177,69194,1515 -Agora/Proposal/validator/cosignature/legal/with 1 cosigners/propsoal,237484909,663370,8471 -Agora/Proposal/validator/cosignature/legal/with 1 cosigners/stake,123296365,319226,5470 -Agora/Proposal/validator/cosignature/legal/with 5 cosigners/propsoal,675336848,1882805,11101 -Agora/Proposal/validator/cosignature/legal/with 5 cosigners/stake,554091553,1461634,7980 -Agora/Proposal/validator/cosignature/legal/with 10 cosigners/propsoal,1336993992,3667352,14389 -Agora/Proposal/validator/cosignature/legal/with 10 cosigners/stake,1102063894,2914419,11117 -Agora/Proposal/validator/cosignature/illegal/duplicate cosigners/stake,123296365,319226,5470 -Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: VotingReady/stake,123296365,319226,5470 -Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: Locked/stake,123296365,319226,5470 -Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: Finished/stake,123296365,319226,5470 -Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: VotingReady/stake,554091553,1461634,7980 -Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: Locked/stake,554091553,1461634,7980 -Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: Finished/stake,554091553,1461634,7980 -Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: VotingReady/stake,1102063894,2914419,11117 -Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: Locked/stake,1102063894,2914419,11117 -Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: Finished/stake,1102063894,2914419,11117 -Agora/Proposal/validator/voting/legal/propsoal,247594094,689025,8443 -Agora/Proposal/validator/voting/legal/stake,141390725,374830,5489 -Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to next state/propsoal,222990625,630700,8426 -Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to next state/stake,123296365,319226,5467 -Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to failed state/propsoal,217935933,619979,8428 -Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to failed state/stake,123296365,319226,5469 -Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/illegal/insufficient cosigns/stake,117222929,305504,5397 -Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to next state/propsoal,600833052,1725797,11249 -Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to next state/stake,526604275,1381680,8170 -Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to failed state/propsoal,240305281,682043,8789 -Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to failed state/stake,123296365,319226,5710 -Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/illegal/insufficient cosigns/stake,445454241,1167344,7819 -Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to next state/propsoal,1164574757,3363392,14778 -Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to next state/stake,1154814568,3068129,11548 -Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to failed state/propsoal,268266966,759623,9242 -Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to failed state/stake,123296365,319226,6012 -Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/illegal/insufficient cosigns/stake,1024215053,2732615,10845 -Agora/Proposal/validator/advancing/legal/advance to next state/from: VotingReady/propsoal,251396469,709467,8435 -Agora/Proposal/validator/advancing/legal/advance to next state/from: VotingReady/stake,123296365,319226,5474 -Agora/Proposal/validator/advancing/legal/advance to next state/from: Locked/propsoal,240157360,676636,8435 -Agora/Proposal/validator/advancing/legal/advance to next state/from: Locked/stake,123296365,319226,5474 -Agora/Proposal/validator/advancing/legal/advance to failed state/from: VotingReady/propsoal,237329915,670626,8429 -Agora/Proposal/validator/advancing/legal/advance to failed state/from: VotingReady/stake,123296365,319226,5470 -Agora/Proposal/validator/advancing/legal/advance to failed state/from: Locked/propsoal,238460893,673030,8429 -Agora/Proposal/validator/advancing/legal/advance to failed state/from: Locked/stake,123296365,319226,5470 -Agora/Proposal/validator/advancing/illegal/insufficient votes/stake,123296365,319226,5470 -Agora/Proposal/validator/advancing/illegal/initial state is Finished/stake,123296365,319226,5462 -"Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady",245987595,688711,8403 -"Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished",215263333,612711,8405 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished",212560614,604622,8407 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked",212560614,604622,8407 -"Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady",1775652167,5199490,29511 -"Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished",1448293766,4317963,29695 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished",1340653392,3978430,29679 -"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked",1340653392,3978430,29679 +Agora/Proposal/validator/cosignature/legal/with 1 cosigners/propsoal,235408912,657765,8097 +Agora/Proposal/validator/cosignature/legal/with 1 cosigners/stake,125665131,316762,5462 +Agora/Proposal/validator/cosignature/legal/with 5 cosigners/propsoal,680441047,1897008,10727 +Agora/Proposal/validator/cosignature/legal/with 5 cosigners/stake,576106975,1490610,7972 +Agora/Proposal/validator/cosignature/legal/with 10 cosigners/propsoal,1351073436,3706315,14015 +Agora/Proposal/validator/cosignature/legal/with 10 cosigners/stake,1148637636,2982695,11109 +Agora/Proposal/validator/cosignature/illegal/duplicate cosigners/stake,125665131,316762,5462 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: VotingReady/stake,125665131,316762,5462 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: Locked/stake,125665131,316762,5462 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: Finished/stake,125665131,316762,5462 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: VotingReady/stake,576106975,1490610,7972 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: Locked/stake,576106975,1490610,7972 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: Finished/stake,576106975,1490610,7972 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: VotingReady/stake,1148637636,2982695,11109 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: Locked/stake,1148637636,2982695,11109 +Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: Finished/stake,1148637636,2982695,11109 +Agora/Proposal/validator/voting/legal/propsoal,246896882,688919,8069 +Agora/Proposal/validator/voting/legal/stake,141234659,368136,5481 +Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to next state/propsoal,222376736,631090,8052 +Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to next state/stake,125665131,316762,5459 +Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to failed state/propsoal,217322044,620369,8054 +Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to failed state/stake,125665131,316762,5461 +Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/illegal/insufficient cosigns/stake,118020743,304972,5389 +Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to next state/propsoal,614587307,1766683,10875 +Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to next state/stake,548619697,1410656,8162 +Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to failed state/propsoal,239691392,682433,8415 +Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to failed state/stake,125665131,316762,5702 +Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/illegal/insufficient cosigns/stake,446252055,1166812,7811 +Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to next state/propsoal,1196289192,3454898,14404 +Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to next state/stake,1201388310,3136405,11540 +Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to failed state/propsoal,267653077,760013,8868 +Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to failed state/stake,125665131,316762,6004 +Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/illegal/insufficient cosigns/stake,1025012867,2732083,10837 +Agora/Proposal/validator/advancing/legal/advance to next state/from: VotingReady/propsoal,250229153,709227,8061 +Agora/Proposal/validator/advancing/legal/advance to next state/from: VotingReady/stake,125665131,316762,5466 +Agora/Proposal/validator/advancing/legal/advance to next state/from: Locked/propsoal,238990044,676396,8061 +Agora/Proposal/validator/advancing/legal/advance to next state/from: Locked/stake,125665131,316762,5466 +Agora/Proposal/validator/advancing/legal/advance to failed state/from: VotingReady/propsoal,236162599,670386,8055 +Agora/Proposal/validator/advancing/legal/advance to failed state/from: VotingReady/stake,125665131,316762,5462 +Agora/Proposal/validator/advancing/legal/advance to failed state/from: Locked/propsoal,237293577,672790,8055 +Agora/Proposal/validator/advancing/legal/advance to failed state/from: Locked/stake,125665131,316762,5462 +Agora/Proposal/validator/advancing/illegal/insufficient votes/stake,125665131,316762,5462 +Agora/Proposal/validator/advancing/illegal/initial state is Finished/stake,125665131,316762,5454 +"Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady",245855872,689807,8029 +"Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished",215131610,613807,8031 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished",212428891,605718,8033 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked",212428891,605718,8033 +"Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady",1775520444,5200586,29137 +"Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished",1448162043,4319059,29321 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished",1340521669,3979526,29305 +"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked",1340521669,3979526,29305 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,806 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 Agora/Treasury/Validator/Positive/Allows for effect changes,31556709,81546,1452 @@ -66,5 +66,5 @@ Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,80 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 Agora/Governor/policy/GST minting,51007235,144191,2034 Agora/Governor/validator/proposal creation,309689999,834675,9064 -Agora/Governor/validator/GATs minting,421016677,1141838,9187 +Agora/Governor/validator/GATs minting,418560845,1137908,9187 Agora/Governor/validator/mutate governor state,88986020,248491,8662