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

Merge pull request #62 from Liqwid-Labs/connor/mutate-governor

Browse source 
Mutate Governor Settings Effect Implementation
This commit is contained in:
方泓睿 2022-05-24 12:41:25 +08:00 • committed by GitHub
commit 9dff9bbf57
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
10 changed files with 488 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

174
agora-sample/Sample/Effect/GovernorMutation.hs Normal file
View file

@ -0,0 +1,174 @@
module Sample.Effect.GovernorMutation (
mkEffectTxInfo,
effectValidator,
effectValidatorAddress,
effectValidatorHash,
atAssetClass,
govRef,
effectRef,
invalidNewGovernorDatum,
validNewGovernorDatum,
mkEffectDatum,
) where
import Agora.Effect.GovernorMutation (
MutateGovernorDatum (..),
mutateGovernorValidator,
)
import Agora.Governor (GovernorDatum (..))
import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
import Plutarch.Api.V1 (mkValidator, validatorHash)
import Plutarch.SafeMoney (Tagged (Tagged))
import Plutus.V1.Ledger.Address (scriptHashAddress)
import Plutus.V1.Ledger.Api (
Address,
Datum (..),
ToData (..),
TokenName (..),
TxInInfo (..),
TxInfo (..),
TxOut (..),
TxOutRef (TxOutRef),
Validator,
ValidatorHash (..),
)
import Plutus.V1.Ledger.Api qualified as Interval
import Plutus.V1.Ledger.Value (AssetClass, assetClass)
import Plutus.V1.Ledger.Value qualified as Value
import Sample.Shared (
authorityTokenSymbol,
defaultProposalThresholds,
govAssetClass,
govValidatorAddress,
governor,
minAda,
signer,
)
import Test.Util (datumPair, toDatumHash)
-- | The effect validator instance.
effectValidator :: Validator
effectValidator = mkValidator $ mutateGovernorValidator governor
-- | The hash of the validator instance.
effectValidatorHash :: ValidatorHash
effectValidatorHash = validatorHash effectValidator
-- | The address of the validator.
effectValidatorAddress :: Address
effectValidatorAddress = scriptHashAddress effectValidatorHash
-- | The assetclass of the authority token.
atAssetClass :: AssetClass
atAssetClass = assetClass authorityTokenSymbol tokenName
where
-- TODO: use 'validatorHashToTokenName'
ValidatorHash bs = effectValidatorHash
tokenName = TokenName bs
-- | The mock reference of the governor state UTXO.
govRef :: TxOutRef
govRef = TxOutRef "614481d2159bfb72350222d61fce17e548e0fc00e5a1f841ff1837c431346ce7" 1
-- | The mock reference of the effect UTXO.
effectRef :: TxOutRef
effectRef = TxOutRef "c31164dc11835de7eb6187f67d0e1a19c1dfc0786a456923eef5043189cdb578" 1
-- | The input effect datum in 'mkEffectTransaction'.
mkEffectDatum :: GovernorDatum -> MutateGovernorDatum
mkEffectDatum newGovDatum =
MutateGovernorDatum
{ governorRef = govRef
, newDatum = newGovDatum
}
{- | Given the new governor state, create an effect to update the governor's state.
Note that the transaction is valid only if the given new datum is valid.
-}
mkEffectTxInfo :: GovernorDatum -> TxInfo
mkEffectTxInfo newGovDatum =
let gst = Value.assetClassValue govAssetClass 1
at = Value.assetClassValue atAssetClass 1
-- One authority token is burnt in the process.
burnt = Value.assetClassValue atAssetClass (-1)
--
governorInputDatum' :: GovernorDatum
governorInputDatum' =
GovernorDatum
{ proposalThresholds = defaultProposalThresholds
, nextProposalId = ProposalId 0
}
governorInputDatum :: Datum
governorInputDatum = Datum $ toBuiltinData governorInputDatum'
governorInput :: TxOut
governorInput =
TxOut
{ txOutAddress = govValidatorAddress
, txOutValue = gst
, txOutDatumHash = Just $ toDatumHash governorInputDatum
}
--
-- The effect should update 'nextProposalId'
effectInputDatum' :: MutateGovernorDatum
effectInputDatum' = mkEffectDatum newGovDatum
effectInputDatum :: Datum
effectInputDatum = Datum $ toBuiltinData effectInputDatum'
effectInput :: TxOut
effectInput =
TxOut
{ txOutAddress = effectValidatorAddress
, txOutValue = at -- The effect carry an authotity token.
, txOutDatumHash = Just $ toDatumHash effectInputDatum
}
--
governorOutputDatum' :: GovernorDatum
governorOutputDatum' = effectInputDatum'.newDatum
governorOutputDatum :: Datum
governorOutputDatum = Datum $ toBuiltinData governorOutputDatum'
governorOutput :: TxOut
governorOutput =
TxOut
{ txOutAddress = govValidatorAddress
, txOutValue = mconcat [gst, minAda]
, txOutDatumHash = Just $ toDatumHash governorOutputDatum
}
in TxInfo
{ txInfoInputs =
[ TxInInfo effectRef effectInput
, TxInInfo govRef governorInput
]
, txInfoOutputs = [governorOutput]
, txInfoFee = Value.singleton "" "" 2
, txInfoMint = burnt
, txInfoDCert = []
, txInfoWdrl = []
, txInfoValidRange = Interval.always
, txInfoSignatories = [signer]
, txInfoData = datumPair <$> [governorInputDatum, governorOutputDatum, effectInputDatum]
, txInfoId = "4dae3806cc69615b721d52ed09b758f43f25a8f39b7934d6b28514caf71f5f7b"
}
validNewGovernorDatum :: GovernorDatum
validNewGovernorDatum =
GovernorDatum
{ proposalThresholds = defaultProposalThresholds
, nextProposalId = ProposalId 42
}
invalidNewGovernorDatum :: GovernorDatum
invalidNewGovernorDatum =
GovernorDatum
{ proposalThresholds =
defaultProposalThresholds
{ countVoting = Tagged (-1)
}
, nextProposalId = ProposalId 42
}

