check stake locks in stake validator

2022-09-26 20:17:41 +08:00 · 2022-09-26 20:17:41 +08:00 · b7a7d6c505
commit b7a7d6c505
parent dd05ab45ca
4 changed files with 157 additions and 69 deletions
--- a/agora-specs/Spec/Proposal.hs
+++ b/agora-specs/Spec/Proposal.hs
@ -53,7 +53,7 @@ specs =
              Create.addInvalidLocksParameters
              True
              False
-              True
+              False
          , Create.mkTestTree
              "has reached maximum proposals limit"
              Create.exceedMaximumProposalsParameters
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@ -45,6 +45,7 @@ module Agora.Stake (
 import Agora.Proposal (
  PProposalId,
  PProposalRedeemer,
+  PProposalStatus,
  PResultTag,
  ProposalId,
  ResultTag,
@ -252,6 +253,8 @@ newtype PStakeDatum (s :: S) = PStakeDatum
      PEq
    , -- | @since 1.0.0
      PDataFields
+    , -- | @since 1.0.0
+      PShow
    )

 instance DerivePlutusType PStakeDatum where
@ -503,9 +506,13 @@ instance DerivePlutusType PStakeRedeemerContext where
 -}
 data PProposalContext (s :: S)
  = -- | A proposal is spent.
-    PWithProposalRedeemer (Term s PProposalRedeemer)
+    PSpendProposal
+      (Term s PProposalId)
+      (Term s PProposalStatus)
+      (Term s PProposalRedeemer)
  | -- | A new proposal is created.
    PNewProposal
+      (Term s PProposalId)
  | -- | No proposal is spent or created.
    PNoProposal
  deriving stock
--- a/agora/Agora/Stake/Redeemers.hs
+++ b/agora/Agora/Stake/Redeemers.hs
@ -14,12 +14,17 @@ module Agora.Stake.Redeemers (
  pdepositWithdraw,
 ) where

