partially fix cosigning logic; improve performance

2022-06-28 22:38:44 +08:00 · 2022-06-28 22:38:44 +08:00 · 95410ce254
commit 95410ce254
parent a293f7acc3
3 changed files with 346 additions and 355 deletions
--- 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,44 +236,159 @@ 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
+        PCosign r -> unTermCont $ do
+          pguardC "Should be in draft state" $
+            proposalF.status #== pconstant Draft
+
+          newSigs <- pletC $ pfield @"newCosigners" # r
+
+          pguardC "Signed by all new cosigners" $
+            pall # signedBy # 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 -> 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
@ -281,7 +396,9 @@ proposalValidator proposal =
                  proposalF.status #== pconstant VotingReady

                pguardC "Proposal time should be wthin the voting period" $
-            isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
+                  isVotingPeriod # proposalF.timingConfig
+                    # proposalF.startingTime
+                    # currentTime

                -- Ensure the transaction is voting to a valid 'ResultTag'(outcome).
                PProposalVotes voteMap <- pmatchC proposalF.votes
@ -354,58 +471,7 @@ proposalValidator proposal =

                pure $ popaque (pconstant ())
              --------------------------------------------------------------------------
-        PCosign r -> unTermCont $ do
-          pguardC "Stake should not change" stakeUnchanged

-          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 "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
-                )
-              # newSigs
-
-          let updatedSigs = pconcat # newSigs # proposalF.cosigners
-              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
-
-          pure $ popaque (pconstant ())
-        --------------------------------------------------------------------------
              PUnlock r -> unTermCont $ do
                -- At draft stage, the votes should be empty.
                pguardC "Shouldn't retract votes from a draft proposal" $
@ -482,9 +548,10 @@ proposalValidator proposal =
                    # proposalF.proposalId #== pcon PDidNothing

                pure $ popaque (pconstant ())
-        --------------------------------------------------------------------------
-        PAdvanceProposal _r -> unTermCont $ do
-          pguardC "Stake should not change" stakeUnchanged
+              ------------------------------------------------------------------
+              PAdvanceProposal _ -> unTermCont $ do
+                pguardC "Stake should not change" $
+                  stakeInputHash #== stakeOutputHash

                proposalOutStatus <- pletC $ pfield @"status" # proposalOut

@ -572,3 +639,4 @@ proposalValidator proposal =
                          -- TODO: Should check that the GST is not moved
                          --        if the proposal is in 'Locked' state.
                    )
+              _ -> popaque (pconstant ())
--- 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.

--- 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