2
agora-sample/Sample/Governor.hs
View file

@ -508,7 +508,7 @@ mintGATs =
The effect script should carry an valid tagged authority token,
and said token will be burnt in the transaction. We use 'noOpValidator'
here as a mock effect, so no actual change is done to the governor state.
TODO: use 'mutateGovernorEffect' as the mock effect in the future.
TODO: use 'Agora.Effect.GovernorMutation.mutateGovernorEffect' as the mock effect in the future.
The governor will ensure the new governor state is valid.
-}

4
agora-test/Spec.hs
View file

@ -7,6 +7,7 @@ import Test.Tasty (defaultMain, testGroup)
--------------------------------------------------------------------------------
import Spec.AuthorityToken qualified as AuthorityToken
import Spec.Effect.GovernorMutation qualified as GovernorMutation
import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
import Spec.Governor qualified as Governor
import Spec.Model.MultiSig qualified as MultiSig
@ -26,6 +27,9 @@ main =
[ testGroup
"Treasury Withdrawal Effect"
TreasuryWithdrawal.tests
, testGroup
"Governor Mutation Effect"
GovernorMutation.tests
]
, testGroup
"Stake tests"

67
agora-test/Spec/Effect/GovernorMutation.hs Normal file
View file

@ -0,0 +1,67 @@
module Spec.Effect.GovernorMutation (tests) where
import Agora.Effect.GovernorMutation (mutateGovernorValidator)
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
import Agora.Governor.Scripts (governorValidator)
import Agora.Proposal (ProposalId (..))
import Plutus.V1.Ledger.Api (ScriptContext (ScriptContext), ScriptPurpose (Spending))
import Sample.Effect.GovernorMutation (
effectRef,
govRef,
invalidNewGovernorDatum,
mkEffectDatum,
mkEffectTxInfo,
validNewGovernorDatum,
)
import Sample.Shared qualified as Shared
import Test.Tasty (TestTree, testGroup)
import Test.Util (effectFailsWith, effectSucceedsWith, validatorFailsWith, validatorSucceedsWith)
tests :: [TestTree]
tests =
[ testGroup
"validator"
[ testGroup
"valid new governor datum"
[ validatorSucceedsWith
"governor validator should pass"
(governorValidator Shared.governor)
( GovernorDatum
{ proposalThresholds = Shared.defaultProposalThresholds
, nextProposalId = ProposalId 0
}
)
MutateGovernor
( ScriptContext
(mkEffectTxInfo validNewGovernorDatum)
(Spending govRef)
)
, effectSucceedsWith
"effect validator should pass"
(mutateGovernorValidator Shared.governor)
(mkEffectDatum validNewGovernorDatum)
(ScriptContext (mkEffectTxInfo validNewGovernorDatum) (Spending effectRef))
]
, testGroup
"invalid new governor datum"
[ validatorFailsWith
"governor validator should fail"
(governorValidator Shared.governor)
( GovernorDatum
{ proposalThresholds = Shared.defaultProposalThresholds
, nextProposalId = ProposalId 0
}
)
MutateGovernor
( ScriptContext
(mkEffectTxInfo invalidNewGovernorDatum)
(Spending govRef)
)
, effectFailsWith
"effect validator should fail"
(mutateGovernorValidator Shared.governor)
(mkEffectDatum validNewGovernorDatum)
(ScriptContext (mkEffectTxInfo invalidNewGovernorDatum) (Spending effectRef))
]
]
]

