From b0eb044bf229156d302aeab4d1747ff79b93822f Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 31 Mar 2022 16:48:59 +0200 Subject: [PATCH] lock field in Stake datum, `singleAuthorityTokenBurned` helper --- agora-test/Spec/Sample/Stake.hs | 6 +-- agora-test/Spec/Stake.hs | 6 +-- agora/Agora/AuthorityToken.hs | 32 ++++++++++++++- agora/Agora/Effect.hs | 25 +++++++++--- agora/Agora/Proposal.hs | 18 +++++++++ agora/Agora/Stake.hs | 70 +++++++++++++++++++++++++++++++-- agora/Agora/Treasury.hs | 16 +++----- 7 files changed, 146 insertions(+), 27 deletions(-) diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index e0ed848..08bd0e1 100644 --- a/agora-test/Spec/Sample/Stake.hs +++ b/agora-test/Spec/Sample/Stake.hs @@ -95,7 +95,7 @@ stakeCreation :: ScriptContext stakeCreation = let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST datum :: Datum - datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer) + datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer []) in ScriptContext { scriptContextTxInfo = TxInfo @@ -123,7 +123,7 @@ stakeCreation = stakeCreationWrongDatum :: ScriptContext stakeCreationWrongDatum = let datum :: Datum - datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer) -- Too much GT + datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT in ScriptContext { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]} , scriptContextPurpose = Minting policySymbol @@ -155,7 +155,7 @@ stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext stakeDepositWithdraw config = let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST stakeBefore :: StakeDatum - stakeBefore = StakeDatum config.startAmount signer + stakeBefore = StakeDatum config.startAmount signer [] stakeAfter :: StakeDatum stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta} diff --git a/agora-test/Spec/Stake.hs b/agora-test/Spec/Stake.hs index ccd16e7..8f2538d 100644 --- a/agora-test/Spec/Stake.hs +++ b/agora-test/Spec/Stake.hs @@ -52,19 +52,19 @@ tests = , validatorSucceedsWith "stakeDepositWithdraw deposit" (stakeValidator Stake.stake) - (toDatum $ StakeDatum 100_000 signer) + (toDatum $ StakeDatum 100_000 signer []) (toDatum $ DepositWithdraw 100_000) (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000}) , validatorSucceedsWith "stakeDepositWithdraw withdraw" (stakeValidator Stake.stake) - (toDatum $ StakeDatum 100_000 signer) + (toDatum $ StakeDatum 100_000 signer []) (toDatum $ DepositWithdraw $ negate 100_000) (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000}) , validatorFailsWith "stakeDepositWithdraw negative GT" (stakeValidator Stake.stake) - (toDatum $ StakeDatum 100_000 signer) + (toDatum $ StakeDatum 100_000 signer []) (toDatum $ DepositWithdraw 1_000_000) (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000}) ] diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index 4050348..dadabe4 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -8,6 +8,7 @@ Tokens acting as redeemable proofs of DAO authority. module Agora.AuthorityToken ( authorityTokenPolicy, authorityTokensValidIn, + singleAuthorityTokenBurned, AuthorityToken (..), ) where @@ -32,7 +33,15 @@ import Prelude -------------------------------------------------------------------------------- -import Agora.Utils (allOutputs, passert, passetClassValueOf, passetClassValueOf', plookup) +import Agora.Utils ( + allInputs, + allOutputs, + passert, + passetClassValueOf, + passetClassValueOf', + plookup, + psymbolValueOf, + ) -------------------------------------------------------------------------------- @@ -85,6 +94,27 @@ authorityTokensValidIn = phoistAcyclic $ -- No GATs exist at this output! pconstant True +-- | Assert that a single authority token has been burned. +singleAuthorityTokenBurned :: + forall (s :: S). + Term s PCurrencySymbol -> + Term s (PAsData PTxInfo) -> + Term s PValue -> + Term s PBool +singleAuthorityTokenBurned gatCs txInfo mint = P.do + let gatAmountMinted :: Term _ PInteger + gatAmountMinted = psymbolValueOf # gatCs # mint + + foldr1 + (#&&) + [ ptraceIfFalse "GAT not burned." $ gatAmountMinted #== -1 + , ptraceIfFalse "All inputs only have valid GATs" $ + allInputs @PUnit # pfromData txInfo #$ plam $ \txOut _value _address _datum -> + authorityTokensValidIn + # gatCs + # txOut + ] + -- | Policy given 'AuthorityToken' params. authorityTokenPolicy :: AuthorityToken -> diff --git a/agora/Agora/Effect.hs b/agora/Agora/Effect.hs index 82764d2..69ddc1c 100644 --- a/agora/Agora/Effect.hs +++ b/agora/Agora/Effect.hs @@ -7,19 +7,28 @@ Helpers for constructing effects. -} module Agora.Effect (makeEffect) where -import Plutarch.Api.V1 (PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator) +import Agora.AuthorityToken (singleAuthorityTokenBurned) +import Agora.Utils (passert) +import Plutarch.Api.V1 (PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue) import Plutarch.Internal (punsafeCoerce) import Plutarch.Monadic qualified as P +import Plutus.V1.Ledger.Value (CurrencySymbol) -------------------------------------------------------------------------------- --- | Helper "template" for creating effect validator. +{- | Helper "template" for creating effect validator. + + In some situations, it may be the case that we need more control over how + an effect is implemented. In such situations, it's okay to not use this + helper. +-} makeEffect :: forall (datum :: PType) (s :: S). PIsData datum => - (Term s datum -> Term s PTxOutRef -> Term s PTxInfo -> Term s POpaque) -> + CurrencySymbol -> + (Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) -> Term s PValidator -makeEffect f = +makeEffect gatCs' f = plam $ \datum _redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo' <- plet ctx.txInfo @@ -30,7 +39,13 @@ makeEffect f = PSpending txOutRef <- pmatch $ pfromData ctx.purpose txOutRef' <- plet (pfield @"_0" # txOutRef) - -- TODO: Here, check that a *single* GAT is burned. + txInfo <- pletFields @'["mint"] txInfo' + let mint :: Term s PValue + mint = txInfo.mint + + gatCs <- plet $ pconstant gatCs' + + passert "singleAuthorityTokenBurned" $ singleAuthorityTokenBurned gatCs txInfo' mint f datum' txOutRef' txInfo' diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index a5dbbd9..f063b6d 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -14,10 +14,15 @@ module Agora.Proposal ( ProposalStatus (..), ProposalThresholds (..), ProposalVotes (..), + ProposalTag (..), ResultTag (..), -- * Plutarch-land PProposalDatum (..), + PProposalStatus (..), + PProposalThresholds (..), + PProposalVotes (..), + PProposalTag (..), PResultTag (..), ) where @@ -85,6 +90,7 @@ data ProposalStatus -- -- TODO: The owner of the proposal may choose to reclaim their proposal. Finished + deriving stock (Eq, Show, GHC.Generic) PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Finished, 2)] @@ -101,6 +107,7 @@ data ProposalThresholds = ProposalThresholds -- ^ How much GT required to allow voting to happen. -- (i.e. to move into 'VotingReady') } + deriving stock (Eq, Show, GHC.Generic) PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)] @@ -119,6 +126,7 @@ newtype ProposalVotes = ProposalVotes { getProposalVotes :: [(ResultTag, Integer)] } deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving stock (Eq, Show, GHC.Generic) -- | Haskell-level datum for Proposal scripts. data ProposalDatum = ProposalDatum @@ -136,9 +144,15 @@ data ProposalDatum = ProposalDatum , votes :: ProposalVotes -- ^ Vote tally on the proposal } + deriving stock (Eq, Show, GHC.Generic) PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)] +-- | Identifies a Proposal, issued upon creation of a proposal. +newtype ProposalTag = ProposalTag {proposalTag :: Integer} + deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving stock (Eq, Show, GHC.Generic) + -- | Parameters that identify the Proposal validator script. data Proposal = Proposal @@ -149,6 +163,10 @@ data Proposal = Proposal newtype PResultTag (s :: S) = PResultTag (Term s PInteger) deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PResultTag PInteger) +-- | Plutarch-level version of 'PProposalTag'. +newtype PProposalTag (s :: S) = PProposalTag (Term s PInteger) + deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTag PInteger) + -- | Plutarch-level version of 'ProposalStatus'. data PProposalStatus (s :: S) = -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'. diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index ff362e0..814b2f2 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -12,6 +12,8 @@ module Agora.Stake ( PStakeRedeemer (..), StakeDatum (..), StakeRedeemer (..), + ProposalLock (..), + PProposalLock (..), Stake (..), stakePolicy, stakeValidator, @@ -43,15 +45,18 @@ import Plutarch.Api.V1 ( mkMintingPolicy, ) import Plutarch.DataRepr ( + DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (PIsDataReprInstances), ) import Plutarch.Internal (punsafeCoerce) +import Plutarch.Lift (PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) -------------------------------------------------------------------------------- +import Agora.Proposal (PProposalTag, PResultTag, ProposalTag (..), ResultTag (..)) import Agora.SafeMoney (GTTag) import Agora.Utils ( anyInput, @@ -94,19 +99,48 @@ data StakeRedeemer PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)] +data ProposalLock = ProposalLock + { vote :: ResultTag + -- ^ What was voted on. This allows retracting votes to + -- undo their vote. + , proposalTag :: ProposalTag + -- ^ Identifies the proposal. + } + deriving stock (Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed ''ProposalLock [('ProposalLock, 0)] + -- | Haskell-level datum for Stake scripts. data StakeDatum = StakeDatum { stakedAmount :: Tagged GTTag Integer + -- ^ Tracks the amount of governance token staked in the datum. + -- This also acts as the voting weight for 'Proposal's. , owner :: PubKeyHash + -- ^ The hash of the public key this stake belongs to. + -- + -- TODO Support for MultiSig/Scripts is tracked here: + -- https://github.com/Liqwid-Labs/agora/issues/45 + , lockedBy :: [ProposalLock] + -- ^ The proposal locks in place. This field must be empty + -- for the stake to be usable for deposits and withdrawals. } deriving stock (Show, GHC.Generic) PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)] +-------------------------------------------------------------------------------- + -- | Plutarch-level datum for Stake scripts. newtype PStakeDatum (s :: S) = PStakeDatum { getStakeDatum :: - Term s (PDataRecord '["stakedAmount" ':= PDiscrete GTTag, "owner" ':= PPubKeyHash]) + Term + s + ( PDataRecord + '[ "stakedAmount" ':= PDiscrete GTTag + , "owner" ':= PPubKeyHash + , "lockedBy" ':= PBuiltinList (PAsData PProposalLock) + ] + ) } deriving stock (GHC.Generic) deriving anyclass (Generic) @@ -115,6 +149,9 @@ newtype PStakeDatum (s :: S) = PStakeDatum (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PStakeDatum) +instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum +deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum) + -- | Plutarch-level redeemer for Stake scripts. data PStakeRedeemer (s :: S) = -- | Deposit or withdraw a discrete amount of the staked governance token. @@ -128,6 +165,29 @@ data PStakeRedeemer (s :: S) (PlutusType, PIsData) via PIsDataReprInstances PStakeRedeemer +instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer +deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer) + +newtype PProposalLock (s :: S) = PProposalLock + { getProposalLock :: + Term + s + ( PDataRecord + '[ "vote" ':= PResultTag + , "proposalTag" ':= PProposalTag + ] + ) + } + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData, PDataFields) + via (PIsDataReprInstances PProposalLock) + +instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock +deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock) + -------------------------------------------------------------------------------- {- What this Policy does @@ -338,6 +398,8 @@ stakeValidator stake = -- | Check whether a Stake is locked. If it is locked, various actions are unavailable. stakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool) stakeLocked = phoistAcyclic $ - plam $ \_stakeDatum -> - -- TODO: when we extend this to support proposals, this will need to do something - pcon PFalse + plam $ \stakeDatum -> + let locks :: Term _ (PBuiltinList (PAsData PProposalLock)) + locks = pfield @"lockedBy" # stakeDatum + in -- 'pnotNull' ? + pelimList (\_ _ -> pcon PTrue) (pcon PFalse) locks diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index ff4ab36..df11f65 100644 --- a/agora/Agora/Treasury.hs +++ b/agora/Agora/Treasury.hs @@ -21,8 +21,8 @@ import Plutus.V1.Ledger.Value (CurrencySymbol) -------------------------------------------------------------------------------- -import Agora.AuthorityToken (authorityTokensValidIn) -import Agora.Utils (allInputs, passert, psymbolValueOf) +import Agora.AuthorityToken (singleAuthorityTokenBurned) +import Agora.Utils (passert) {- | Validator ensuring that transactions consuming the treasury do so in a valid manner. @@ -37,7 +37,7 @@ treasuryV :: :--> PAsData PScriptContext :--> PUnit ) -treasuryV cs = plam $ \_d r ctx' -> P.do +treasuryV gatCs' = plam $ \_d r ctx' -> P.do -- plet required fields from script context. ctx <- pletFields @["txInfo", "purpose"] ctx' @@ -52,16 +52,10 @@ treasuryV cs = plam $ \_d r ctx' -> P.do txInfo <- pletFields @'["mint"] txInfo' let mint :: Term s PValue mint = txInfo.mint - gatAmountMinted :: Term s PInteger - gatAmountMinted = psymbolValueOf # pconstant cs # mint - passert "GAT not burned." $ gatAmountMinted #== -1 + gatCs <- plet $ pconstant gatCs' - passert "All inputs only have valid GATs" $ - allInputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum -> - authorityTokensValidIn - # pconstant cs - # txOut + passert "singleAuthorityTokenBurned" $ singleAuthorityTokenBurned gatCs txInfo' mint pconstant ()