Sulkta-OSS/agora
3
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

encode reference script hashes in effects

Browse source 
Also:

- Change the validation logic to check the reference script in the GAT UTXO upon the minting of GAT
- Make use of `PMonad`
This commit is contained in:
Hongrui Fang 2022-08-15 22:36:49 +08:00
parent 67517bc81f
commit e5385c3021
5 changed files with 107 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

68
agora/Agora/Governor/Scripts.hs
View file

@ -28,6 +28,7 @@ import Agora.Governor (
) )
import Agora.Proposal ( import Agora.Proposal (
PProposalDatum (..), PProposalDatum (..),
PProposalEffectGroup,
ProposalStatus (Draft, Locked), ProposalStatus (Draft, Locked),
phasNeutralEffect, phasNeutralEffect,
pisEffectsVotesCompatible, pisEffectsVotesCompatible,
@ -36,7 +37,14 @@ import Agora.Proposal (
pwinner, pwinner,
) )
import Agora.Proposal.Time (createProposalStartingTime) 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 ( import Agora.Stake (
PProposalLock (..), PProposalLock (..),
PStakeDatum (..), PStakeDatum (..),
@ -45,17 +53,17 @@ import Agora.Stake (
import Agora.Utils ( import Agora.Utils (
pfindDatum, pfindDatum,
pfromDatumHash, pfromDatumHash,
pfstTuple,
pmustFindDatum, pmustFindDatum,
psndTuple,
validatorHashToAddress, validatorHashToAddress,
) )
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PCurrencySymbol, PCurrencySymbol,
PMap,
PValidatorHash,
) )
import Plutarch.Api.V1.AssocMap qualified as AssocMap
import Plutarch.Api.V2 ( import Plutarch.Api.V2 (
PAddress, PAddress,
PDatumHash,
PMintingPolicy, PMintingPolicy,
PScriptPurpose (PMinting, PSpending), PScriptPurpose (PMinting, PSpending),
PTxOut, PTxOut,
@ -66,10 +74,9 @@ import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.IsData (pmatchEnumFromData) import Plutarch.Extra.IsData (pmatchEnumFromData)
import Plutarch.Extra.List (pfirstJust) import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Map ( import Plutarch.Extra.Map (
plookup,
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.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.ScriptContext ( import Plutarch.Extra.ScriptContext (
pfindOutputsToAddress, pfindOutputsToAddress,
@ -489,35 +496,44 @@ governorValidator as =
pguardC "Output GATs is more than minted GATs" $ pguardC "Output GATs is more than minted GATs" $
plength # outputsWithGAT #== gatCount plength # outputsWithGAT #== gatCount
let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PTxOut :--> PBool) let validateGATOutput' :: Term s (PProposalEffectGroup :--> PTxOut :--> PBool)
gatOutputValidator' = validateGATOutput' =
phoistAcyclic $ phoistAcyclic $
plam plam
( \effects output' -> unTermCont $ do ( \effects output -> unTermCont $ do
output <- pletFieldsC @'["address", "datum"] output' outputF <- pletFieldsC @'["address", "datum", "referenceScript"] output
let scriptHash = let receiverScriptHash =
passertPJust # "GAT receiver is not a script" passertPJust # "GAT receiver should be a script"
#$ pscriptHashFromAddress # output.address #$ pscriptHashFromAddress # outputF.address
datumHash = effect =
ptrace passertPJust # "Receiver should be in the effect group"
"Output to effect should have datum" #$ AssocMap.plookup # receiverScriptHash # effects
pfromDatumHash hasCorrectReferenceScript =
# output.datum pmaybeData
# pconstant True
expectedDatumHash = # plam
passertPJust # "Receiver is not in the effect list" ( ( passertPDJust
#$ plookup # scriptHash # effects # "Output UTXO should have a reference script"
# outputF.referenceScript
#==
)
. pfromData
)
# (psndTuple # effect)
hasCorrectDatum =
pfstTuple # effect #== pfromDatumHash # outputF.datum
pure $ pure $
foldr1 foldr1
(#&&) (#&&)
[ ptraceIfFalse "GAT must be tagged by the effect hash" $ authorityTokensValidIn # patSymbol # output' [ ptraceIfFalse "GAT valid" $ authorityTokensValidIn # patSymbol # output
, ptraceIfFalse "Unexpected datum" $ datumHash #== expectedDatumHash , ptraceIfFalse "Correct datum" hasCorrectDatum
, ptraceIfFalse "Reference script correct" hasCorrectReferenceScript
] ]
) )
gatOutputValidator = gatOutputValidator' # effectGroup validateGATOutput = validateGATOutput' # effectGroup
pguardC "GATs valid" $ pguardC "GATs valid" $
pfoldr pfoldr
@ -526,7 +542,7 @@ governorValidator as =
let value = pfield @"value" # txOut let value = pfield @"value" # txOut
atValue = psymbolValueOf # patSymbol # value atValue = psymbolValueOf # patSymbol # value
in pif (atValue #== 0) r $ in pif (atValue #== 0) r $
pif (atValue #== 1) (r #&& gatOutputValidator # txOut) $ pconstant False pif (atValue #== 1) (r #&& validateGATOutput # txOut) $ pconstant False
) )
# pconstant True # pconstant True
# pfromData txInfoF.outputs # pfromData txInfoF.outputs

17
agora/Agora/Plutarch/Orphans.hs
View file

@ -7,7 +7,7 @@
module Agora.Plutarch.Orphans () where module Agora.Plutarch.Orphans () where
import Plutarch.Api.V1 (PDatumHash (..)) import Plutarch.Api.V2 (PDatumHash (..), PScriptHash (..))
import Plutarch.Builtin (PIsData (..)) import Plutarch.Builtin (PIsData (..))
import Plutarch.Extra.TermCont (ptryFromC) import Plutarch.Extra.TermCont (ptryFromC)
import Plutarch.TryFrom (PTryFrom (..)) import Plutarch.TryFrom (PTryFrom (..))
@ -37,3 +37,18 @@ instance PTryFrom PData (PAsData PUnit)
instance (PIsData a) => PIsData (PAsData a) where instance (PIsData a) => PIsData (PAsData a) where
pfromDataImpl = punsafeCoerce pfromDataImpl = punsafeCoerce
pdataImpl = pdataImpl . pfromData 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)

36
agora/Agora/Proposal.hs
View file

@ -11,6 +11,7 @@ module Agora.Proposal (
-- * Haskell-land -- * Haskell-land
-- Proposal (..), -- Proposal (..),
ProposalEffectGroup,
ProposalDatum (..), ProposalDatum (..),
ProposalRedeemer (..), ProposalRedeemer (..),
ProposalStatus (..), ProposalStatus (..),
@ -21,6 +22,7 @@ module Agora.Proposal (
emptyVotesFor, emptyVotesFor,
-- * Plutarch-land -- * Plutarch-land
PProposalEffectGroup,
PProposalDatum (..), PProposalDatum (..),
PProposalRedeemer (..), PProposalRedeemer (..),
PProposalStatus (..), PProposalStatus (..),
@ -41,7 +43,12 @@ module Agora.Proposal (
) where ) where
import Agora.Plutarch.Orphans () 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 Agora.SafeMoney (GTTag)
import Data.Tagged (Tagged) import Data.Tagged (Tagged)
import Generics.SOP qualified as SOP import Generics.SOP qualified as SOP
@ -50,7 +57,10 @@ import Plutarch.Api.V1.AssocMap qualified as PAssocMap
import Plutarch.Api.V2 ( import Plutarch.Api.V2 (
KeyGuarantees (Unsorted), KeyGuarantees (Unsorted),
PDatumHash, PDatumHash,
PMaybeData,
PPubKeyHash, PPubKeyHash,
PScriptHash,
PTuple,
) )
import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields) import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields)
import Plutarch.Extra.Comonad (pextract) import Plutarch.Extra.Comonad (pextract)
@ -75,7 +85,7 @@ import Plutarch.Lift (
) )
import Plutarch.SafeMoney (PDiscrete (..)) import Plutarch.SafeMoney (PDiscrete (..))
import Plutarch.Show (PShow (..)) import Plutarch.Show (PShow (..))
import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash) import PlutusLedgerApi.V2 (DatumHash, PubKeyHash, ScriptHash, ValidatorHash)
import PlutusTx qualified import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
@ -272,6 +282,9 @@ newtype ProposalVotes = ProposalVotes
emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0) 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. {- | Haskell-level datum for Proposal scripts.
@since 0.1.0 @since 0.1.0
@ -282,7 +295,7 @@ data ProposalDatum = ProposalDatum
-- TODO: could we encode this more efficiently? -- TODO: could we encode this more efficiently?
-- This is shaped this way for future proofing. -- This is shaped this way for future proofing.
-- See https://github.com/Liqwid-Labs/agora/issues/39 -- 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. -- ^ Effect lookup table. First by result, then by effect hash.
, status :: ProposalStatus , status :: ProposalStatus
-- ^ The status the proposal is in. -- ^ The status the proposal is in.
@ -583,6 +596,15 @@ deriving via
instance instance
(PConstantDecl ProposalVotes) (PConstantDecl ProposalVotes)
type PProposalEffectGroup =
PMap
'Unsorted
PValidatorHash
( PTuple
PDatumHash
(PMaybeData (PAsData PScriptHash))
)
{- | Plutarch-level version of 'ProposalDatum'. {- | Plutarch-level version of 'ProposalDatum'.
@since 0.1.0 @since 0.1.0
@ -593,7 +615,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
s s
( PDataRecord ( PDataRecord
'[ "proposalId" ':= PProposalId '[ "proposalId" ':= PProposalId
, "effects" ':= PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash) , "effects" ':= PMap 'Unsorted PResultTag PProposalEffectGroup
, "status" ':= PProposalStatus , "status" ':= PProposalStatus
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash) , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
, "thresholds" ':= PProposalThresholds , "thresholds" ':= PProposalThresholds
@ -678,7 +700,7 @@ phasNeutralEffect ::
forall (s :: S). forall (s :: S).
Term Term
s s
( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash) ( PMap 'Unsorted PResultTag PProposalEffectGroup
:--> PBool :--> PBool
) )
phasNeutralEffect = phoistAcyclic $ PAssocMap.pany # PAssocMap.pnull phasNeutralEffect = phoistAcyclic $ PAssocMap.pany # PAssocMap.pnull
@ -691,7 +713,7 @@ pisEffectsVotesCompatible ::
forall (s :: S). forall (s :: S).
Term Term
s s
( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash) ( PMap 'Unsorted PResultTag PProposalEffectGroup
:--> PProposalVotes :--> PProposalVotes
:--> PBool :--> PBool
) )
@ -811,7 +833,7 @@ phighestVotes = phoistAcyclic $
pneutralOption :: pneutralOption ::
Term Term
s s
( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash) ( PMap 'Unsorted PResultTag PProposalEffectGroup
:--> PResultTag :--> PResultTag
) )
pneutralOption = phoistAcyclic $ pneutralOption = phoistAcyclic $

6
agora/Agora/Proposal/Time.hs
View file

@ -44,8 +44,9 @@ import Plutarch.DataRepr (
PDataFields, PDataFields,
) )
import Plutarch.Extra.Applicative (PApply (pliftA2)) import Plutarch.Extra.Applicative (PApply (pliftA2))
import Plutarch.Extra.Bind ((#>>=))
import Plutarch.Extra.Field (pletAll, pletAllC) 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.Extra.TermCont (pmatchC)
import Plutarch.Lift ( import Plutarch.Lift (
DerivePConstantViaNewtype (..), DerivePConstantViaNewtype (..),
@ -357,8 +358,7 @@ createProposalStartingTime = phoistAcyclic $
"createProposalStartingTime: given time range should be tight enough" "createProposalStartingTime: given time range should be tight enough"
pnothing pnothing
) )
in -- TODO: PMonad when? in ct #>>= f
pmaybe # pnothing # f # ct
{- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field. {- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.

17
agora/Agora/Utils.hs
View file

@ -24,6 +24,8 @@ module Agora.Utils (
pfromDatumHash, pfromDatumHash,
pfromInlineDatum, pfromInlineDatum,
ptryFindDatum, ptryFindDatum,
pfstTuple,
psndTuple,
) where ) where
import Plutarch.Api.V1.AssocMap (KeyGuarantees (Unsorted), PMap) import Plutarch.Api.V1.AssocMap (KeyGuarantees (Unsorted), PMap)
@ -32,6 +34,7 @@ import Plutarch.Api.V2 (
PDatum, PDatum,
PDatumHash, PDatumHash,
POutputDatum (..), POutputDatum (..),
PTuple,
) )
import Plutarch.Extra.Functor (pfmap) import Plutarch.Extra.Functor (pfmap)
import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing) import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
@ -235,3 +238,17 @@ infixr 8 #.**
Term s c -> Term s c ->
Term s e Term s e
(#.**) f g x y z = f #$ g # x # y # z (#.**) 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" #)