From b6fb23975ceb0fb6bdfe9d857892f586feb49daf Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Wed, 13 Jul 2022 19:01:51 +0800 Subject: [PATCH] improve performance of the governor validator --- agora-specs/Property/Governor.hs | 16 -- agora-specs/Spec/AuthorityToken.hs | 25 +-- agora-specs/Spec/Proposal.hs | 2 +- agora/Agora/AuthorityToken.hs | 10 +- agora/Agora/Effect.hs | 7 +- agora/Agora/Governor.hs | 2 - agora/Agora/Governor/Scripts.hs | 240 +++++++++-------------------- agora/Agora/Proposal.hs | 83 +++++----- agora/Agora/Proposal/Scripts.hs | 3 +- agora/Agora/Stake.hs | 26 ++-- agora/Agora/Treasury.hs | 5 +- agora/Agora/Utils.hs | 35 ----- bench.csv | 31 ++-- 13 files changed, 166 insertions(+), 319 deletions(-) diff --git a/agora-specs/Property/Governor.hs b/agora-specs/Property/Governor.hs index 7d45d99..81df659 100644 --- a/agora-specs/Property/Governor.hs +++ b/agora-specs/Property/Governor.hs @@ -62,8 +62,6 @@ data GovernorDatumCases = ExecuteLE0 | CreateLE0 | VoteLE0 - | CreateLEVote - | ExecuteLVote | Correct deriving stock (Eq, Show) @@ -72,8 +70,6 @@ instance Universe GovernorDatumCases where [ ExecuteLE0 , CreateLE0 , VoteLE0 - , CreateLEVote - , ExecuteLVote , Correct ] @@ -94,8 +90,6 @@ governorDatumValidProperty = | e < 0 = ExecuteLE0 | c < 0 = CreateLE0 | v < 0 = VoteLE0 - | c > v = CreateLEVote - | v >= e = ExecuteLVote | otherwise = Correct expected :: GovernorDatum -> Maybe Bool @@ -127,16 +121,6 @@ governorDatumValidProperty = VoteLE0 -> -- vote < 0 return $ ProposalThresholds execute create le0 - CreateLEVote -> do - -- c > vote - nv <- taggedInteger (0, untag create - 1) - ne <- taggedInteger (untag nv + 1, 1000000000) - return $ ProposalThresholds ne create nv - ExecuteLVote -> do - -- vote >= execute - ne <- taggedInteger (0, untag vote) - nc <- taggedInteger (0, untag vote) - return $ ProposalThresholds ne nc vote Correct -> do -- c <= vote < execute nv <- taggedInteger (0, untag execute - 1) diff --git a/agora-specs/Spec/AuthorityToken.hs b/agora-specs/Spec/AuthorityToken.hs index 46b7423..93d7bea 100644 --- a/agora-specs/Spec/AuthorityToken.hs +++ b/agora-specs/Spec/AuthorityToken.hs @@ -11,19 +11,18 @@ module Spec.AuthorityToken (specs) where import Agora.AuthorityToken (singleAuthorityTokenBurned) import Plutarch (ClosedTerm, POpaque, compile, perror, popaque) +import Plutarch.Unsafe (punsafeCoerce) import PlutusLedgerApi.V1 ( Address (Address), Credential (PubKeyCredential, ScriptCredential), CurrencySymbol, Script, TxInInfo (TxInInfo), - TxInfo (..), TxOut (TxOut), TxOutRef (TxOutRef), ValidatorHash (ValidatorHash), Value, ) -import PlutusLedgerApi.V1.Interval qualified as Interval (always) import PlutusLedgerApi.V1.Value qualified as Value ( Value (Value), singleton, @@ -36,37 +35,25 @@ import Test.Specification ( scriptSucceeds, ) import Prelude ( - Functor (fmap), Maybe (Nothing), PBool, Semigroup ((<>)), + fmap, pconstant, - pconstantData, pif, + ($), ) currencySymbol :: CurrencySymbol currencySymbol = "deadbeef" -mkTxInfo :: Value -> [TxOut] -> TxInfo -mkTxInfo mint outs = - TxInfo - { txInfoInputs = fmap (TxInInfo (TxOutRef "" 0)) outs - , txInfoOutputs = [] - , txInfoFee = Value.singleton "" "" 1000 - , txInfoMint = mint - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = [] - , txInfoData = [] - , txInfoId = "" - } +mkInputs :: [TxOut] -> [TxInInfo] +mkInputs = fmap (TxInInfo (TxOutRef "" 0)) singleAuthorityTokenBurnedTest :: Value -> [TxOut] -> Script singleAuthorityTokenBurnedTest mint outs = let actual :: ClosedTerm PBool - actual = singleAuthorityTokenBurned (pconstant currencySymbol) (pconstantData (mkTxInfo mint outs)) (pconstant mint) + actual = singleAuthorityTokenBurned (pconstant currencySymbol) (punsafeCoerce $ pconstant $ mkInputs outs) (pconstant mint) s :: ClosedTerm POpaque s = pif diff --git a/agora-specs/Spec/Proposal.hs b/agora-specs/Spec/Proposal.hs index 9ef2416..a05d147 100644 --- a/agora-specs/Spec/Proposal.hs +++ b/agora-specs/Spec/Proposal.hs @@ -40,7 +40,7 @@ specs = "use other's stake" Create.useStakeOwnBySomeoneElseParameters True - False + True False , Create.mkTestTree "altered stake" diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index 79b8869..448a215 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -100,20 +100,18 @@ authorityTokensValidIn = phoistAcyclic $ {- | Assert that a single authority token has been burned. - @since 0.1.0 + @since 0.2.0 -} singleAuthorityTokenBurned :: forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S). Term s PCurrencySymbol -> - Term s (PAsData PTxInfo) -> + Term s (PBuiltinList (PAsData PTxInInfo)) -> Term s (PValue keys amounts) -> Term s PBool -singleAuthorityTokenBurned gatCs txInfo mint = unTermCont $ do +singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do let gatAmountMinted :: Term _ PInteger gatAmountMinted = psymbolValueOf # gatCs # mint - txInfoF <- pletFieldsC @'["inputs"] $ txInfo - pure $ foldr1 (#&&) @@ -126,7 +124,7 @@ singleAuthorityTokenBurned gatCs txInfo mint = unTermCont $ do let txOut' = pfield @"resolved" # txInInfo pure $ authorityTokensValidIn # gatCs # pfromData txOut' ) - # txInfoF.inputs + # inputs ] {- | Policy given 'AuthorityToken' params. diff --git a/agora/Agora/Effect.hs b/agora/Agora/Effect.hs index 2239d24..ad4776d 100644 --- a/agora/Agora/Effect.hs +++ b/agora/Agora/Effect.hs @@ -30,7 +30,6 @@ makeEffect :: makeEffect gatCs' f = plam $ \datum _redeemer ctx' -> unTermCont $ do ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' - txInfo' <- pletC ctx.txInfo -- convert input datum, PData, into desierable type -- the way this conversion is performed should be defined @@ -42,14 +41,14 @@ makeEffect gatCs' f = txOutRef' <- pletC (pfield @"_0" # txOutRef) -- fetch minted values to ensure single GAT is burned - txInfo <- pletFieldsC @'["mint"] txInfo' + txInfo <- pletFieldsC @'["mint", "inputs"] ctx.txInfo let mint :: Term _ (PValue _ _) mint = txInfo.mint -- fetch script context gatCs <- pletC $ pconstant gatCs' - pguardC "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint + pguardC "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo.inputs mint -- run effect function - pure $ f gatCs datum' txOutRef' txInfo' + pure $ f gatCs datum' txOutRef' ctx.txInfo diff --git a/agora/Agora/Governor.hs b/agora/Agora/Governor.hs index 7378fe7..f7fb144 100644 --- a/agora/Agora/Governor.hs +++ b/agora/Agora/Governor.hs @@ -260,6 +260,4 @@ governorDatumValid = phoistAcyclic $ [ ptraceIfFalse "Execute threshold is less than or equal to" $ 0 #<= execute , ptraceIfFalse "Draft threshold is less than or equal to " $ 0 #<= draft , ptraceIfFalse "Vote threshold is less than or equal to " $ 0 #<= vote - , ptraceIfFalse "Draft threshold is less than vote threshold" $ draft #<= vote - , ptraceIfFalse "Execute threshold is less than vote threshold" $ vote #< execute ] diff --git a/agora/Agora/Governor/Scripts.hs b/agora/Agora/Governor/Scripts.hs index 6f8c778..89b96fd 100644 --- a/agora/Agora/Governor/Scripts.hs +++ b/agora/Agora/Governor/Scripts.hs @@ -47,10 +47,11 @@ import Agora.Governor ( import Agora.Proposal ( PProposalDatum (..), Proposal (..), - ProposalStatus (Draft, Finished, Locked), - pemptyVotesFor, + ProposalStatus (Draft, Locked), + phasNeutralEffect, + pisEffectsVotesCompatible, + pisVotesEmpty, pneutralOption, - proposalDatumValid, pwinner, ) import Agora.Proposal.Scripts ( @@ -58,7 +59,6 @@ import Agora.Proposal.Scripts ( proposalValidator, ) import Agora.Proposal.Time (createProposalStartingTime) -import Agora.SafeMoney (GTTag) import Agora.Stake ( PProposalLock (..), PStakeDatum (..), @@ -79,10 +79,6 @@ import Agora.Utils ( validatorHashToAddress, validatorHashToTokenName, ) -import Plutarch.Extra.Record - --------------------------------------------------------------------------------- - import Plutarch.Api.V1 ( PAddress, PCurrencySymbol, @@ -93,7 +89,6 @@ import Plutarch.Api.V1 ( PTxOut, PValidator, PValidatorHash, - PValue, mintingPolicySymbol, mkMintingPolicy, mkValidator, @@ -103,19 +98,18 @@ import Plutarch.Api.V1.AssetClass ( passetClass, passetClassValueOf, ) -import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, pisUTXOSpent, ptryFindDatum, ptxSignedBy, pvalueSpent) +import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, pisUTXOSpent, ptryFindDatum, pvalueSpent) import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (psymbolValueOf) +import Plutarch.Extra.Field (pletAllC) import Plutarch.Extra.IsData (pmatchEnumFromData) +import Plutarch.Extra.List (pfirstJust) import Plutarch.Extra.Map ( plookup, plookup', ) import Plutarch.Extra.Maybe (pisDJust) +import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC) -import Plutarch.SafeMoney (PDiscrete (..), pvalueDiscrete') - --------------------------------------------------------------------------------- - import PlutusLedgerApi.V1 ( CurrencySymbol (..), MintingPolicy, @@ -277,7 +271,7 @@ governorPolicy gov = governorValidator :: Governor -> ClosedTerm PValidator governorValidator gov = plam $ \datum' redeemer' ctx' -> unTermCont $ do - ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx' + ctxF <- pletAllC ctx' txInfo' <- pletC $ pfromData $ ctxF.txInfo txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums", "signatories", "validRange"] txInfo' @@ -292,15 +286,7 @@ governorValidator gov = let ownAddress = pfromData $ ownInputF.address (pfromData -> (oldGovernorDatum :: Term _ PGovernorDatum), _) <- ptryFromC datum' - oldGovernorDatumF <- - pletFieldsC - @'[ "proposalThresholds" - , "nextProposalId" - , "proposalTimings" - , "createProposalTimeRangeMaxWidth" - , "maximumProposalsPerStake" - ] - oldGovernorDatum + oldGovernorDatumF <- pletAllC oldGovernorDatum -- Check that GST will be returned to the governor. let ownInputGSTAmount = psymbolValueOf # pgstSymbol # ownInputF.value @@ -354,20 +340,21 @@ governorValidator gov = -- Check that a stake is spent to create the propsal, -- and the value it contains meets the requirement. - stakeInput <- + stakeInputs <- pletC $ - mustBePJust # "Stake input not found" #$ pfind + pfilter # phoistAcyclic ( plam $ - \((pfield @"resolved" #) -> txOut') -> unTermCont $ do - txOut <- pletFieldsC @'["address", "value"] txOut' - - pure $ - txOut.address #== pdata pstakeValidatorAddress - #&& psymbolValueOf # psstSymbol # txOut.value #== 1 + \((pfield @"value" #) . (pfield @"resolved" #) -> value) -> + psymbolValueOf # psstSymbol # value #== 1 ) # pfromData txInfoF.inputs + pguardC "Can process only one stake" $ + plength # stakeInputs #== 1 + + stakeInput <- pletC $ phead # stakeInputs + stakeInputF <- pletFieldsC @'["datumHash", "value"] $ pfield @"resolved" # stakeInput pguardC "Stake input doesn't have datum" $ @@ -375,20 +362,12 @@ governorValidator gov = let stakeInputDatum = mustFindDatum' @PStakeDatum # stakeInputF.datumHash # txInfoF.datums - stakeInputDatumF <- - pletFieldsC @["stakedAmount", "owner", "lockedBy"] stakeInputDatum + stakeInputDatumF <- pletAllC stakeInputDatum pguardC "Proposals created by the stake must not exceed the number stored in the governor." $ pnumCreatedProposals # stakeInputDatumF.lockedBy #< oldGovernorDatumF.maximumProposalsPerStake - pguardC "Required amount of stake GTs should be presented" $ - stakeInputDatumF.stakedAmount #== (pgtValueOf # stakeInputF.value) - - -- TODO: Is this required? - pguardC "Tx should be signed by the stake owner" $ - ptxSignedBy # txInfoF.signatories # stakeInputDatumF.owner - -- Check that the newly minted PST is sent to the proposal validator, -- and the datum it carries is legal. @@ -417,92 +396,79 @@ governorValidator gov = # outputDatumHash # txInfoF.datums - pguardC "Proposal datum must be valid" $ - proposalDatumValid' # proposalOutputDatum' + proposalOutputDatum <- pletAllC proposalOutputDatum' - proposalOutputDatum <- - pletFieldsC - @'["effects", "cosigners", "proposalId", "votes"] - proposalOutputDatum' - - pguardC "Proposal should have only one cosigner" $ - plength # pfromData proposalOutputDatum.cosigners #== 1 - - let -- Votes should be empty at this point - expectedVotes = pemptyVotesFor # pfromData proposalOutputDatum.effects - expectedStartingTime = + let expectedStartingTime = createProposalStartingTime # oldGovernorDatumF.createProposalTimeRangeMaxWidth # txInfoF.validRange - -- Id, thresholds and timings should be copied from the old governor state datum. - expectedProposalOut = - mkRecordConstr - PProposalDatum - ( #proposalId .= oldGovernorDatumF.nextProposalId - .& #effects .= proposalOutputDatum.effects - .& #status .= pconstantData Draft - .& #cosigners .= proposalOutputDatum.cosigners - .& #thresholds .= oldGovernorDatumF.proposalThresholds - .& #votes .= pdata expectedVotes - .& #timingConfig .= oldGovernorDatumF.proposalTimings - .& #startingTime .= pdata expectedStartingTime - ) - pguardC "Datum correct" $ expectedProposalOut #== proposalOutputDatum' + expectedCosigners = psingleton @PBuiltinList # stakeInputDatumF.owner - let cosigner = phead # pfromData proposalOutputDatum.cosigners - - pguardC "Cosigner should be the stake owner" $ - pdata stakeInputDatumF.owner #== cosigner + pguardC "Proposal datum correct" $ + foldl1 + (#&&) + [ ptraceIfFalse "has neutral effect" $ + phasNeutralEffect # proposalOutputDatum.effects + , ptraceIfFalse "votes have valid shape" $ + pisEffectsVotesCompatible # proposalOutputDatum.effects # proposalOutputDatum.votes + , ptraceIfFalse "votes are empty" $ + pisVotesEmpty # proposalOutputDatum.votes + , ptraceIfFalse "id correct" $ + proposalOutputDatum.proposalId #== oldGovernorDatumF.nextProposalId + , ptraceIfFalse "status is Draft" $ + proposalOutputDatum.status #== pconstantData Draft + , ptraceIfFalse "cosigners correct" $ + plistEquals # pfromData proposalOutputDatum.cosigners # expectedCosigners + , ptraceIfFalse "starting time correct" $ + proposalOutputDatum.startingTime #== expectedStartingTime + , ptraceIfFalse "copy over configurations" $ + proposalOutputDatum.thresholds #== oldGovernorDatumF.proposalThresholds + #&& proposalOutputDatum.timingConfig #== oldGovernorDatumF.proposalTimings + ] -- Check the output stake has been proposly updated. + let stakeOutputDatumHash = + mustBePJust # "Output stake should be presented" + #$ pfirstJust + # phoistAcyclic + ( plam + ( \txOut -> unTermCont $ do + txOutF <- pletFieldsC @'["datumHash", "value"] txOut - stakeOutput <- - pletC $ - mustBePJust - # "Stake output not found" - #$ pfind - # phoistAcyclic - ( plam $ - \txOut' -> unTermCont $ do - txOut <- pletFieldsC @'["address", "value"] txOut' - - pure $ - txOut.address #== pdata pstakeValidatorAddress - #&& psymbolValueOf # psstSymbol # txOut.value #== 1 - ) - # pfromData txInfoF.outputs - - stakeOutputF <- pletFieldsC @'["datumHash", "value"] $ stakeOutput - - pguardC "Staked GTs should be sent back to stake validator" $ - stakeInputDatumF.stakedAmount #== (pgtValueOf # stakeOutputF.value) - - let stakeOutputDatumHash = mustBePDJust # "Stake output should have datum" # stakeOutputF.datumHash + pure $ + pif + (psymbolValueOf # psstSymbol # txOutF.value #== 1) + ( pcon $ + PJust $ + mustBePDJust # "Output stake datum should be presented" + # txOutF.datumHash + ) + (pcon PNothing) + ) + ) + # pfromData txInfoF.outputs stakeOutputDatum = - mustBePJust # "Stake output not found" #$ ptryFindDatum # stakeOutputDatumHash # txInfoF.datums + mustBePJust @(PAsData PStakeDatum) # "Stake output datum presented" + #$ ptryFindDatum # stakeOutputDatumHash # txInfoF.datums - -- The stake should be locked by the newly created proposal. - let newLock = + stakeOutputLocks = + pfromData $ pfield @"lockedBy" # stakeOutputDatum + + -- The stake should be locked by the newly created proposal. + newLock = mkRecordConstr PCreated ( #created .= oldGovernorDatumF.nextProposalId ) -- Append new locks to existing locks - expectedProposalLocks = pcons # pdata newLock # stakeInputDatumF.lockedBy + expectedProposalLocks = + pcons # pdata newLock # stakeInputDatumF.lockedBy - expectedStakeOutputDatum = - pdata $ - mkRecordConstr - PStakeDatum - ( #stakedAmount .= stakeInputDatumF.stakedAmount - .& #owner .= stakeInputDatumF.owner - .& #lockedBy .= pdata expectedProposalLocks - ) - - pguardC "Unexpected stake output datum" $ expectedStakeOutputDatum #== stakeOutputDatum + pguardC "Stake output locks correct" $ + plistEquals # stakeOutputLocks # expectedProposalLocks pure $ popaque $ pconstant () @@ -533,36 +499,14 @@ governorValidator gov = ) # pfromData txInfoF.inputs - proposalOutputF <- - pletFieldsC @'["datumHash"] $ - mustBePJust # "Proposal output not found" - #$ pfind - # plam - ( \txOut -> unTermCont $ do - txOutF <- pletFieldsC @'["address", "value"] txOut - pure $ - psymbolValueOf # ppstSymbol # txOutF.value #== 1 - #&& txOutF.address #== pdata pproposalValidatorAddress - ) - # pfromData txInfoF.outputs - proposalInputDatum <- pletC $ mustFindDatum' @PProposalDatum # proposalInputF.datumHash # txInfoF.datums - proposalOutputDatum <- - pletC $ - mustFindDatum' @PProposalDatum - # proposalOutputF.datumHash - # txInfoF.datums - - pguardC "Proposal datum must be valid" $ - proposalDatumValid' # proposalInputDatum - #&& proposalDatumValid' # proposalOutputDatum proposalInputDatumF <- - pletFieldsC @'["proposalId", "effects", "status", "cosigners", "thresholds", "votes", "timingConfig", "startingTime"] + pletFieldsC @'["effects", "status", "thresholds", "votes"] proposalInputDatum -- Check that the proposal state is advanced so that a proposal cannot be executed twice. @@ -570,22 +514,6 @@ governorValidator gov = pguardC "Proposal must be in locked(executable) state in order to execute effects" $ proposalInputDatumF.status #== pconstantData Locked - let expectedOutputProposalDatum = - mkRecordConstr - PProposalDatum - ( #proposalId .= proposalInputDatumF.proposalId - .& #effects .= proposalInputDatumF.effects - .& #status .= pconstantData Finished - .& #cosigners .= proposalInputDatumF.cosigners - .& #thresholds .= proposalInputDatumF.thresholds - .& #votes .= proposalInputDatumF.votes - .& #timingConfig .= proposalInputDatumF.timingConfig - .& #startingTime .= proposalInputDatumF.startingTime - ) - - pguardC "Unexpected output proposal datum" $ - pdata proposalOutputDatum #== pdata expectedOutputProposalDatum - -- TODO: anything else to check here? -- Find the highest votes and the corresponding tag. @@ -661,15 +589,11 @@ governorValidator gov = Just MutateGovernor -> unTermCont $ do -- Check that a GAT is burnt. - pure $ popaque $ singleAuthorityTokenBurned patSymbol ctxF.txInfo txInfoF.mint + pure $ popaque $ singleAuthorityTokenBurned patSymbol txInfoF.inputs txInfoF.mint -------------------------------------------------------------------------- Nothing -> ptraceError "Unknown redeemer" where - -- Get th amount of governance tokens in a value. - pgtValueOf :: Term s (PValue _ _ :--> PDiscrete GTTag) - pgtValueOf = phoistAcyclic $ pvalueDiscrete' gov.gtClassRef - -- The currency symbol of authority token. patSymbol :: Term s PCurrencySymbol patSymbol = phoistAcyclic $ pconstant $ authorityTokenSymbolFromGovernor gov @@ -680,24 +604,12 @@ governorValidator gov = let AssetClass (sym, _) = proposalSTAssetClassFromGovernor gov in phoistAcyclic $ pconstant sym - -- Is a proposal state datum valid? - proposalDatumValid' :: Term s (PProposalDatum :--> PBool) - proposalDatumValid' = - let params = proposalFromGovernor gov - in phoistAcyclic $ proposalDatumValid params - -- The address of the proposal validator. pproposalValidatorAddress :: Term s PAddress pproposalValidatorAddress = let vh = proposalValidatorHashFromGovernor gov in phoistAcyclic $ pconstant $ validatorHashToAddress vh - -- The address of the stake validator. - pstakeValidatorAddress :: Term s PAddress - pstakeValidatorAddress = - let vh = stakeValidatorHashFromGovernor gov - in phoistAcyclic $ pconstant $ validatorHashToAddress vh - -- The currency symbol of the stake state token. psstSymbol :: Term s PCurrencySymbol psstSymbol = diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 45758d4..d06d0d3 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -29,8 +29,9 @@ module Agora.Proposal ( PResultTag (..), -- * Plutarch helpers - proposalDatumValid, - pemptyVotesFor, + phasNeutralEffect, + pisEffectsVotesCompatible, + pisVotesEmpty, pwinner, pwinner', pneutralOption, @@ -50,6 +51,7 @@ import Plutarch.Api.V1 ( PPubKeyHash, PValidatorHash, ) +import Plutarch.Api.V1.AssocMap qualified as PAssocMap import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..)) import Plutarch.Extra.IsData ( DerivePConstantViaDataList (..), @@ -57,11 +59,10 @@ import Plutarch.Extra.IsData ( EnumIsData (..), ProductIsData (ProductIsData), ) -import Plutarch.Extra.List (pnotNull) import Plutarch.Extra.Map qualified as PM import Plutarch.Extra.Map.Unsorted qualified as PUM import Plutarch.Extra.Other (DerivePNewtype' (..)) -import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC) +import Plutarch.Extra.TermCont (pguardC, pletC) import Plutarch.Lift ( DerivePConstantViaNewtype (..), PConstantDecl, @@ -597,19 +598,6 @@ deriving via instance (PConstantDecl ProposalVotes) -{- | Plutarch-level version of 'emptyVotesFor'. - - @since 0.1.0 --} -pemptyVotesFor :: forall s a. (PIsData a) => Term s (PMap 'Unsorted PResultTag a :--> PProposalVotes) -pemptyVotesFor = - phoistAcyclic $ - plam - ( \m -> - pcon $ - PProposalVotes $ PM.pmap # plam (const $ pconstant 0) # m - ) - {- | Plutarch-level version of 'ProposalDatum'. @since 0.1.0 @@ -712,27 +700,50 @@ deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instanc @since 0.1.0 -} -proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool) -proposalDatumValid proposal = - phoistAcyclic $ - plam $ \datum' -> unTermCont $ do - datum <- pletFieldsC @'["effects", "cosigners", "votes"] $ datum' - let atLeastOneNegativeResult = - pany - # phoistAcyclic - (plam $ \m -> pnull #$ pto $ pfromData $ psndBuiltin # m) - #$ pto - $ pfromData datum.effects +{- | Return true if the effect list contains at least one neutral outcome. - pure $ - foldr1 - (#&&) - [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult - , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners - , ptraceIfFalse "Proposal has fewer cosigners than the limit" $ plength # pfromData datum.cosigners #<= pconstant proposal.maximumCosigners - , ptraceIfFalse "Proposal votes and effects are compatible with each other" $ PUM.pkeysEqual # datum.effects # pto (pfromData datum.votes) - ] + @since 0.2.0 +-} +phasNeutralEffect :: + forall (s :: S). + Term + s + ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash) + :--> PBool + ) +phasNeutralEffect = phoistAcyclic $ PAssocMap.pany # PAssocMap.pnull + +{- | Return true if votes and effects of the proposal have the same key set. + + @since 0.2.0 +-} +pisEffectsVotesCompatible :: + forall (s :: S). + Term + s + ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash) + :--> PProposalVotes + :--> PBool + ) +pisEffectsVotesCompatible = phoistAcyclic $ + plam $ \m (pto -> v :: Term _ (PMap _ _ _)) -> + PUM.pkeysEqual # m # v + +{- | Retutns true if vote counts of /all/ the options are zero. + + @since 0.2.0 +-} +pisVotesEmpty :: + forall (s :: S). + Term + s + ( PProposalVotes + :--> PBool + ) +pisVotesEmpty = phoistAcyclic $ + plam $ \(pto -> m :: Term _ (PMap _ _ _)) -> + PAssocMap.pall # plam (#== 0) # m {- | Wrapper for 'pwinner''. When the winner cannot be found, the 'neutral' option will be returned. diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 9412b1e..a3bd325 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -40,7 +40,6 @@ import Agora.Utils ( getMintingPolicySymbol, mustBePJust, mustFindDatum', - pisUniq', pltAsData, ) import Plutarch.Api.V1 ( @@ -63,7 +62,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 (pmapMaybe, pmergeBy, pmsortBy) +import Plutarch.Extra.List (pisUniq', pmapMaybe, pmergeBy, pmsortBy) import Plutarch.Extra.Map (plookup, pupdate) import Plutarch.Extra.Maybe (pfromDJust, pfromJust, pisJust) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index cb14229..e269428 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -51,13 +51,14 @@ import Plutarch.Extra.IsData ( ) import Plutarch.Extra.List (pnotNull) import Plutarch.Extra.Other (DerivePNewtype' (..)) +import Plutarch.Extra.Sum (PSum (..)) +import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.SafeMoney (PDiscrete) import Plutarch.Show (PShow (..)) import PlutusLedgerApi.V1 (PubKeyHash) import PlutusLedgerApi.V1.Value (AssetClass) import PlutusTx qualified -import Prelude ((+)) import Prelude hiding (Num (..)) -------------------------------------------------------------------------------- @@ -396,21 +397,14 @@ pnumCreatedProposals :: Term s (PBuiltinList (PAsData PProposalLock) :--> PInteg pnumCreatedProposals = phoistAcyclic $ plam $ \l -> - pfoldl - # phoistAcyclic - ( plam - ( \c (pfromData -> lock) -> - c - + pmatch - lock - ( \case - PCreated _ -> 1 - _ -> 0 - ) - ) - ) - # 0 - # l + pto $ + pfoldMap + # plam + ( \(pfromData -> lock) -> pmatch lock $ \case + PCreated _ -> pcon $ PSum 1 + _ -> mempty + ) + # l {- | The role of a stake for a particular proposal. Scott-encoded. diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index 16d5a51..bc7cc73 100644 --- a/agora/Agora/Treasury.hs +++ b/agora/Agora/Treasury.hs @@ -114,14 +114,13 @@ treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> unTermCont $ do redeemer #== pforgetData (pconstantData SpendTreasuryGAT) -- Get the minted value from txInfo. - txInfo' <- pletC ctx.txInfo - txInfo <- pletFieldsC @'["mint"] txInfo' + txInfo <- pletFieldsC @'["mint", "inputs"] ctx.txInfo let mint :: Term _ (PValue _ _) mint = txInfo.mint gatCs <- pletC $ pconstant gatCs' pguardC "A single authority token has been burned" $ - singleAuthorityTokenBurned gatCs txInfo' mint + singleAuthorityTokenBurned gatCs txInfo.inputs mint pure . popaque $ pconstant () diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index e8945c2..3c46016 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -20,8 +20,6 @@ module Agora.Utils ( isScriptAddress, isPubKey, pltAsData, - pisUniqBy', - pisUniq', ) where import Plutarch.Api.V1 ( @@ -208,36 +206,3 @@ pltAsData :: 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 0caf6cf..7557f59 100644 --- a/bench.csv +++ b/bench.csv @@ -1,18 +1,19 @@ name,cpu,mem,size -Agora/Effects/Treasury Withdrawal Effect/effect/Simple,333327612,830203,3674 -Agora/Effects/Treasury Withdrawal Effect/effect/Simple with multiple treasuries ,492387542,1197315,3986 -Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,456007605,1104500,3859 -Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,88940927,246756,8891 -Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,107090537,296185,3627 +Agora/Effects/Treasury Withdrawal Effect/effect/Simple,333137234,829671,3674 +Agora/Effects/Treasury Withdrawal Effect/effect/Simple with multiple treasuries ,492197164,1196783,3986 +Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,455817227,1103968,3859 +Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,84914023,233054,7949 +Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,104760131,289547,3491 Agora/Stake/policy/stakeCreation,51008580,149029,2522 Agora/Stake/validator/stakeDepositWithdraw deposit,183506412,498838,4745 Agora/Stake/validator/stakeDepositWithdraw withdraw,183506412,498838,4733 Agora/Proposal/policy (proposal creation)/legal/proposal,34975627,103548,2117 -Agora/Proposal/policy (proposal creation)/legal/governor,327971301,871386,9370 +Agora/Proposal/policy (proposal creation)/legal/governor,316600184,838411,8429 Agora/Proposal/policy (proposal creation)/legal/stake,152415805,398403,5404 Agora/Proposal/policy (proposal creation)/illegal/invalid next proposal id/proposal,34975627,103548,2117 Agora/Proposal/policy (proposal creation)/illegal/invalid next proposal id/stake,152415805,398403,5404 Agora/Proposal/policy (proposal creation)/illegal/use other's stake/proposal,34975627,103548,2086 +Agora/Proposal/policy (proposal creation)/illegal/use other's stake/governor,316600184,838411,8398 Agora/Proposal/policy (proposal creation)/illegal/altered stake/proposal,34975627,103548,2117 Agora/Proposal/policy (proposal creation)/illegal/invalid stake locks/proposal,34975627,103548,2125 Agora/Proposal/policy (proposal creation)/illegal/invalid stake locks/stake,157849465,413053,5412 @@ -223,12 +224,12 @@ Agora/Proposal/validator/unlocking/illegal/with 42 proposals/remove creator too Agora/Proposal/validator/unlocking/illegal/with 42 proposals/remove creator too early/status: VotingReady/stake,1674013803,4194887,26590 Agora/Proposal/validator/unlocking/illegal/with 42 proposals/remove creator too early/status: Locked/stake,1674013803,4194887,26590 Agora/Proposal/validator/unlocking/illegal/with 42 proposals/creator: retract votes/stake,1674013803,4194887,26506 -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 -Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,806 -Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 -Agora/Governor/policy/GST minting,51480023,145787,2048 -Agora/Governor/validator/proposal creation,303114849,813451,9390 -Agora/Governor/validator/GATs minting,422654153,1147158,9516 -Agora/Governor/validator/mutate governor state,90087778,252215,8991 +Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,20570665,54655,725 +Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,32757063,87013,825 +Agora/Treasury/Validator/Positive/Allows for effect changes,31277082,80782,1450 +Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,20570665,54655,725 +Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,32757063,87013,825 +Agora/Governor/policy/GST minting,49408995,139981,1910 +Agora/Governor/validator/proposal creation,294638205,791763,8449 +Agora/Governor/validator/GATs minting,249873031,663031,8575 +Agora/Governor/validator/mutate governor state,86060874,238513,8049