simplify the governor mutation effect

agora/Agora/Effect/GovernorMutation.hs

@@ -21,13 +21,15 @@ module Agora.Effect.GovernorMutation (
 import Agora.Effect (makeEffect)
 import Agora.Governor (
   GovernorDatum,
+  GovernorRedeemer (MutateGovernor),
   PGovernorDatum,
-  pisGovernorDatumValid,
+  PGovernorRedeemer,
  )
 import Agora.Plutarch.Orphans ()
-import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTAssetClass)
+import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTSymbol, governorValidatorHash)
-import Plutarch.Api.V1 (PValue)
+import Agora.Utils (pfromSingleton, ptryFromRedeemer)
 import Plutarch.Api.V2 (
+  PScriptPurpose (PSpending),
   PTxOutRef,
   PValidator,
  )
@@ -35,15 +37,14 @@ import Plutarch.DataRepr (
   DerivePConstantViaData (DerivePConstantViaData),
   PDataFields,
  )
-import Plutarch.Extra.Maybe (
+import Plutarch.Extra.Field (pletAll, pletAllC)
-  passertPJust,
+import Plutarch.Extra.Maybe (passertPJust, pdnothing)
- )
+import Plutarch.Extra.Record (mkRecordConstr, (.=))
-import Plutarch.Extra.ScriptContext (pfromOutputDatum, pisScriptAddress)
+import Plutarch.Extra.ScriptContext (paddressFromValidatorHash, pfromOutputDatum, pisScriptAddress)
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletFieldsC)
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC)
-import Plutarch.Extra.Value (pvalueOf)
+import Plutarch.Extra.Value (psymbolValueOf)
 import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
 import PlutusLedgerApi.V1 (TxOutRef)
-import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
 import PlutusTx qualified
 
 --------------------------------------------------------------------------------
@@ -102,10 +103,14 @@ instance DerivePlutusType PMutateGovernorDatum where
   type DPTStrat _ = PlutusTypeData
 
 -- | @since 0.1.0
-instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernorDatum = MutateGovernorDatum
+instance PUnsafeLiftDecl PMutateGovernorDatum where
+  type PLifted PMutateGovernorDatum = MutateGovernorDatum
 
 -- | @since 0.1.0
-deriving via (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum) instance (PConstantDecl MutateGovernorDatum)
+deriving via
+  (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum)
+  instance
+    (PConstantDecl MutateGovernorDatum)
 
 -- | @since 0.1.0
 deriving anyclass instance PTryFrom PData PMutateGovernorDatum
@@ -142,74 +147,78 @@ mutateGovernorValidator ::
   AgoraScripts ->
   ClosedTerm PValidator
 mutateGovernorValidator as = makeEffect (authorityTokenSymbol as) $
-  \_gatCs (datum :: Term _ PMutateGovernorDatum) _ txInfo -> unTermCont $ do
+  \_gatCs (effectDatum :: Term _ PMutateGovernorDatum) _ txInfo -> unTermCont $ do
-    datumF <- pletFieldsC @'["newDatum", "governorRef"] datum
+    effectDatumF <- pletAllC effectDatum
-    txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums"] txInfo
+    txInfoF <- pletFieldsC @'["inputs", "outputs", "datums", "redeemers"] txInfo
 
-    let mint :: Term _ (PBuiltinList _)
+    ----------------------------------------------------------------------------
-        mint = pto $ pto $ pto $ pfromData txInfoF.mint
 
-    pguardC "Nothing should be minted/burnt other than GAT" $
+    scriptInputs <-
-      plength # mint #== 1
+      pletC $
+        pfilter
+          # plam
+            ( \inInfo ->
+                pisScriptAddress
+                  #$ pfield @"address"
+                  #$ pfield @"resolved" # inInfo
+            )
+          # pfromData txInfoF.inputs
 
-    -- Only two script inputs are alloed: one from the effect, one from the governor.
+    -- Only two script inputs are alloed: one from the effect script, another from the governor.
     pguardC "Only self and governor script inputs are allowed" $
