prevent minting multiple into one UTxO; regression tests

2022-11-09 17:42:18 +08:00 · 2022-11-09 17:42:18 +08:00 · 287054d95e
commit 287054d95e
parent 0eacf1f6f2
8 changed files with 215 additions and 123 deletions
--- a/agora/Agora/AuthorityToken.hs
+++ b/agora/Agora/AuthorityToken.hs
@ -11,6 +11,7 @@ module Agora.AuthorityToken (
  singleAuthorityTokenBurned,
 ) where

+import Agora.Governor (PGovernorRedeemer (PMintGATs), presolveGovernorRedeemer)
 import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag)
 import Agora.Utils (psymbolValueOfT, ptag, ptoScottEncodingT, puntag)
 import Plutarch.Api.V1 (
@ -24,17 +25,14 @@ import Plutarch.Api.V2 (
  KeyGuarantees,
  PAddress (PAddress),
  PMintingPolicy,
-  PScriptContext (PScriptContext),
  PScriptPurpose (PMinting),
  PTxInInfo (PTxInInfo),
-  PTxInfo (PTxInfo),
  PTxOut (PTxOut),
 )
 import Plutarch.Extra.AssetClass (PAssetClassData)
 import Plutarch.Extra.Bool (passert)
 import "liqwid-plutarch-extra" Plutarch.Extra.List (plookupAssoc)
-import Plutarch.Extra.Maybe (pfromJust)
-import Plutarch.Extra.ScriptContext (pisTokenSpent)
+import Plutarch.Extra.Maybe (passertPJust, pfromJust)
 import Plutarch.Extra.Sum (PSum (PSum))
 import Plutarch.Extra.Tagged (PTagged)
 import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
@ -149,33 +147,44 @@ singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
 -}
 authorityTokenPolicy :: ClosedTerm (PTagged GovernorSTTag PAssetClassData :--> PMintingPolicy)
 authorityTokenPolicy =
-  plam $ \gstAssetClass _redeemer ctx' ->
-    pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do
-      ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
-      PTxInfo txInfo' <- pmatchC $ pfromData ctx.txInfo
-      txInfo <- pletFieldsC @'["inputs", "mint", "outputs"] txInfo'
-      let inputs = txInfo.inputs
-          govTokenSpent = pisTokenSpent # puntag (ptoScottEncodingT # gstAssetClass) # inputs
+  plam $ \gstAssetClass _redeemer ctx -> unTermCont $ do
+    ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
+    txInfoF <-
+      pletFieldsC
+        @'[ "inputs"
+          , "mint"
+          , "outputs"
+          , "redeemers"
+          ]
+        ctxF.txInfo

-      PMinting ownSymbol' <- pmatchC $ pfromData ctx.purpose
+    PMinting ownSymbol' <- pmatchC $ pfromData ctxF.purpose

-      let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
+    let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'

-      PPair mintedATs burntATs <-
-        pmatchC $ pfromJust #$ psymbolValueOf' # ownSymbol # txInfo.mint
+    PPair mintedATs burntATs <-
+      pmatchC $ pfromJust #$ psymbolValueOf' # ownSymbol # txInfoF.mint

