encode reference script hashes in effects

Also: - Change the validation logic to check the reference script in the GAT UTXO upon the minting of GAT - Make use of `PMonad`
2022-08-15 22:36:49 +08:00 · 2022-08-15 22:36:49 +08:00 · ce72202cfd
commit ce72202cfd
parent bd4eab6563
5 changed files with 107 additions and 37 deletions
--- a/agora/Agora/Governor/Scripts.hs
+++ b/agora/Agora/Governor/Scripts.hs
@ -28,6 +28,7 @@ import Agora.Governor (
 )
 import Agora.Proposal (
  PProposalDatum (..),
+  PProposalEffectGroup,
  ProposalStatus (Draft, Locked),
  phasNeutralEffect,
  pisEffectsVotesCompatible,
@ -36,7 +37,14 @@ import Agora.Proposal (
  pwinner,
 )
 import Agora.Proposal.Time (createProposalStartingTime)
-import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTSymbol, proposalSTSymbol, proposalValidatoHash, stakeSTSymbol)
+import Agora.Scripts (
+  AgoraScripts,
+  authorityTokenSymbol,
+  governorSTSymbol,
+  proposalSTSymbol,
+  proposalValidatoHash,
+  stakeSTSymbol,
+ )
 import Agora.Stake (
  PProposalLock (..),
  PStakeDatum (..),
@ -45,17 +53,17 @@ import Agora.Stake (
 import Agora.Utils (
  pfindDatum,
  pfromDatumHash,
+  pfstTuple,
  pmustFindDatum,
+  psndTuple,
  validatorHashToAddress,
 )
 import Plutarch.Api.V1 (
  PCurrencySymbol,
-  PMap,
-  PValidatorHash,
 )
+import Plutarch.Api.V1.AssocMap qualified as AssocMap
 import Plutarch.Api.V2 (
  PAddress,
-  PDatumHash,
  PMintingPolicy,
  PScriptPurpose (PMinting, PSpending),
  PTxOut,
@ -66,10 +74,9 @@ 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 (passertPJust, pfromJust, pnothing)
+import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pfromJust, pmaybeData, pnothing)
 import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
 import Plutarch.Extra.ScriptContext (
  pfindOutputsToAddress,
@ -489,35 +496,44 @@ governorValidator as =
          pguardC "Output GATs is more than minted GATs" $
            plength # outputsWithGAT #== gatCount

-          let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PTxOut :--> PBool)
-              gatOutputValidator' =
+          let validateGATOutput' :: Term s (PProposalEffectGroup :--> PTxOut :--> PBool)
+              validateGATOutput' =
                phoistAcyclic $
                  plam
-                    ( \effects output' -> unTermCont $ do
-                        output <- pletFieldsC @'["address", "datum"] output'
+                    ( \effects output -> unTermCont $ do
+                        outputF <- pletFieldsC @'["address", "datum", "referenceScript"] output

-                        let scriptHash =
-                              passertPJust # "GAT receiver is not a script"
-                                #$ pscriptHashFromAddress # output.address
-                            datumHash =
-                              ptrace
-                                "Output to effect should have datum"
-                                pfromDatumHash
-                                # output.datum
-
-                            expectedDatumHash =
-                              passertPJust # "Receiver is not in the effect list"
-                                #$ plookup # scriptHash # effects
+                        let receiverScriptHash =
+                              passertPJust # "GAT receiver should be a script"
+                                #$ pscriptHashFromAddress # outputF.address
+                            effect =
+                              passertPJust # "Receiver should be in the effect group"
+                                #$ AssocMap.plookup # receiverScriptHash # effects
+                            hasCorrectReferenceScript =
+                              pmaybeData
+                                # pconstant True
+                                # plam
+                                  ( ( passertPDJust
+                                        # "Output UTXO should have a reference script"
+                                        # outputF.referenceScript
+                                        #==
+                                    )
+                                      . pfromData
+                                  )
+                                # (psndTuple # effect)
+                            hasCorrectDatum =
+                              pfstTuple # effect #== pfromDatumHash # outputF.datum

                        pure $
                          foldr1
                            (#&&)
-                            [ ptraceIfFalse "GAT must be tagged by the effect hash" $ authorityTokensValidIn # patSymbol # output'
-                            , ptraceIfFalse "Unexpected datum" $ datumHash #== expectedDatumHash
+                            [ ptraceIfFalse "GAT valid" $ authorityTokensValidIn # patSymbol # output
+                            , ptraceIfFalse "Correct datum" hasCorrectDatum
+                            , ptraceIfFalse "Reference script correct" hasCorrectReferenceScript
                            ]
                    )

-              gatOutputValidator = gatOutputValidator' # effectGroup
+              validateGATOutput = validateGATOutput' # effectGroup

          pguardC "GATs valid" $
            pfoldr
@ -526,7 +542,7 @@ governorValidator as =
                    let value = pfield @"value" # txOut
                        atValue = psymbolValueOf # patSymbol # value
                     in pif (atValue #== 0) r $
-                          pif (atValue #== 1) (r #&& gatOutputValidator # txOut) $ pconstant False
+                          pif (atValue #== 1) (r #&& validateGATOutput # txOut) $ pconstant False
                )
              # pconstant True
              # pfromData txInfoF.outputs
--- a/agora/Agora/Plutarch/Orphans.hs
+++ b/agora/Agora/Plutarch/Orphans.hs
@ -7,7 +7,7 @@

 module Agora.Plutarch.Orphans () where

-import Plutarch.Api.V1 (PDatumHash (..))
+import Plutarch.Api.V2 (PDatumHash (..), PScriptHash (..))
 import Plutarch.Builtin (PIsData (..))
 import Plutarch.Extra.TermCont (ptryFromC)
 import Plutarch.TryFrom (PTryFrom (..))
@ -37,3 +37,18 @@ instance PTryFrom PData (PAsData PUnit)
 instance (PIsData a) => PIsData (PAsData a) where
  pfromDataImpl = punsafeCoerce
  pdataImpl = pdataImpl . pfromData
+
+-- | @since 1.0.0
+instance PTryFrom PData (PAsData PScriptHash) where
+  type PTryFromExcess PData (PAsData PScriptHash) = Flip Term PScriptHash
+  ptryFrom' opq = runTermCont $ do
+    (pfromData -> unwrapped, _) <- ptryFromC @(PAsData PByteString) opq
+
+    tcont $ \f ->
+      pif
+        -- Blake2b_224 hash: 224 bits/28 bytes.
+        (plengthBS # unwrapped #== 28)
+        (f ())
+        (ptraceError "ptryFrom(PScriptHash): must be 32 bytes long")
+
+    pure (punsafeCoerce opq, pcon $ PScriptHash unwrapped)
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@ -11,6 +11,7 @@ module Agora.Proposal (
  -- * Haskell-land

  -- Proposal (..),
+  ProposalEffectGroup,
  ProposalDatum (..),
  ProposalRedeemer (..),
  ProposalStatus (..),
@ -21,6 +22,7 @@ module Agora.Proposal (
  emptyVotesFor,

  -- * Plutarch-land
+  PProposalEffectGroup,
  PProposalDatum (..),
  PProposalRedeemer (..),
  PProposalStatus (..),
@ -41,7 +43,12 @@ module Agora.Proposal (
 ) where

 import Agora.Plutarch.Orphans ()
-import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
+import Agora.Proposal.Time (
+  PProposalStartingTime,
+  PProposalTimingConfig,
+  ProposalStartingTime,
+  ProposalTimingConfig,
+ )
 import Agora.SafeMoney (GTTag)
 import Data.Tagged (Tagged)
 import Generics.SOP qualified as SOP
@ -50,7 +57,10 @@ import Plutarch.Api.V1.AssocMap qualified as PAssocMap
 import Plutarch.Api.V2 (
  KeyGuarantees (Unsorted),
  PDatumHash,
+  PMaybeData,
  PPubKeyHash,
+  PScriptHash,
+  PTuple,
 )
 import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields)
 import Plutarch.Extra.Comonad (pextract)
@ -75,7 +85,7 @@ import Plutarch.Lift (
 )
 import Plutarch.SafeMoney (PDiscrete (..))
 import Plutarch.Show (PShow (..))
-import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
+import PlutusLedgerApi.V2 (DatumHash, PubKeyHash, ScriptHash, ValidatorHash)
 import PlutusTx qualified
 import PlutusTx.AssocMap qualified as AssocMap

@ -272,6 +282,9 @@ newtype ProposalVotes = ProposalVotes
 emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
 emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)

+-- | @since 0.3.0
+type ProposalEffectGroup = AssocMap.Map ValidatorHash (DatumHash, Maybe ScriptHash)
+
 {- | Haskell-level datum for Proposal scripts.

     @since 0.1.0
@ -282,7 +295,7 @@ data ProposalDatum = ProposalDatum
  -- TODO: could we encode this more efficiently?
  -- This is shaped this way for future proofing.
  -- See https://github.com/Liqwid-Labs/agora/issues/39
-  , effects :: AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
+  , effects :: AssocMap.Map ResultTag ProposalEffectGroup
  -- ^ Effect lookup table. First by result, then by effect hash.
  , status :: ProposalStatus
  -- ^ The status the proposal is in.
@ -583,6 +596,15 @@ deriving via
  instance
    (PConstantDecl ProposalVotes)

+type PProposalEffectGroup =
+  PMap
+    'Unsorted
+    PValidatorHash
+    ( PTuple
+        PDatumHash
+        (PMaybeData (PAsData PScriptHash))
+    )
+
 {- | Plutarch-level version of 'ProposalDatum'.

     @since 0.1.0
@ -593,7 +615,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
        s
        ( PDataRecord
            '[ "proposalId" ':= PProposalId
-             , "effects" ':= PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+             , "effects" ':= PMap 'Unsorted PResultTag PProposalEffectGroup
             , "status" ':= PProposalStatus
             , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
             , "thresholds" ':= PProposalThresholds
@ -678,7 +700,7 @@ phasNeutralEffect ::
  forall (s :: S).
  Term
    s
-    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+    ( PMap 'Unsorted PResultTag PProposalEffectGroup
        :--> PBool
    )
 phasNeutralEffect = phoistAcyclic $ PAssocMap.pany # PAssocMap.pnull
@ -691,7 +713,7 @@ pisEffectsVotesCompatible ::
  forall (s :: S).
  Term
    s
-    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+    ( PMap 'Unsorted PResultTag PProposalEffectGroup
        :--> PProposalVotes
        :--> PBool
    )
@ -811,7 +833,7 @@ phighestVotes = phoistAcyclic $
 pneutralOption ::
  Term
    s
-    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+    ( PMap 'Unsorted PResultTag PProposalEffectGroup
        :--> PResultTag
    )
 pneutralOption = phoistAcyclic $
--- a/agora/Agora/Proposal/Time.hs
+++ b/agora/Agora/Proposal/Time.hs
@ -44,8 +44,9 @@ import Plutarch.DataRepr (
  PDataFields,
 )
 import Plutarch.Extra.Applicative (PApply (pliftA2))
+import Plutarch.Extra.Bind ((#>>=))
 import Plutarch.Extra.Field (pletAll, pletAllC)
-import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
+import Plutarch.Extra.Maybe (pjust, pnothing)
 import Plutarch.Extra.TermCont (pmatchC)
 import Plutarch.Lift (
  DerivePConstantViaNewtype (..),
@ -357,8 +358,7 @@ createProposalStartingTime = phoistAcyclic $
                      "createProposalStartingTime: given time range should be tight enough"
                      pnothing
                  )
-     in -- TODO: PMonad when?
-        pmaybe # pnothing # f # ct
+     in ct #>>= f

 {- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.

--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@ -24,6 +24,8 @@ module Agora.Utils (
  pfromDatumHash,
  pfromInlineDatum,
  ptryFindDatum,
+  pfstTuple,
+  psndTuple,
 ) where

 import Plutarch.Api.V1.AssocMap (KeyGuarantees (Unsorted), PMap)
@ -32,6 +34,7 @@ import Plutarch.Api.V2 (
  PDatum,
  PDatumHash,
  POutputDatum (..),
+  PTuple,
 )
 import Plutarch.Extra.Functor (pfmap)
 import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
@ -235,3 +238,17 @@ infixr 8 #.**
  Term s c ->
  Term s e
 (#.**) f g x y z = f #$ g # x # y # z
+
+{- | Extract the first component of a 'PTuple'.
+
+     @since 1.0.0
+-}
+pfstTuple :: forall a b s. (PIsData a) => Term s (PTuple a b :--> a)
+pfstTuple = phoistAcyclic $ plam $ pfromData . (pfield @"_0" #)
+
+{- | Extract the second component of a 'PTuple'.
+
+     @since 1.0.0
+-}
+psndTuple :: forall b a s. (PIsData b) => Term s (PTuple a b :--> b)
+psndTuple = phoistAcyclic $ plam $ pfromData . (pfield @"_1" #)