3
agora.cabal
View file

@ -130,6 +130,7 @@ library
exposed-modules:
Agora.AuthorityToken
Agora.Effect
Agora.Effect.GovernorMutation
Agora.Effect.NoOp
Agora.Effect.TreasuryWithdrawal
Agora.Governor
@ -168,6 +169,7 @@ library agora-testlib
library agora-sample
import: lang, deps, test-deps
exposed-modules:
Sample.Effect.GovernorMutation
Sample.Effect.TreasuryWithdrawal
Sample.Governor
Sample.Proposal
@ -185,6 +187,7 @@ test-suite agora-test
hs-source-dirs: agora-test
other-modules:
Spec.AuthorityToken
Spec.Effect.GovernorMutation
Spec.Effect.TreasuryWithdrawal
Spec.Governor
Spec.Model.MultiSig

4
agora/Agora/Effect.hs
View file

@ -23,7 +23,7 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
-}
makeEffect ::
forall (datum :: PType).
(PIsData datum, PTryFrom PData datum) =>
(PIsData datum, PTryFrom PData (PAsData datum)) =>
CurrencySymbol ->
(forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
ClosedTerm PValidator
@ -35,7 +35,7 @@ makeEffect gatCs' f =
-- convert input datum, PData, into desierable type
-- the way this conversion is performed should be defined
-- by PTryFrom for each datum in effect script.
(datum', _) <- tctryFrom @datum datum
(pfromData -> datum', _) <- tctryFrom datum
-- ensure purpose is Spending.
PSpending txOutRef <- tcmatch $ pfromData ctx.purpose

214
agora/Agora/Effect/GovernorMutation.hs Normal file
View file

@ -0,0 +1,214 @@
{-# LANGUAGE TemplateHaskell #-}
{- |
Module : Agora.Effect.GovernorMutation
Maintainer : connor@mlabs.city
Description: An effect that mutates governor settings.
An effect for mutating governor settings.
-}
module Agora.Effect.GovernorMutation (
-- * Haskell-land
MutateGovernorDatum (..),
-- * Plutarch-land
PMutateGovernorDatum (..),
-- * Scripts
mutateGovernorValidator,
) where
--------------------------------------------------------------------------------
import Control.Applicative (Const)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
--------------------------------------------------------------------------------
import Plutarch.Api.V1 (
PTxOutRef,
PValidator,
PValue,
)
import Plutarch.Api.V1.Extra (pvalueOf)
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
)
import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
import Plutarch.TryFrom (PTryFrom (..))
import Plutarch.Unsafe (punsafeCoerce)
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Api (TxOutRef)
import Plutus.V1.Ledger.Value (AssetClass (..))
import PlutusTx qualified
--------------------------------------------------------------------------------
import Agora.Effect (makeEffect)
import Agora.Governor (
Governor,
GovernorDatum,
PGovernorDatum,
governorDatumValid,
)
import Agora.Governor.Scripts (
authorityTokenSymbolFromGovernor,
governorSTAssetClassFromGovernor,
)
import Agora.Utils (
isScriptAddress,
mustBePDJust,
mustBePJust,
ptryFindDatum,
tcassert,
)
--------------------------------------------------------------------------------
-- | Haskell-level datum for the governor mutation effect script.
data MutateGovernorDatum = MutateGovernorDatum
{ governorRef :: TxOutRef
-- ^ Referenced governor state UTXO should be updated by the effect.
, newDatum :: GovernorDatum
-- ^ The new settings for the governor.
}
deriving stock (Show, GHC.Generic)
deriving anyclass (Generic)
PlutusTx.makeIsDataIndexed ''MutateGovernorDatum [('MutateGovernorDatum, 0)]
--------------------------------------------------------------------------------
-- | Plutarch-level version of 'MutateGovernorDatum'.
newtype PMutateGovernorDatum (s :: S)
= PMutateGovernorDatum
( Term
s
( PDataRecord
'[ "governorRef" ':= PTxOutRef
, "newDatum" ':= PGovernorDatum
]
)
)
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving
(PlutusType, PIsData, PDataFields, PEq)
via (PIsDataReprInstances PMutateGovernorDatum)
instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernorDatum = MutateGovernorDatum
deriving via (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum) instance (PConstantDecl MutateGovernorDatum)
-- TODO: Derive this.
instance PTryFrom PData (PAsData PMutateGovernorDatum) where
type PTryFromExcess PData (PAsData PMutateGovernorDatum) = Const ()
ptryFrom' d k =
k (punsafeCoerce d, ())
--------------------------------------------------------------------------------
{- | Validator for the governor mutation effect.
This effect is implemented using the 'Agora.Effect.makeEffect' wrapper,
meaning that the burning of GAT is checked in said wrapper.
In order to locate the governor, the validator is parametrized with a 'Agora.Governor.Governor'.
All the information it needs to validate the effect is encoded in the 'MutateGovernorDatum',
so regardless what redeemer it's given, it will check:
- No token is minted/burnt other than GAT.
- Nothing is being paid to the the effect validator.
- The governor's state UTXO must be spent:
* It carries exactly one GST.
* It's referenced by 'governorRef' in the effect's datum.
- A new state UTXO is paid to the governor:
* It contains the GST.
* It has valid governor state datum.
* The datum is exactly the same as the 'newDatum'.
-}
mutateGovernorValidator :: Governor -> ClosedTerm PValidator
mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov) $
\_gatCs (datum :: Term _ PMutateGovernorDatum) _ txInfo -> unTermCont $ do
datumF <- tcont $ pletFields @'["newDatum", "governorRef"] datum
txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "datums"] txInfo
let mint :: Term _ (PBuiltinList _)
mint = pto $ pto $ pto $ pfromData txInfoF.mint
tcassert "Nothing should be minted/burnt other than GAT" $
plength # mint #== 1
-- Only two script inputs are alloed: one from the effect, one from the governor.
tcassert "Only self and governor script inputs are allowed" $
pfoldr
# phoistAcyclic
( plam $ \inInfo count ->
let address = pfield @"address" #$ pfield @"resolved" # inInfo
in pif
(isScriptAddress # address)
(count + 1)
count
)
# (0 :: Term _ PInteger)
# pfromData txInfoF.inputs
#== 2
-- Find the governor input by looking for GST.
let inputWithGST =
mustBePJust # "Governor input not found" #$ pfind
# phoistAcyclic
( plam $ \inInfo ->
let value = pfield @"value" #$ pfield @"resolved" # inInfo
in gstValueOf # value #== 1
)
# pfromData txInfoF.inputs
govInInfo <- tcont $ pletFields @'["outRef", "resolved"] $ inputWithGST
-- The effect can only modify the governor UTXO referenced in the datum.
tcassert "Can only modify the pinned governor" $
govInInfo.outRef #== datumF.governorRef
-- The transaction can only have one output, which should be sent to the governor.
tcassert "Only governor output is allowed" $
plength # pfromData txInfoF.outputs #== 1
let govAddress = pfield @"address" #$ govInInfo.resolved
govOutput' = pfromData $ phead # pfromData txInfoF.outputs
govOutput <- tcont $ pletFields @'["address", "value", "datumHash"] govOutput'
tcassert "No output to the governor" $
govOutput.address #== govAddress
tcassert "Governor output doesn't carry the GST" $
gstValueOf # govOutput.value #== 1
let governorOutputDatumHash =
mustBePDJust # "Governor output doesn't have datum" # govOutput.datumHash
governorOutputDatum =
pfromData @PGovernorDatum $
mustBePJust # "Governor output datum not found"
#$ ptryFindDatum # governorOutputDatumHash # txInfoF.datums
-- Ensure the output governor datum is what we want.
tcassert "Unexpected governor datum" $ datumF.newDatum #== governorOutputDatum
tcassert "New governor datum should be valid" $ governorDatumValid # 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) = governorSTAssetClassFromGovernor gov

6
agora/Agora/Effect/NoOp.hs
View file

@ -18,13 +18,13 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
deriving (PlutusType, PIsData) via (DerivePNewtype PNoOp PUnit)
instance PTryFrom PData PNoOp where
type PTryFromExcess PData PNoOp = Const ()
instance PTryFrom PData (PAsData PNoOp) where
type PTryFromExcess PData (PAsData PNoOp) = Const ()
ptryFrom' _ cont =
-- JUSTIFICATION:
-- We don't care anything about data.
-- It should always be reduced to Unit.
cont (pcon $ PNoOp (pconstant ()), ())
cont (pdata $ pcon $ PNoOp (pconstant ()), ())
-- | Dummy effect which can only burn its GAT.
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator

14
agora/Agora/Effect/TreasuryWithdrawal.hs
View file

@ -18,7 +18,7 @@ import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Agora.Effect (makeEffect)
import Agora.Utils (findTxOutByTxOutRef, paddValue, tcassert, tclet, tcmatch)
import Agora.Utils (findTxOutByTxOutRef, isPubKey, paddValue, tcassert, tclet, tcmatch)
import Plutarch.Api.V1 (
PCredential (..),
PTuple,
@ -82,8 +82,8 @@ deriving via
instance
(PConstantDecl TreasuryWithdrawalDatum)
instance PTryFrom PData PTreasuryWithdrawalDatum where
type PTryFromExcess PData PTreasuryWithdrawalDatum = Const ()
instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum) where
type PTryFromExcess PData (PAsData PTreasuryWithdrawalDatum) = Const ()
ptryFrom' opq cont =
-- TODO: This should not use 'punsafeCoerce'.
-- Blocked by 'PCredential', and 'PTuple'.
@ -140,12 +140,6 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
receiverValuesSum = sumValues # datum.receivers
isPubkey = plam $ \cred ->
pmatch cred $
\case
PPubKeyCredential _ -> pcon PTrue
PScriptCredential _ -> pcon PFalse
-- Constraints
outputContentMatchesRecivers =
pall # plam (\out -> pelem # out # outputValues)
@ -165,7 +159,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
( \((pfield @"_0" #) . pfromData -> cred) ->
cred #== pfield @"credential" # effInput.address
#|| pelem # cred # datum.treasuries
#|| isPubkey # pfromData cred
#|| isPubKey # pfromData cred
)
# inputValues

17
agora/Agora/Utils.hs
View file

@ -61,6 +61,8 @@ module Agora.Utils (
validatorHashToAddress,
pmergeBy,
phalve,
isScriptAddress,
isPubKey,
) where
--------------------------------------------------------------------------------
@ -214,7 +216,7 @@ pfromMaybe = phoistAcyclic $
PJust a' -> a'
PNothing -> e
-- | Yield True if a given PMaybe is of form PJust _.
-- | Yield True if a given PMaybe is of form @'PJust' _@.
pisJust :: forall a s. Term s (PMaybe a :--> PBool)
pisJust = phoistAcyclic $
plam $ \v' ->
@ -657,6 +659,19 @@ scriptHashFromAddress = phoistAcyclic $
PScriptCredential ((pfield @"_0" #) -> h) -> pcon $ PJust h
_ -> pcon PNothing
-- | Return true if the given address is a script address.
isScriptAddress :: Term s (PAddress :--> PBool)
isScriptAddress = phoistAcyclic $
plam $ \addr -> pnot #$ isPubKey #$ pfromData $ pfield @"credential" # addr
-- | Return true if the given credential is a pub-key-hash.
isPubKey :: Term s (PCredential :--> PBool)
isPubKey = phoistAcyclic $
plam $ \cred ->
pmatch cred $ \case
PScriptCredential _ -> pconstant False
_ -> pconstant True
-- | Find all TxOuts sent to an Address
findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut))
findOutputsToAddress = phoistAcyclic $