-      pure $
-        popaque $
-          pif
-            (0 #< mintedATs)
-            ( unTermCont $ do
-                pguardC "No GAT burnt" $ 0 #== burntATs
-                pguardC "Parent token did not move in minting GATs" govTokenSpent
-                pguardC "All outputs only emit valid GATs" $
-                  pall
-                    # plam
-                      (authorityTokensValidIn # ptag ownSymbol #)
-                    # txInfo.outputs
-                pure $ pconstant ()
-            )
-            (passert "No GAT minted" (0 #== mintedATs) (pconstant ()))
+    pure $
+      popaque $
+        pif
+          (0 #< mintedATs)
+          ( unTermCont $ do
+              pguardC "No GAT burnt" $ 0 #== burntATs
+              let governorRedeemer =
+                    passertPJust
+                      # "GST should move"
+                      #$ presolveGovernorRedeemer
+                      # (ptoScottEncodingT # gstAssetClass)
+                      # pfromData txInfoF.inputs
+                      # txInfoF.redeemers
+              pguardC "Governor redeemr correct" $
+                pcon PMintGATs #== governorRedeemer
+              pguardC "All outputs only emit valid GATs" $
+                pall
+                  # plam
+                    (authorityTokensValidIn # ptag ownSymbol #)
+                  # txInfoF.outputs
+              pure $ pconstant ()
+          )
+          (passert "No GAT minted" (0 #== mintedATs) (pconstant ()))
--- a/agora/Agora/Governor.hs
+++ b/agora/Agora/Governor.hs
@ -21,6 +21,7 @@ module Agora.Governor (
  pgetNextProposalId,
  getNextProposalId,
  pisGovernorDatumValid,
+  presolveGovernorRedeemer,
 ) where

 import Agora.Aeson.Orphans ()
@ -39,21 +40,33 @@ import Agora.Proposal.Time (
  pisMaxTimeRangeWidthValid,
  pisProposalTimingConfigValid,
 )
-import Agora.SafeMoney (GTTag)
+import Agora.SafeMoney (GTTag, GovernorSTTag)
 import Data.Aeson qualified as Aeson
 import Data.Tagged (Tagged)
 import Optics.TH (makeFieldLabelsNoPrefix)
+import Plutarch.Api.V1.Scripts (PRedeemer)
+import Plutarch.Api.V2 (KeyGuarantees (Unsorted), PMap, PScriptPurpose (PSpending), PTxInInfo)
 import Plutarch.DataRepr (
  DerivePConstantViaData (DerivePConstantViaData),
  PDataFields,
 )
-import Plutarch.Extra.AssetClass (AssetClass)
+import Plutarch.Extra.AssetClass (AssetClass, PAssetClass)
+import Plutarch.Extra.Bind (PBind ((#>>=)))
+import Plutarch.Extra.Field (pletAll)
+import Plutarch.Extra.Function (pflip)
+import Plutarch.Extra.Functor (PFunctor (pfmap))
 import Plutarch.Extra.IsData (
  DerivePConstantViaEnum (DerivePConstantEnum),
  EnumIsData (EnumIsData),
  PlutusTypeEnumData,
 )
+import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
+import Plutarch.Extra.Maybe (pjust, pnothing)
+import Plutarch.Extra.Record (mkRecordConstr, (.=))
+import Plutarch.Extra.ScriptContext (ptryFromRedeemer)
+import Plutarch.Extra.Tagged (PTagged)
 import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletFieldsC)
+import Plutarch.Extra.Value (passetClassValueOfT)
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import PlutusLedgerApi.V1 (TxOutRef)
 import PlutusTx qualified
@ -285,3 +298,49 @@ pisGovernorDatumValid = phoistAcyclic $
        , ptraceIfFalse "time range valid" $
            pisMaxTimeRangeWidthValid # datumF.createProposalTimeRangeMaxWidth
        ]
+
+-- | @since 1.0.0
+presolveGovernorRedeemer ::
+  forall (s :: S).
+  Term
+    s
+    ( PTagged GovernorSTTag PAssetClass
+        :--> PBuiltinList PTxInInfo
+        :--> PMap 'Unsorted PScriptPurpose PRedeemer
+        :--> PMaybe PGovernorRedeemer
+    )
+presolveGovernorRedeemer = phoistAcyclic $
+  plam $ \gstClass inputs redeemers ->
+    let governorInputRef =
+          pfindJust
+            # plam
+              ( flip pletAll $ \inputF ->
+                  let value = pfield @"value" # inputF.resolved
+                      isGovernorInput =
+                        passetClassValueOfT
+                          # gstClass
+                          # value
+                          #== 1
+                   in pif
+                        isGovernorInput
+                        (pjust # inputF.outRef)
+                        pnothing
+              )
+            # inputs
+
+        governorScriptPurpose =
+          pfmap
+            # plam
+              ( \ref ->
+                  mkRecordConstr
+                    PSpending
+                    (#_0 .= ref)
+              )
+            # governorInputRef
+
+        governorRedeemer =
+          governorScriptPurpose
+            #>>= pflip
+            # ptryFromRedeemer @(PAsData PGovernorRedeemer)
+            # redeemers
+     in pfmap # plam pfromData # governorRedeemer
--- a/agora/Agora/Governor/Scripts.hs
+++ b/agora/Agora/Governor/Scripts.hs
@ -57,8 +57,8 @@ import Plutarch.Extra.AssetClass (PAssetClassData, passetClass)
 import Plutarch.Extra.Field (pletAll, pletAllC)
 import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, plistEqualsBy, pmapMaybe)
 import "liqwid-plutarch-extra" Plutarch.Extra.Map (pkeys, ptryLookup)
-import Plutarch.Extra.Maybe (passertPJust, pjust, pmaybe, pmaybeData, pnothing)
-import Plutarch.Extra.Ord (psort)
+import Plutarch.Extra.Maybe (passertPJust, pjust, pmaybeData, pnothing)
+import Plutarch.Extra.Ord (POrdering (..), pcompareBy, pfromOrd, psort)
 import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
 import Plutarch.Extra.ScriptContext (
  pfindTxInByTxOutRef,
@ -335,6 +335,8 @@ governorValidator =

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

+    pstClass <- pletC $ passetClass # pto pstSymbol # pconstant ""
+
    getProposalDatum :: Term _ (PTxOut :--> PMaybe PProposalDatum) <-
      pletC $
        plam $
@ -342,8 +344,8 @@ governorValidator =
            let isProposalUTxO =
                  txOutF.address
                    #== pdata proposalValidatorAddress
-                    #&& psymbolValueOfT
-                    # pstSymbol
+                    #&& passetClassValueOf
+                    # pstClass
                    # txOutF.value
                    #== 1

@ -388,16 +390,7 @@ governorValidator =
          -- Check that exactly one proposal token is being minted.

          pguardC "Exactly one proposal token must be minted" $
-            let vMap = pfromData $ pto txInfoF.mint
-                tnMap = plookup # puntag pstSymbol # vMap
-                -- Ada and PST
-                onlyPST = plength # pto vMap #== 2
-                onePST =
-                  pmaybe
-                    # pconstant False
-                    # plam (#== AssocMap.psingleton # pconstant "" # 1)
-                    # tnMap
-             in onlyPST #&& onePST
+            passetClassValueOf # pstClass # txInfoF.mint #== 1

          -- Check that a stake is spent to create the propsal,
          --   and the value it contains meets the requirement.
@ -510,14 +503,13 @@ governorValidator =
                  ( \output -> unTermCont $ do
                      outputF <- pletFieldsC @'["address", "datum", "value"] output

-                      let isAuthorityUTxO =
+                      let atAmount =
                            psymbolValueOfT
                              # atSymbol
                              # outputF.value
-                              #== 1

                          handleAuthorityUTxO =
-                            unTermCont $ do
+                            do
                              receiverScriptHash <-
                                pletC $
                                  passertPJust
@ -556,13 +548,21 @@ governorValidator =
                                  , ptraceIfFalse "Value correctly encodes Auth Check script" valueGATCorrect
                                  ]

-                              pure receiverScriptHash
+                              pure $ pjust # receiverScriptHash

-                      pure $
-                        pif
-                          isAuthorityUTxO
-                          (pjust # handleAuthorityUTxO)
-                          pnothing
+                      pmatchC
+                        ( pcompareBy
+                            # pfromOrd
+                            # atAmount
+                            # 1
+                        )
+                        >>= \case
+                          -- atAmount == 1
+                          PEQ -> handleAuthorityUTxO
+                          -- atAmount < 1
+                          PLT -> pure pnothing
+                          -- atAmount > 1
+                          PGT -> pure $ ptraceError "More than one GAT in one UTxO"
                  )

              -- The sorted hashes of all the GAT receivers.
--- a/agora/Agora/Proposal/Scripts.hs
+++ b/agora/Agora/Proposal/Scripts.hs
@ -10,7 +10,7 @@ module Agora.Proposal.Scripts (
  proposalPolicy,
 ) where

-import Agora.Governor (PGovernorRedeemer (PCreateProposal))
+import Agora.Governor (PGovernorRedeemer (PCreateProposal), presolveGovernorRedeemer)
 import Agora.Proposal (
  PProposalDatum (PProposalDatum),
  PProposalRedeemer (PAdvanceProposal, PCosign, PUnlockStake, PVote),
@ -70,7 +70,6 @@ import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
 import Plutarch.Extra.ScriptContext (
  pfindTxInByTxOutRef,
  ptryFromOutputDatum,
-  ptryFromRedeemer,
 )
 import Plutarch.Extra.Sum (PSum (PSum))
 import Plutarch.Extra.Tagged (PTagged)
@ -82,7 +81,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
  ptryFromC,
 )
 import Plutarch.Extra.Traversable (pfoldMap)
-import Plutarch.Extra.Value (passetClassValueOfT, psymbolValueOf)
+import Plutarch.Extra.Value (psymbolValueOf')
 import Plutarch.Unsafe (punsafeCoerce)

 {- | Policy for Proposals.
@ -118,44 +117,25 @@ proposalPolicy =

    PMinting ((pfield @"_0" #) -> ownSymbol) <- pmatchC $ pfromData ctxF.purpose

-    let mintedProposalST =
-          psymbolValueOf
+    pguardC "Minted exactly one proposal ST"
+      $ pmatch
+        ( pfromJust
+            #$ psymbolValueOf'
            # ownSymbol
            # txInfoF.mint
+        )
+      $ \(PPair minted burnt) ->
+        minted
+          #== 1
+          #&& ptraceIfFalse "Burning a proposal is not supported" (burnt #== 0)

-    pguardC "Minted exactly one proposal ST" $
-      mintedProposalST #== 1
-
-    let governorInputRef =
+    let governorRedeemer =
          passertPJust
            # "GST should move"
-            #$ pfindJust
-            # plam
-              ( flip pletAll $ \inputF ->
-                  let value = pfield @"value" # inputF.resolved
-                      isGovernorInput =
-                        passetClassValueOfT
-                          # (ptoScottEncodingT # gstAssetClass)
-                          # value
-                          #== 1
-                   in pif
-                        isGovernorInput
-                        (pjust # inputF.outRef)
-                        pnothing
-              )
+            #$ presolveGovernorRedeemer
+            # (ptoScottEncodingT # gstAssetClass)
            # pfromData txInfoF.inputs
-
-        governorScriptPurpose =
-          mkRecordConstr
-            PSpending
-            (#_0 .= governorInputRef)
-
-        governorRedeemer =
-          pfromData $
-            pfromJust
-              #$ ptryFromRedeemer @(PAsData PGovernorRedeemer)
-              # governorScriptPurpose
-              # txInfoF.redeemers
+            # txInfoF.redeemers

    pguardC "Govenor redeemer correct" $
      pcon PCreateProposal #== governorRedeemer
--- a/agora/Agora/Stake/Scripts.hs
+++ b/agora/Agora/Stake/Scripts.hs
@ -207,7 +207,7 @@ stakePolicy =
                      passetClassValueOfT
                        # (ptoScottEncodingT # gtClass)
                        # outputF.value
-                        #== (pfromData datumF.stakedAmount)
+                        #== pfromData datumF.stakedAmount
                  , ptraceIfFalse "Stake Owner should sign the transaction" $
                      pauthorizedBy
                        # authorizationContext txInfoF