diff --git a/agora-sample/Sample/Effect/GovernorMutation.hs b/agora-sample/Sample/Effect/GovernorMutation.hs new file mode 100644 index 0000000..7d41cb7 --- /dev/null +++ b/agora-sample/Sample/Effect/GovernorMutation.hs @@ -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 + } diff --git a/agora-sample/Sample/Governor.hs b/agora-sample/Sample/Governor.hs index 27d867b..8d0cab5 100644 --- a/agora-sample/Sample/Governor.hs +++ b/agora-sample/Sample/Governor.hs @@ -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. -} diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index d2c90f7..2d97c1e 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -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" diff --git a/agora-test/Spec/Effect/GovernorMutation.hs b/agora-test/Spec/Effect/GovernorMutation.hs new file mode 100644 index 0000000..1436b5a --- /dev/null +++ b/agora-test/Spec/Effect/GovernorMutation.hs @@ -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)) + ] + ] + ] diff --git a/agora.cabal b/agora.cabal index 3d83793..9014c21 100644 --- a/agora.cabal +++ b/agora.cabal @@ -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 diff --git a/agora/Agora/Effect.hs b/agora/Agora/Effect.hs index 8fb40ba..c35ed55 100644 --- a/agora/Agora/Effect.hs +++ b/agora/Agora/Effect.hs @@ -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 diff --git a/agora/Agora/Effect/GovernorMutation.hs b/agora/Agora/Effect/GovernorMutation.hs new file mode 100644 index 0000000..fb28e33 --- /dev/null +++ b/agora/Agora/Effect/GovernorMutation.hs @@ -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 diff --git a/agora/Agora/Effect/NoOp.hs b/agora/Agora/Effect/NoOp.hs index a384675..39c63ee 100644 --- a/agora/Agora/Effect/NoOp.hs +++ b/agora/Agora/Effect/NoOp.hs @@ -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 diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 5bad045..5bf451c 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -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 diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index c594200..89f33c1 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -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 $