-      pfoldr
+      plength # scriptInputs #== 2
-        # phoistAcyclic
+
-          ( plam $ \inInfo count ->
+    pguardC "Governor input should present" $
-              let address = pfield @"address" #$ pfield @"resolved" # inInfo
+      pany
-               in pif
+        # plam
-                    (pisScriptAddress # address)
+          ( flip pletAll $ \inputF ->
-                    (count + 1)
+              let gstSymbol = pconstant $ governorSTSymbol as
-                    count
+                  governorAddress =
+                    paddressFromValidatorHash
+                      # pconstant (governorValidatorHash as)
+                      # pdnothing
+
+                  isGovernorInput =
+                    foldl1
+                      (#&&)
+                      [ ptraceIfFalse "Can only modify the pinned governor" $
+                          inputF.outRef #== effectDatumF.governorRef
+                      , ptraceIfFalse "Governor UTxO should carry GST" $
+                          psymbolValueOf
+                            # gstSymbol
+                            # (pfield @"value" # inputF.resolved)
+                            #== 1
+                      , ptraceIfFalse "Governor validator run" $
+                          pfield @"address" # inputF.resolved
+                            #== governorAddress
+                      ]
+               in isGovernorInput
           )
-        # (0 :: Term _ PInteger)
+        # scriptInputs
-        # pfromData txInfoF.inputs
-        #== 2
 
-    -- Find the governor input by looking for GST.
+    let governorRedeemer =
-    let inputWithGST =
+          pfromData $
-          passertPJust # "Governor input not found" #$ pfind
+            passertPJust # "Govenor redeemer should be resolved"
-            # phoistAcyclic
+              #$ ptryFromRedeemer @(PAsData PGovernorRedeemer)
-              ( plam $ \inInfo ->
+                # mkRecordConstr PSpending (#_0 .= effectDatumF.governorRef)
-                  let value = pfield @"value" #$ pfield @"resolved" # inInfo
+                # txInfoF.redeemers
-                   in gstValueOf # value #== 1
-              )
-            # pfromData txInfoF.inputs
 
-    govInInfo <- pletFieldsC @'["outRef", "resolved"] $ inputWithGST
+    pguardC "Spend governor with redeemer MutateGovernor" $
+      governorRedeemer #== pconstant MutateGovernor
 
-    -- The effect can only modify the governor UTXO referenced in the datum.
+    ----------------------------------------------------------------------------
-    pguardC "Can only modify the pinned governor" $
-      govInInfo.outRef #== datumF.governorRef
 
-    -- The transaction can only have one output, which should be sent to the governor.
+    let governorOutput =
-    pguardC "Only governor output is allowed" $
+          ptrace "Only governor output is allowed" $
-      plength # pfromData txInfoF.outputs #== 1
+            pfromSingleton # pfromData txInfoF.outputs
 
-    let govAddress = pfield @"address" #$ govInInfo.resolved
+        governorOutputDatum =
-        govOutput' = phead # pfromData txInfoF.outputs
+          ptrace "Resolve governor outoput datum" $
+            pfromOutputDatum @PGovernorDatum
+              # (pfield @"datum" # governorOutput)
+              # txInfoF.datums
 
-    govOutput <- pletFieldsC @'["address", "value", "datum"] govOutput'
+    pguardC "New governor datum correct" $
-
+      governorOutputDatum #== effectDatumF.newDatum
-    pguardC "No output to the governor" $
-      govOutput.address #== govAddress
-
-    pguardC "Governor output doesn't carry the GST" $
-      gstValueOf # govOutput.value #== 1
-
-    let governorOutputDatum =
-          ptrace "Governor output datum not found" $
-            pfromOutputDatum @PGovernorDatum # govOutput.datum # txInfoF.datums
-
-    -- Ensure the output governor datum is what we want.
-    pguardC "Unexpected governor datum" $ datumF.newDatum #== governorOutputDatum
-    pguardC "New governor datum should be valid" $ pisGovernorDatumValid # governorOutputDatum
 
     return $ popaque $ pconstant ()
-  where
-    -- Get the amount of GST in the a given value.
-    gstValueOf :: Term s (PValue _ _ :--> PInteger)
-    gstValueOf = phoistAcyclic $ plam $ \v -> pvalueOf # v # pconstant cs # pconstant tn
-      where
-        AssetClass (cs, tn) = governorSTAssetClass as

agora/Agora/Utils.hs

@@ -31,13 +31,15 @@ module Agora.Utils (
   ppureIf,
   pltBy,
   pinsertUniqueBy,
+  ptryFromRedeemer,
 ) where
 
-import Plutarch.Api.V1 (PPOSIXTime, PTokenName, PValidatorHash)
+import Plutarch.Api.V1 (KeyGuarantees (Unsorted), PPOSIXTime, PRedeemer, PTokenName, PValidatorHash)
-import Plutarch.Api.V2 (PScriptHash)
+import Plutarch.Api.V1.AssocMap (PMap, plookup)
+import Plutarch.Api.V2 (PScriptHash, PScriptPurpose)
 import Plutarch.Extra.Applicative (PApplicative (ppure))
 import Plutarch.Extra.Category (PCategory (pidentity))
-import Plutarch.Extra.Functor (PFunctor (PSubcategory))
+import Plutarch.Extra.Functor (PFunctor (PSubcategory, pfmap))
 import Plutarch.Extra.Maybe (pnothing)
 import Plutarch.Extra.Ord (PComparator, POrdering (PLT), pcompareBy, pequateBy)
 import Plutarch.Extra.Time (PCurrentTime (PCurrentTime))
@@ -369,3 +371,19 @@ pinsertUniqueBy = phoistAcyclic $
                in ensureUniqueness next
           )
           (const $ psingleton # x)
+
+-- | @since 1.0.0
+ptryFromRedeemer ::
+  forall (r :: PType) (s :: S).
+  (PTryFrom PData r) =>
+  Term
+    s
+    ( PScriptPurpose
+        :--> PMap 'Unsorted PScriptPurpose PRedeemer
+        :--> PMaybe r
+    )
+ptryFromRedeemer = phoistAcyclic $
+  plam $ \p m ->
+    pfmap
+      # plam (flip ptryFrom fst . pto)
+      # (plookup # p # m)