-import Agora.Proposal (PProposalRedeemer (PUnlock, PVote))
+import Agora.Proposal (
+  PProposalId,
+  PProposalRedeemer (PUnlock, PVote),
+  ProposalStatus (Finished),
+ )
 import Agora.Stake (
  PProposalContext (
    PNewProposal,
-    PWithProposalRedeemer
+    PSpendProposal
  ),
+  PProposalLock (PCreated, PVoted),
  PSigContext (owner, signedBy),
  PSignedBy (
    PSignedByDelegate,
@ -93,26 +98,39 @@ pisSignedBy = phoistAcyclic $
 -- | Return true if only the @lockedBy@ field of the stake datum is updated.
 ponlyLocksUpdated ::
  forall (s :: S).
-  Term s (PStakeRedeemerHandlerContext :--> PBool)
+  Term
+    s
+    ( ( PBuiltinList (PAsData PProposalLock)
+          :--> PBuiltinList (PAsData PProposalLock)
+      )
+        :--> PStakeRedeemerHandlerContext
+        :--> PBool
+    )
 ponlyLocksUpdated = phoistAcyclic $
-  pbatchUpdateInputs #$ plam $ \i o ->
-    pletAll i $ \iF ->
-      let newLocks = pfield @"lockedBy" # o
-       in mkRecordConstr
-            PStakeDatum
-            ( #stakedAmount .= iF.stakedAmount
-                .& #owner .= iF.owner
-                .& #delegatedTo .= iF.delegatedTo
-                .& #lockedBy .= newLocks
-            )
-            #== o
+  plam $ \f ->
+    pbatchUpdateInputs #$ plam $ \i o ->
+      pletAll i $ \iF ->
+        let newLocks = f # pfromData iF.lockedBy
+
+            expected =
+              mkRecordConstr
+                PStakeDatum
+                ( #stakedAmount .= iF.stakedAmount
+                    .& #owner .= iF.owner
+                    .& #delegatedTo .= iF.delegatedTo
+                    .& #lockedBy .= pdata newLocks
+                )
+         in expected #== o

 -- | Validation logic shared between 'ppermitVote' and 'retractVote'.
 pvoteHelper ::
  forall (s :: S).
  Term
    s
-    ( (PProposalContext :--> PBool)
+    ( ( PProposalContext
+          :--> PBuiltinList (PAsData PProposalLock)
+          :--> PBuiltinList (PAsData PProposalLock)
+      )
        :--> PStakeRedeemerHandler
    )
 pvoteHelper = phoistAcyclic $
@ -125,14 +143,21 @@ pvoteHelper = phoistAcyclic $
    -- This puts trust into the Proposal. The Proposal must necessarily check
    -- that this is not abused.

-    pguardC "Proposal ST spent" $
-      valProposalCtx # ctxF.proposalContext
-
    pguardC "Correct outputs" $
-      ponlyLocksUpdated # ctx
+      ponlyLocksUpdated # (valProposalCtx # ctxF.proposalContext) # ctx

    pure $ pconstant ()

+paddNewLock ::
+  forall (s :: S).
+  Term
+    s
+    ( PProposalLock
+        :--> PBuiltinList (PAsData PProposalLock)
+        :--> PBuiltinList (PAsData PProposalLock)
+    )
+paddNewLock = phoistAcyclic $ plam $ \newLock -> pcons # pdata newLock
+
 {- | Default implementation of 'Agora.Stake.PermitVote'.

     @since 1.0.0
@ -141,11 +166,41 @@ ppermitVote :: forall (s :: S). Term s PStakeRedeemerHandler
 ppermitVote = pvoteHelper #$ phoistAcyclic $
  plam $
    flip pmatch $ \case
-      PWithProposalRedeemer r -> pmatch r $ \case
-        PVote _ -> pconstant True
-        _ -> ptrace "Expected Vote" $ pconstant False
-      PNewProposal -> pconstant True
-      _ -> pconstant False
+      PSpendProposal pid _ r -> pmatch r $ \case
+        PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) ->
+          let newLock =
+                mkRecordConstr
+                  PVoted
+                  ( #votedOn .= pdata pid
+                      .& #votedFor .= pdata voteFor
+                  )
+           in paddNewLock # newLock
+        _ -> ptraceError "Expected Vote"
+      PNewProposal pid ->
+        let newLock =
+              mkRecordConstr
+                PCreated
+                ( #created .= pdata pid
+                )
+         in paddNewLock # newLock
+      _ -> ptraceError "Expected proposal"
+
+premoveLocks ::
+  forall (s :: S).
+  Term
+    s
+    ( PProposalId :--> PBool
+        :--> PBuiltinList (PAsData PProposalLock)
+        :--> PBuiltinList (PAsData PProposalLock)
+    )
+premoveLocks = phoistAcyclic $
+  plam $ \pid rc ->
+    pfilter
+      # plam
+        ( \(pfromData -> l) -> pnot #$ pmatch l $ \case
+            PCreated ((pfield @"created" #) -> pid') -> rc #&& pid' #== pid
+            PVoted ((pfield @"votedOn" #) -> pid') -> pid' #== pid
+        )

 {- | Default implementation of 'Agora.Stake.RetractVotes'.

@ -155,10 +210,13 @@ pretractVote :: forall (s :: S). Term s PStakeRedeemerHandler
 pretractVote = pvoteHelper #$ phoistAcyclic $
  plam $
    flip pmatch $ \case
-      PWithProposalRedeemer r -> pmatch r $ \case
-        PUnlock _ -> pconstant True
-        _ -> ptrace "Expected Unlock" $ pconstant False
-      _ -> pconstant False
+      PSpendProposal pid s r -> pmatch r $ \case
+        PUnlock _ ->
+          let allowRemovingCreatorLock =
+                s #== pconstant Finished
+           in premoveLocks # pid # allowRemovingCreatorLock
+        _ -> ptraceError "Expected unlock"
+      _ -> ptraceError "Expected spending proposal"

 -- | Validation logic shared by 'pdelegateTo' and 'pclearDelegate'.
 pdelegateHelper ::
--- a/agora/Agora/Stake/Scripts.hs
+++ b/agora/Agora/Stake/Scripts.hs
@ -12,7 +12,7 @@ module Agora.Stake.Scripts (
 ) where

 import Agora.Credential (authorizationContext, pauthorizedBy)
-import Agora.Proposal (PProposalRedeemer)
+import Agora.Proposal (PProposalDatum, PProposalRedeemer)
 import Agora.SafeMoney (GTTag)
 import Agora.Scripts (
  AgoraScripts,
@ -23,7 +23,7 @@ import Agora.Stake (
  PProposalContext (
    PNewProposal,
    PNoProposal,
-    PWithProposalRedeemer
+    PSpendProposal
  ),
  PSigContext (PSigContext),
  PSignedBy (
@ -73,10 +73,8 @@ import Plutarch.Api.V2 (
  AmountGuarantees,
  PMintingPolicy,
  PScriptPurpose (PMinting, PSpending),
-  PTxInInfo,
  PTxInfo,
  PTxOut,
-  PTxOutRef,
  PValidator,
 )
 import Plutarch.Extra.AssetClass (
@ -84,14 +82,14 @@ import Plutarch.Extra.AssetClass (
  passetClassValueOf,
  pvalueOf,
 )
-import Plutarch.Extra.Bind (PBind ((#>>=)))
 import Plutarch.Extra.Category (PSemigroupoid ((#>>>)))
+import Plutarch.Extra.Field (pletAll)
 import Plutarch.Extra.Functor (PFunctor (pfmap))
 import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
 import Plutarch.Extra.Maybe (
  passertPJust,
+  pfromMaybe,
  pjust,
-  pmaybe,
  pmaybeData,
  pnothing,
 )
@ -402,9 +400,9 @@ mkStakeValidator
      pguardC "No new SST minted" $
        foldl1
          (#||)
-          [ ptraceIfFalse "All stakes burnt" $
+          [ ptraceIfTrue "All stakes burnt" $
              mintedST #< 0 #&& pnull # stakeOutputDatums
-          , ptraceIfFalse "Nothing burnt" $
+          , ptraceIfTrue "Nothing burnt" $
              mintedST #== 0
          ]

@ -420,42 +418,67 @@ mkStakeValidator
            # pconstant propCs
            # pconstant propTn

+      getProposalDatum <- pletC $
+        plam $
+          flip pletAll $ \txOutF ->
+            let isProposalUTxO =
+                  passetClassValueOf
+                    # txOutF.value
+                    # proposalSTClass #== 1
+                proposalDatum =
+                  pfromData $
+                    pfromOutputDatum @(PAsData PProposalDatum)
+                      # txOutF.datum
+                      # txInfoF.datums
+             in pif isProposalUTxO (pjust # proposalDatum) pnothing
+
      let pstMinted =
            passetClassValueOf # txInfoF.mint # proposalSTClass #== 1

+          newProposalContext =
+            pcon $
+              PNewProposal $
+                pfield @"proposalId"
+                  #$ passertPJust # "Proposal output should present"
+                  #$ pfindJust # getProposalDatum # pfromData txInfoF.outputs
+
+          spendProposalContext =
+            let getProposalRedeemer = plam $ \ref ->
+                  flip (ptryFrom @PProposalRedeemer) fst $
+                    pto $
+                      passertPJust
+                        # "Malformed script context: propsoal input not found in redeemer map"
+                          #$ plookup
+                        # pcon
+                          ( PSpending $
+                              pdcons @_0
+                                # pdata ref
+                                # pdnil
+                          )
+                        # txInfoF.redeemers
+
+                getContext = plam $
+                  flip pletAll $ \inInfoF ->
+                    pfmap
+                      # plam
+                        ( \proposalDatum ->
+                            let id = pfield @"proposalId" # proposalDatum
+                                status = pfield @"status" # proposalDatum
+                                redeemer = getProposalRedeemer # inInfoF.outRef
+                             in pcon $ PSpendProposal id status redeemer
+                        )
+                      #$ getProposalDatum
+                      # pfromData inInfoF.resolved
+             in pfindJust # getContext # pfromData txInfoF.inputs
+
+          noProposalContext = pcon PNoProposal
+
      proposalContext <-
        pletC $
-          let convertRedeemer = plam $ \(pto -> dt) ->
-                ptryFrom @PProposalRedeemer dt fst
-
-              findRedeemer = plam $ \ref ->
-                plookup
-                  # pcon
-                    ( PSpending $
-                        pdcons @_0
-                          # pdata ref
-                          # pdnil
-                    )
-                  # txInfoF.redeemers
-
-              f :: Term _ (PTxInInfo :--> PMaybe PTxOutRef)
-              f = plam $ \inInfo ->
-                let value = pfield @"value" #$ pfield @"resolved" # inInfo
-                    ref = pfield @"outRef" # inInfo
-                 in pif
-                      (passetClassValueOf # value # proposalSTClass #== 1)
-                      (pjust # ref)
-                      pnothing
-
-              proposalRef = pfindJust # f # txInfoF.inputs
-           in pif pstMinted (pcon PNewProposal) $
-                pmaybe
-                  # pcon PNoProposal
-                  # plam
-                    ( \((convertRedeemer #) -> proposalRedeemer) ->
-                        pcon $ PWithProposalRedeemer proposalRedeemer
-                    )
-                  #$ proposalRef #>>= findRedeemer
+          pif
+            pstMinted
+            newProposalContext
+            (pfromMaybe # noProposalContext # spendProposalContext)

      --------------------------------------------------------------------------