From 097e055f199717c44299a48c9bfe6117b0bb183b Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 30 Mar 2022 15:32:50 +0200 Subject: [PATCH 1/6] use plutarch-safemoney instead of local Agora.SafeMoney --- agora-test/Spec/Sample/Stake.hs | 13 ++-- agora.cabal | 1 + agora/Agora/Proposal.hs | 9 ++- agora/Agora/SafeMoney.hs | 125 ++------------------------------ agora/Agora/Stake.hs | 78 ++++++++++---------- flake.lock | 14 ++-- flake.nix | 14 +++- 7 files changed, 75 insertions(+), 179 deletions(-) diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index 85b95ac..e0ed848 100644 --- a/agora-test/Spec/Sample/Stake.hs +++ b/agora-test/Spec/Sample/Stake.hs @@ -51,8 +51,9 @@ import Plutus.V1.Ledger.Value qualified as Value -------------------------------------------------------------------------------- -import Agora.SafeMoney +import Agora.SafeMoney (GTTag) import Agora.Stake +import Plutarch.SafeMoney import Spec.Util (datumPair, toDatumHash) -------------------------------------------------------------------------------- @@ -62,7 +63,7 @@ stake :: Stake stake = Stake { gtClassRef = - AssetClassRef + Tagged ( AssetClass ( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" , "LQ" @@ -143,9 +144,9 @@ stakeCreationUnsigned = -- | Config for creating a ScriptContext that deposits or withdraws. data DepositWithdrawExample = DepositWithdrawExample - { startAmount :: Discrete GTTag + { startAmount :: Tagged GTTag Integer -- ^ The amount of GT stored before the transaction. - , delta :: Discrete GTTag + , delta :: Tagged GTTag Integer -- ^ The amount of GT deposited or withdrawn from the Stake. } @@ -168,7 +169,7 @@ stakeDepositWithdraw config = { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing , txOutValue = st - <> discreteValue stake.gtClassRef stakeBefore.stakedAmount + <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount) , txOutDatumHash = Just (toDatumHash stakeAfter) } ] @@ -177,7 +178,7 @@ stakeDepositWithdraw config = { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing , txOutValue = st - <> discreteValue stake.gtClassRef stakeAfter.stakedAmount + <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount) , txOutDatumHash = Just (toDatumHash stakeAfter) } ] diff --git a/agora.cabal b/agora.cabal index 3afdca4..046a5c8 100644 --- a/agora.cabal +++ b/agora.cabal @@ -97,6 +97,7 @@ common deps , plutarch , plutarch-extra , plutarch-numeric + , plutarch-safemoney , plutus-core , plutus-ledger-api , plutus-tx diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index ddad144..a5dbbd9 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -38,7 +38,8 @@ import PlutusTx qualified -------------------------------------------------------------------------------- -import Agora.SafeMoney (Discrete, GTTag, PDiscrete) +import Agora.SafeMoney (GTTag) +import Plutarch.SafeMoney (PDiscrete, Tagged) -------------------------------------------------------------------------------- -- Haskell-land @@ -92,11 +93,11 @@ PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('F to 'Proposal's when they are created. -} data ProposalThresholds = ProposalThresholds - { execute :: Discrete GTTag + { execute :: Tagged GTTag Integer -- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass. - , draft :: Discrete GTTag + , draft :: Tagged GTTag Integer -- ^ How much GT required to "create" a proposal. - , vote :: Discrete GTTag + , vote :: Tagged GTTag Integer -- ^ How much GT required to allow voting to happen. -- (i.e. to move into 'VotingReady') } diff --git a/agora/Agora/SafeMoney.hs b/agora/Agora/SafeMoney.hs index d8c3da0..8791ff9 100644 --- a/agora/Agora/SafeMoney.hs +++ b/agora/Agora/SafeMoney.hs @@ -1,51 +1,21 @@ {- | Module : Agora.SafeMoney Maintainer : emi@haskell.fyi -Description: Phantom-type protected types for handling money in Plutus. +Description: Tags and bonuses for Plutarch.SafeMoney. -Phantom-type protected types for handling money in Plutus. +Tags and bonuses for "Plutarch.SafeMoney". -} module Agora.SafeMoney ( - -- * Types - PDiscrete (..), - Discrete (..), - - -- * Tags and refs - AssetClassRef (..), ADATag, GTTag, adaRef, - - -- * Utility functions - paddDiscrete, - pgeqDiscrete, - pzeroDiscrete, - - -- * Conversions - pdiscreteValue, - pvalueDiscrete, - discreteValue, ) where -import Prelude - -------------------------------------------------------------------------------- -import Plutus.V1.Ledger.Value (AssetClass (AssetClass), Value) -import Plutus.V1.Ledger.Value qualified as Value -import PlutusTx qualified +import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) -import Plutarch.Api.V1 (PValue) -import Plutarch.Builtin () -import Plutarch.Internal () -import Plutarch.Monadic qualified as P - --------------------------------------------------------------------------------- - -import Agora.Utils ( - passetClassValueOf', - psingletonValue, - ) +import Plutarch.SafeMoney -------------------------------------------------------------------------------- -- Example tags @@ -58,89 +28,6 @@ data ADATag -------------------------------------------------------------------------------- --- | A tagged AssetClass. Use to resolve a reference inside of a PDiscrete -newtype AssetClassRef (tag :: Type) = AssetClassRef {getAssetClass :: AssetClass} - -- | Resolves ada tags. -adaRef :: AssetClassRef ADATag -adaRef = AssetClassRef (AssetClass ("", "")) - --- TODO: Currently it's possible to transmute from one discrete to another. --- How do we prevent this? --- --- @ --- transmute :: forall (a :: Type) (b :: Type). Discrete a -> Discrete b --- transmute = Discrete . getDiscrete --- @ - -{- | Represents a single asset in a 'Plutus.V1.Ledger.Value.Value' related to a particular 'AssetClass' - through 'AssetClassRef'. --} -newtype Discrete (tag :: Type) = Discrete {getDiscrete :: Integer} - deriving stock (Show, Eq) - deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) - deriving newtype (Num) -- TODO: Use plutarch-numeric - -{- | Represents a single asset in a 'PValue' related to a particular 'AssetClass' - through 'AssetClassRef'. --} -newtype PDiscrete (tag :: Type) (s :: S) - = PDiscrete (Term s PInteger) - deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete tag) PInteger) - --- | Check if one 'PDiscrete' is greater than another. -pgeqDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag :--> PDiscrete tag :--> PBool) -pgeqDiscrete = phoistAcyclic $ - plam $ \x y -> P.do - PDiscrete x' <- pmatch x - PDiscrete y' <- pmatch y - y' #<= x' - --- | Returns a zero-value 'PDiscrete' unit for any tag. -pzeroDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag) -pzeroDiscrete = phoistAcyclic $ pcon (PDiscrete 0) - --- | Add two 'PDiscrete' values of the same tag. -paddDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag :--> PDiscrete tag :--> PDiscrete tag) -paddDiscrete = phoistAcyclic $ - -- In the future, this should use plutarch-numeric - plam $ \x y -> P.do - PDiscrete x' <- pmatch x - PDiscrete y' <- pmatch y - pcon (PDiscrete $ x' + y') - --------------------------------------------------------------------------------- - --- | Downcast a `PValue` to a `PDiscrete` unit. -pvalueDiscrete :: - forall (tag :: Type) (s :: S). - AssetClassRef tag -> - Term s (PValue :--> PDiscrete tag) -pvalueDiscrete (AssetClassRef ac) = phoistAcyclic $ - plam $ \f -> - pcon . PDiscrete $ passetClassValueOf' ac # f - -{- | Get a `PValue` from a `PDiscrete`. - __NOTE__: `pdiscreteValue` after `pvalueDiscrete` is not a round-trip. - It filters for a particular tag. --} -pdiscreteValue :: - forall (tag :: Type) (s :: S). - AssetClassRef tag -> - Term s (PDiscrete tag :--> PValue) -pdiscreteValue (AssetClassRef (AssetClass (cs, tn))) = phoistAcyclic $ - plam $ \f -> pmatch f $ \case - PDiscrete p -> - psingletonValue - # pconstant cs - # pconstant tn - # p - --- | Get a `Value` from a `Discrete`. -discreteValue :: - forall (tag :: Type). - AssetClassRef tag -> - Discrete tag -> - Value -discreteValue (AssetClassRef (AssetClass (cs, tn))) (Discrete v) = - Value.singleton cs tn v +adaRef :: Tagged ADATag AssetClass +adaRef = Tagged (AssetClass ("", "")) diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 67184bf..ff362e0 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -22,7 +22,7 @@ module Agora.Stake ( import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) -import Prelude +import Prelude hiding (Num (..)) -------------------------------------------------------------------------------- @@ -52,16 +52,7 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) -------------------------------------------------------------------------------- -import Agora.SafeMoney ( - AssetClassRef (..), - Discrete, - GTTag, - PDiscrete, - paddDiscrete, - pdiscreteValue, - pgeqDiscrete, - pzeroDiscrete, - ) +import Agora.SafeMoney (GTTag) import Agora.Utils ( anyInput, anyOutput, @@ -77,38 +68,41 @@ import Agora.Utils ( ptxSignedBy, pvalueSpent, ) +import Plutarch.Numeric +import Plutarch.SafeMoney ( + PDiscrete, + Tagged (..), + pdiscreteValue, + untag, + ) -------------------------------------------------------------------------------- -- | Parameters for creating Stake scripts. newtype Stake = Stake - { gtClassRef :: AssetClassRef GTTag + { gtClassRef :: Tagged GTTag AssetClass -- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code. } --- | Plutarch-level redeemer for Stake scripts. -data PStakeRedeemer (s :: S) - = -- | Deposit or withdraw a discrete amount of the staked governance token. - PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag])) - | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. - PDestroy (Term s (PDataRecord '[])) - deriving stock (GHC.Generic) - deriving anyclass (Generic) - deriving anyclass (PIsDataRepr) - deriving - (PlutusType, PIsData) - via PIsDataReprInstances PStakeRedeemer - -- | Haskell-level redeemer for Stake scripts. data StakeRedeemer = -- | Deposit or withdraw a discrete amount of the staked governance token. - DepositWithdraw (Discrete GTTag) + DepositWithdraw (Tagged GTTag Integer) | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. Destroy deriving stock (Show, GHC.Generic) PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)] +-- | Haskell-level datum for Stake scripts. +data StakeDatum = StakeDatum + { stakedAmount :: Tagged GTTag Integer + , owner :: PubKeyHash + } + deriving stock (Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)] + -- | Plutarch-level datum for Stake scripts. newtype PStakeDatum (s :: S) = PStakeDatum { getStakeDatum :: @@ -121,14 +115,18 @@ newtype PStakeDatum (s :: S) = PStakeDatum (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PStakeDatum) --- | Haskell-level datum for Stake scripts. -data StakeDatum = StakeDatum - { stakedAmount :: Discrete GTTag - , owner :: PubKeyHash - } - deriving stock (Show, GHC.Generic) - -PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)] +-- | Plutarch-level redeemer for Stake scripts. +data PStakeRedeemer (s :: S) + = -- | Deposit or withdraw a discrete amount of the staked governance token. + PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag])) + | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. + PDestroy (Term s (PDataRecord '[])) + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData) + via PIsDataReprInstances PStakeRedeemer -------------------------------------------------------------------------------- {- What this Policy does @@ -223,7 +221,7 @@ stakePolicy stake = foldr1 (#&&) [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue - , pgeqByClass' stake.gtClassRef.getAssetClass + , pgeqByClass' (untag stake.gtClassRef) # value # expectedValue , pgeqByClass @@ -300,15 +298,15 @@ stakeValidator stake = foldr1 (#&&) [ stakeDatum.owner #== newStakeDatum.owner - , (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount + , (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount , -- We can't magically conjure GT anyway (no input to spend!) -- do we need to check this, really? - pgeqDiscrete # (pfromData newStakeDatum.stakedAmount) # pzeroDiscrete + zero #<= pfromData newStakeDatum.stakedAmount ] let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta) - ptrace (pshow $ passetClassValueOf' stake.gtClassRef.getAssetClass # value) - ptrace (pshow $ passetClassValueOf' stake.gtClassRef.getAssetClass # expectedValue) + ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # value) + ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # expectedValue) -- TODO: Same as above. This is quite inefficient now, as it does two lookups -- instead of a more efficient single pass, @@ -317,7 +315,7 @@ stakeValidator stake = foldr1 (#&&) [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue - , pgeqByClass' stake.gtClassRef.getAssetClass + , pgeqByClass' (untag stake.gtClassRef) # value # expectedValue , pgeqBySymbol diff --git a/flake.lock b/flake.lock index 89b8ae5..3f6d571 100644 --- a/flake.lock +++ b/flake.lock @@ -1381,11 +1381,11 @@ }, "nixpkgs-2111_3": { "locked": { - "lastModified": 1648420413, - "narHash": "sha256-AHejj7EsbTt+CMOoy15wwkFsFNmx8oinGgDZR22lS6g=", + "lastModified": 1648608655, + "narHash": "sha256-pTjZg9DwU89ZZ1fdtt6/i1X4vSNXoRJYUArgVZPh9F8=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "d6778e0b5d608eb6738af2a64e26d99cdc5b9e86", + "rev": "ba93b1d8253ed4b359b9e81d10e02c106d3f8b11", "type": "github" }, "original": { @@ -1621,17 +1621,17 @@ "validity": "validity" }, "locked": { - "lastModified": 1648163186, - "narHash": "sha256-UfaSb4nk9HWzsj1Kb8RJuPV+iw1Nl4E2+97KOwIwcao=", + "lastModified": 1648639396, + "narHash": "sha256-pAkEsIDXJckVYufVPUzD/4sq4/uE7iyV0IR2BuLhZjY=", "owner": "peter-mlabs", "repo": "plutarch", - "rev": "0638dbd706bc2c5f48f9f40be7bbe1986a778698", + "rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6", "type": "github" }, "original": { "owner": "peter-mlabs", - "ref": "liqwid/extra", "repo": "plutarch", + "rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6", "type": "github" } }, diff --git a/flake.nix b/flake.nix index b944b18..abedaff 100644 --- a/flake.nix +++ b/flake.nix @@ -7,7 +7,9 @@ # see https://github.com/NixOS/nix/issues/6013 inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; }; - inputs.plutarch.url = "github:peter-mlabs/plutarch/liqwid/extra"; + # Rev is this PR https://github.com/peter-mlabs/plutarch/pull/5. + inputs.plutarch.url = + "github:peter-mlabs/plutarch?rev=a7a410da209b9c14c834a41e07b1c197c2a4dcd6"; inputs.plutarch.inputs.nixpkgs.follows = "plutarch/haskell-nix/nixpkgs-unstable"; @@ -56,8 +58,13 @@ extraSources = plutarch.extraSources ++ [ { src = inputs.plutarch; - subdirs = - [ "." "plutarch-test" "plutarch-extra" "plutarch-numeric" ]; + subdirs = [ + "." + "plutarch-test" + "plutarch-extra" + "plutarch-numeric" + "plutarch-safemoney" + ]; } { src = inputs.apropos-tx; @@ -96,6 +103,7 @@ ps.apropos-tx ps.plutarch-extra ps.plutarch-numeric + ps.plutarch-safemoney ps.plutarch-test ps.apropos ]; From b0eb044bf229156d302aeab4d1747ff79b93822f Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 31 Mar 2022 16:48:59 +0200 Subject: [PATCH 2/6] 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 () From 4ef7c7866cae496ab3106c15bdaf9670e572669e Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 4 Apr 2022 13:11:01 +0200 Subject: [PATCH 3/6] add locks in datums, add documentation, ClosedTerm on scripts Also added more lifting instances --- agora/Agora/Effect.hs | 8 +-- agora/Agora/Proposal.hs | 55 +++++++++++++++++++- agora/Agora/Stake.hs | 109 ++++++++++++++++++++++++++++++---------- agora/Agora/Treasury.hs | 6 +-- agora/Agora/Utils.hs | 5 ++ 5 files changed, 147 insertions(+), 36 deletions(-) diff --git a/agora/Agora/Effect.hs b/agora/Agora/Effect.hs index 69ddc1c..a4e3782 100644 --- a/agora/Agora/Effect.hs +++ b/agora/Agora/Effect.hs @@ -23,11 +23,11 @@ import Plutus.V1.Ledger.Value (CurrencySymbol) helper. -} makeEffect :: - forall (datum :: PType) (s :: S). + forall (datum :: PType). PIsData datum => CurrencySymbol -> - (Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) -> - Term s PValidator + (forall (s :: S). Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) -> + ClosedTerm PValidator makeEffect gatCs' f = plam $ \datum _redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' @@ -40,7 +40,7 @@ makeEffect gatCs' f = txOutRef' <- plet (pfield @"_0" # txOutRef) txInfo <- pletFields @'["mint"] txInfo' - let mint :: Term s PValue + let mint :: Term _ PValue mint = txInfo.mint gatCs <- plet $ pconstant gatCs' diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index f063b6d..f8a9357 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -24,6 +24,10 @@ module Agora.Proposal ( PProposalVotes (..), PProposalTag (..), PResultTag (..), + + -- * Scripts + proposalValidator, + proposalPolicy, ) where import GHC.Generics qualified as GHC @@ -31,19 +35,25 @@ import Generics.SOP (Generic, I (I)) import Plutarch.Api.V1 ( PDatumHash, PMap, + PMintingPolicy, PPubKeyHash, + PValidator, PValidatorHash, ) import Plutarch.DataRepr ( + DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (PIsDataReprInstances), ) import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash) import PlutusTx qualified +import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- import Agora.SafeMoney (GTTag) +import Plutarch (popaque) +import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..)) import Plutarch.SafeMoney (PDiscrete, Tagged) -------------------------------------------------------------------------------- @@ -57,7 +67,7 @@ import Plutarch.SafeMoney (PDiscrete, Tagged) @ -} newtype ResultTag = ResultTag {getResultTag :: Integer} - deriving stock (Eq, Show) + deriving stock (Eq, Show, Ord) deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) {- | The "status" of the proposal. This is only useful for state transitions, @@ -123,7 +133,7 @@ PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)] @[('ResultTag' 0, n), ('ResultTag' 1, m)]@ -} newtype ProposalVotes = ProposalVotes - { getProposalVotes :: [(ResultTag, Integer)] + { getProposalVotes :: AssocMap.Map ResultTag Integer } deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) deriving stock (Eq, Show, GHC.Generic) @@ -163,10 +173,22 @@ data Proposal = Proposal newtype PResultTag (s :: S) = PResultTag (Term s PInteger) deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PResultTag PInteger) +instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag +deriving via + (DerivePConstantViaNewtype ResultTag PResultTag PInteger) + instance + (PConstant ResultTag) + -- | Plutarch-level version of 'PProposalTag'. newtype PProposalTag (s :: S) = PProposalTag (Term s PInteger) deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTag PInteger) +instance PUnsafeLiftDecl PProposalTag where type PLifted PProposalTag = ProposalTag +deriving via + (DerivePConstantViaNewtype ProposalTag PProposalTag PInteger) + instance + (PConstant ProposalTag) + -- | Plutarch-level version of 'ProposalStatus'. data PProposalStatus (s :: S) = -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'. @@ -181,6 +203,9 @@ data PProposalStatus (s :: S) (PlutusType, PIsData) via PIsDataReprInstances PProposalStatus +instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus +deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstant ProposalStatus) + -- | Plutarch-level version of 'ProposalThresholds'. newtype PProposalThresholds (s :: S) = PProposalThresholds { getProposalThresholds :: @@ -200,11 +225,20 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PProposalThresholds) +instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds +deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstant ProposalThresholds) + -- | Plutarch-level version of 'ProposalVotes'. newtype PProposalVotes (s :: S) = PProposalVotes (Term s (PMap PResultTag PInteger)) deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap PResultTag PInteger)) +instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes +deriving via + (DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap PResultTag PInteger)) + instance + (PConstant ProposalVotes) + -- | Plutarch-level version of 'ProposalDatum'. newtype PProposalDatum (s :: S) = PProposalDatum { getProposalDatum :: @@ -225,3 +259,20 @@ newtype PProposalDatum (s :: S) = PProposalDatum deriving (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PProposalDatum) + +instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum +deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum) + +-------------------------------------------------------------------------------- + +-- | Policy for Proposals. +proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy +proposalPolicy _ = + plam $ \_redeemer _ctx' -> P.do + popaque (pconstant ()) + +-- | Validator for Proposals. +proposalValidator :: Proposal -> ClosedTerm PValidator +proposalValidator _ = + plam $ \_datum _redeemer _ctx' -> P.do + popaque (pconstant ()) diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 814b2f2..7a90877 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -63,11 +63,11 @@ import Agora.Utils ( anyOutput, paddValue, passert, - passetClassValueOf', pfindTxInByTxOutRef, pgeqByClass, pgeqByClass', pgeqBySymbol, + pnotNull, psingletonValue, psymbolValueOf, ptxSignedBy, @@ -89,27 +89,72 @@ newtype Stake = Stake -- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code. } --- | Haskell-level redeemer for Stake scripts. -data StakeRedeemer - = -- | Deposit or withdraw a discrete amount of the staked governance token. - DepositWithdraw (Tagged GTTag Integer) - | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. - Destroy - deriving stock (Show, GHC.Generic) +{- | A lock placed on a Stake datum in order to prevent + depositing and withdrawing when votes are in place. -PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)] + NOTE: Due to retracting votes always being possible, + this lock will only lock with contention on the proposal. + FIXME: Contention on Proposals could create contention + on voting which in turn creates contention on stakers. + + Vaguely this is the dependency graph for this locking + interaction. Both the stake vaalidator and the proposal + validator are only able to check for eachother through + the datum belonging to the ST: + + @ + ┌─────────────────┐ ┌────────────────────┐ + │ Stake Validator ├─┐ │ Proposal Validator │ + └────────┬────────┘ │ └──────┬─────┬───────┘ + │ │ │ │ + │ ┌─┼────────┘ │ + ▼ │ │ ▼ + ┌──────────────┐ │ │ ┌─────────────────┐ + │ Stake Policy │◄─┘ └►│ Proposal Policy │ + └──────────────┘ └─────────────────┘ + @ +-} data ProposalLock = ProposalLock { vote :: ResultTag -- ^ What was voted on. This allows retracting votes to -- undo their vote. , proposalTag :: ProposalTag - -- ^ Identifies the proposal. + -- ^ Identifies the proposal. See 'ProposalTag' for further + -- comments on its significance. } deriving stock (Show, GHC.Generic) PlutusTx.makeIsDataIndexed ''ProposalLock [('ProposalLock, 0)] +-- | Haskell-level redeemer for Stake scripts. +data StakeRedeemer + = -- | Deposit or withdraw a discrete amount of the staked governance token. + -- Stake must be unlocked. + DepositWithdraw (Tagged GTTag Integer) + | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. + -- Stake must be unlocked. + Destroy + | -- | Permit a Vote to be added onto a 'Proposal'. + -- This also adds a lock to the 'lockedBy' field. See 'ProposalLock'. + -- This needs to be done in sync with casting a vote, otherwise + -- it's possible for a lock to be permanently placed on the stake, + -- and then the funds are lost. + PermitVote ProposalLock + | -- | Retract a vote, removing it from the 'lockedBy' field. See 'ProposalLock'. + -- This action checks for permission of the 'Proposal'. Finished proposals are + -- always allowed to be retracted with. + RetractVotes [ProposalLock] + deriving stock (Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed + ''StakeRedeemer + [ ('DepositWithdraw, 0) + , ('Destroy, 1) + , ('PermitVote, 2) + , ('RetractVotes, 3) + ] + -- | Haskell-level datum for Stake scripts. data StakeDatum = StakeDatum { stakedAmount :: Tagged GTTag Integer @@ -158,6 +203,8 @@ data PStakeRedeemer (s :: S) PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag])) | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. PDestroy (Term s (PDataRecord '[])) + | PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock])) + | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList PProposalLock])) deriving stock (GHC.Generic) deriving anyclass (Generic) deriving anyclass (PIsDataRepr) @@ -204,10 +251,7 @@ deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PCons -------------------------------------------------------------------------------- -- | Policy for Stake state threads. -stakePolicy :: - forall (s :: S). - Stake -> - Term s PMintingPolicy +stakePolicy :: Stake -> ClosedTerm PMintingPolicy stakePolicy stake = plam $ \_redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' @@ -300,10 +344,7 @@ stakePolicy stake = -------------------------------------------------------------------------------- -- | Validator intended for Stake UTXOs to live in. -stakeValidator :: - forall (s :: S). - Stake -> - Term s PValidator +stakeValidator :: Stake -> ClosedTerm PValidator stakeValidator stake = plam $ \datum redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' @@ -322,28 +363,48 @@ stakeValidator stake = PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfo' ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo + + -- Whether the owner signs this transaction or not. ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner + stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake) mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfo.mint spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfo' + -- Is the stake currently locked? + stakeIsLocked <- plet $ stakeLocked # stakeDatum' + pmatch stakeRedeemer $ \case PDestroy _ -> P.do passert "ST at inputs must be 1" $ spentST #== 1 passert "Should burn ST" $ mintedST #== -1 - passert "Stake unlocked" $ - pnot #$ stakeLocked # stakeDatum' + passert "Stake unlocked" $ pnot # stakeIsLocked passert "Owner signs this transaction" ownerSignsTransaction popaque (pconstant ()) + -------------------------------------------------------------------------- + PRetractVotes _ -> P.do + passert + "Owner signs this transaction" + ownerSignsTransaction + -- TODO: check proposal constraints + popaque (pconstant ()) + -------------------------------------------------------------------------- + PPermitVote _ -> P.do + passert + "Owner signs this transaction" + ownerSignsTransaction + -- TODO: check proposal constraints + popaque (pconstant ()) + -------------------------------------------------------------------------- PDepositWithdraw r -> P.do passert "ST at inputs must be 1" $ spentST #== 1 passert "Stake unlocked" $ - pnot #$ stakeLocked # stakeDatum' + pnot #$ stakeIsLocked passert "Owner signs this transaction" ownerSignsTransaction @@ -365,9 +426,6 @@ stakeValidator stake = ] let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta) - ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # value) - ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # expectedValue) - -- TODO: Same as above. This is quite inefficient now, as it does two lookups -- instead of a more efficient single pass, -- but it doesn't really matter for this. At least it's correct. @@ -401,5 +459,4 @@ stakeLocked = phoistAcyclic $ plam $ \stakeDatum -> let locks :: Term _ (PBuiltinList (PAsData PProposalLock)) locks = pfield @"lockedBy" # stakeDatum - in -- 'pnotNull' ? - pelimList (\_ _ -> pcon PTrue) (pcon PFalse) locks + in pnotNull # locks diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index df11f65..9cbf6da 100644 --- a/agora/Agora/Treasury.hs +++ b/agora/Agora/Treasury.hs @@ -28,10 +28,8 @@ import Agora.Utils (passert) do so in a valid manner. -} treasuryV :: - forall {s :: S}. CurrencySymbol -> - Term - s + ClosedTerm ( PAsData PTreasuryDatum :--> PAsData PTreasuryRedeemer :--> PAsData PScriptContext @@ -50,7 +48,7 @@ treasuryV gatCs' = plam $ \_d r ctx' -> P.do -- Get the minted value from txInfo. txInfo' <- plet ctx.txInfo txInfo <- pletFields @'["mint"] txInfo' - let mint :: Term s PValue + let mint :: Term _ PValue mint = txInfo.mint gatCs <- plet $ pconstant gatCs' diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 2f875b0..5ac101c 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -25,6 +25,7 @@ module Agora.Utils ( pfindTxInByTxOutRef, psingletonValue, pfindMap, + pnotNull, -- * Functions which should (probably) not be upstreamed anyOutput, @@ -281,6 +282,10 @@ pfindTxInByTxOutRef = phoistAcyclic $ ) #$ (pfield @"inputs" # txInfo) +-- | True if a list is not empty. +pnotNull :: forall list a. PIsListLike list a => Term _ (list a :--> PBool) +pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse) + -------------------------------------------------------------------------------- {- Functions which should (probably) not be upstreamed All of these functions are quite inefficient. From 51b1e726fc5cf790454bc46ce70f9d8ea4955a56 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 4 Apr 2022 13:37:06 +0200 Subject: [PATCH 4/6] fix typo, add stubs on Governor --- agora/Agora/Governor.hs | 29 ++++++++++++++++++++++++++++- agora/Agora/Stake.hs | 2 +- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/agora/Agora/Governor.hs b/agora/Agora/Governor.hs index 33584e1..34777ad 100644 --- a/agora/Agora/Governor.hs +++ b/agora/Agora/Governor.hs @@ -5,9 +5,22 @@ Description: Governor entity scripts acting as authority of entire system. Governor entity scripts acting as authority of entire system. -} -module Agora.Governor (GovernorDatum (..), GovernorRedeemer (..), Governor (..)) where +module Agora.Governor ( + -- * Haskell-land + GovernorDatum (..), + GovernorRedeemer (..), + Governor (..), + + -- * Plutarch-land + + -- * Scripts + governorPolicy, + governorValidator, +) where import Agora.Proposal (ProposalThresholds) +import Plutarch (popaque) +import Plutarch.Api.V1 (PMintingPolicy, PValidator) -- | Datum for the Governor script. newtype GovernorDatum = GovernorDatum @@ -31,3 +44,17 @@ data GovernorRedeemer -- | Parameters for creating Governor scripts. data Governor = Governor + +-------------------------------------------------------------------------------- + +-- | Policy for Governors. +governorPolicy :: Governor -> ClosedTerm PMintingPolicy +governorPolicy _ = + plam $ \_redeemer _ctx' -> P.do + popaque (pconstant ()) + +-- | Validator for Governors. +governorValidator :: Governor -> ClosedTerm PValidator +governorValidator _ = + plam $ \_datum _redeemer _ctx' -> P.do + popaque (pconstant ()) diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 7a90877..bb7f471 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -99,7 +99,7 @@ newtype Stake = Stake on voting which in turn creates contention on stakers. Vaguely this is the dependency graph for this locking - interaction. Both the stake vaalidator and the proposal + interaction. Both the stake validator and the proposal validator are only able to check for eachother through the datum belonging to the ST: From 809480b351a402672b4afdba17636973d203a6a2 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 4 Apr 2022 16:03:25 +0200 Subject: [PATCH 5/6] `PTryFrom` comment, README badge --- README.md | 3 ++- agora/Agora/Stake.hs | 2 +- agora/Agora/Treasury.hs | 26 +++++++++++++++----------- 3 files changed, 18 insertions(+), 13 deletions(-) diff --git a/README.md b/README.md index a0f2905..77cf520 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,5 @@ -# Agora +# Agora :classical_building: +![integrate.yaml badge](https://github.com/Liqwid-Labs/agora/actions/workflows/integrate.yaml/badge.svg?branch=master) Agora is a set of Plutus scripts that compose together to form a governance system. diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index bb7f471..9ee7c3c 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -351,7 +351,7 @@ stakeValidator stake = txInfo' <- plet ctx.txInfo txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo' - -- Coercion is safe in that if coercion fails we crash hard. + -- TODO: Use PTryFrom let stakeRedeemer :: Term _ PStakeRedeemer stakeRedeemer = pfromData $ punsafeCoerce redeemer stakeDatum' :: Term _ PStakeDatum diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index 9cbf6da..71eee81 100644 --- a/agora/Agora/Treasury.hs +++ b/agora/Agora/Treasury.hs @@ -10,7 +10,7 @@ module Agora.Treasury (module Agora.Treasury) where import GHC.Generics qualified as GHC import Generics.SOP -import Plutarch.Api.V1.Contexts (PScriptContext, PScriptPurpose (PMinting)) +import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting)) import Plutarch.Api.V1.Value (PCurrencySymbol, PValue) import Plutarch.DataRepr ( PDataFields, @@ -23,19 +23,23 @@ import Plutus.V1.Ledger.Value (CurrencySymbol) import Agora.AuthorityToken (singleAuthorityTokenBurned) import Agora.Utils (passert) +import Plutarch (popaque) +import Plutarch.Api.V1 (PValidator) +import Plutarch.Unsafe (punsafeCoerce) {- | Validator ensuring that transactions consuming the treasury do so in a valid manner. -} -treasuryV :: +treasuryValidator :: CurrencySymbol -> - ClosedTerm - ( PAsData PTreasuryDatum - :--> PAsData PTreasuryRedeemer - :--> PAsData PScriptContext - :--> PUnit - ) -treasuryV gatCs' = plam $ \_d r ctx' -> P.do + ClosedTerm PValidator +treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do + -- TODO: Use PTryFrom + let treasuryRedeemer :: Term _ (PAsData PTreasuryRedeemer) + treasuryRedeemer = punsafeCoerce redeemer + _treasuryDatum' :: Term _ (PAsData PTreasuryDatum) + _treasuryDatum' = punsafeCoerce datum + -- plet required fields from script context. ctx <- pletFields @["txInfo", "purpose"] ctx' @@ -43,7 +47,7 @@ treasuryV gatCs' = plam $ \_d r ctx' -> P.do PMinting _ <- pmatch ctx.purpose -- Ensure redeemer type is valid. - PAlterTreasuryParams _ <- pmatch $ pfromData r + PAlterTreasuryParams _ <- pmatch $ pfromData treasuryRedeemer -- Get the minted value from txInfo. txInfo' <- plet ctx.txInfo @@ -55,7 +59,7 @@ treasuryV gatCs' = plam $ \_d r ctx' -> P.do passert "singleAuthorityTokenBurned" $ singleAuthorityTokenBurned gatCs txInfo' mint - pconstant () + popaque $ pconstant () {- | Plutarch level type representing datum of the treasury. Contains: From ae7191e0ac8d73e0fb420bb2a98441c75640ceef Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 5 Apr 2022 12:03:30 +0200 Subject: [PATCH 6/6] apply Jack's PR suggestions --- agora/Agora/Effect.hs | 23 ++++++++++++++++++----- agora/Agora/Governor.hs | 6 ++++-- agora/Agora/Proposal.hs | 6 +++++- agora/Agora/SafeMoney.hs | 2 +- agora/Agora/Stake.hs | 7 ++++--- agora/Agora/Treasury.hs | 2 +- 6 files changed, 33 insertions(+), 13 deletions(-) diff --git a/agora/Agora/Effect.hs b/agora/Agora/Effect.hs index a4e3782..e8c3794 100644 --- a/agora/Agora/Effect.hs +++ b/agora/Agora/Effect.hs @@ -5,11 +5,15 @@ Description: Helpers for constructing effects Helpers for constructing effects. -} -module Agora.Effect (makeEffect) where +module Agora.Effect ( + makeEffect, + noopEffect, +) where import Agora.AuthorityToken (singleAuthorityTokenBurned) import Agora.Utils (passert) -import Plutarch.Api.V1 (PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue) +import Plutarch (popaque) +import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue) import Plutarch.Internal (punsafeCoerce) import Plutarch.Monadic qualified as P import Plutus.V1.Ledger.Value (CurrencySymbol) @@ -26,13 +30,14 @@ makeEffect :: forall (datum :: PType). PIsData datum => CurrencySymbol -> - (forall (s :: S). Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) -> + (forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) -> ClosedTerm PValidator makeEffect gatCs' f = plam $ \datum _redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo' <- plet ctx.txInfo + -- TODO: Use PTryFrom let datum' :: Term _ datum datum' = pfromData $ punsafeCoerce datum @@ -45,8 +50,16 @@ makeEffect gatCs' f = gatCs <- plet $ pconstant gatCs' - passert "singleAuthorityTokenBurned" $ singleAuthorityTokenBurned gatCs txInfo' mint + passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint - f datum' txOutRef' txInfo' + f gatCs datum' txOutRef' txInfo' -------------------------------------------------------------------------------- + +-- | Dummy effect which can only burn its GAT. +noopEffect :: CurrencySymbol -> ClosedTerm PValidator +noopEffect = + ( `makeEffect` + \_gatCs (_datum :: Term _ PUnit) _txOutRef _txInfo -> P.do + popaque (pconstant ()) + ) diff --git a/agora/Agora/Governor.hs b/agora/Agora/Governor.hs index 34777ad..db24681 100644 --- a/agora/Agora/Governor.hs +++ b/agora/Agora/Governor.hs @@ -18,14 +18,16 @@ module Agora.Governor ( governorValidator, ) where -import Agora.Proposal (ProposalThresholds) +import Agora.Proposal (ProposalTag, ProposalThresholds) import Plutarch (popaque) import Plutarch.Api.V1 (PMintingPolicy, PValidator) -- | Datum for the Governor script. -newtype GovernorDatum = GovernorDatum +data GovernorDatum = GovernorDatum { proposalThresholds :: ProposalThresholds -- ^ Gets copied over upon creation of a 'Agora.Proposal.ProposalDatum'. + , nextProposalTag :: ProposalTag + -- ^ What tag the next proposal will get upon creating. } {- | Redeemer for Governor script. The governor has two primary diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index f8a9357..a7df633 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -158,7 +158,11 @@ data ProposalDatum = ProposalDatum PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)] --- | Identifies a Proposal, issued upon creation of a proposal. +{- | Identifies a Proposal, issued upon creation of a proposal. + In practice, this number starts at zero, and increments by one + for each proposal. The 100th proposal will be @'ProposalTag' 99@. + This counter lives in the 'Governor', see 'nextProposalTag'. +-} newtype ProposalTag = ProposalTag {proposalTag :: Integer} deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) deriving stock (Eq, Show, GHC.Generic) diff --git a/agora/Agora/SafeMoney.hs b/agora/Agora/SafeMoney.hs index 8791ff9..f94ae8d 100644 --- a/agora/Agora/SafeMoney.hs +++ b/agora/Agora/SafeMoney.hs @@ -3,7 +3,7 @@ Module : Agora.SafeMoney Maintainer : emi@haskell.fyi Description: Tags and bonuses for Plutarch.SafeMoney. -Tags and bonuses for "Plutarch.SafeMoney". +Tags and extras for "Plutarch.SafeMoney". -} module Agora.SafeMoney ( ADATag, diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 9ee7c3c..234510c 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -100,7 +100,7 @@ newtype Stake = Stake Vaguely this is the dependency graph for this locking interaction. Both the stake validator and the proposal - validator are only able to check for eachother through + validator are only able to check for one another through the datum belonging to the ST: @ @@ -143,7 +143,8 @@ data StakeRedeemer PermitVote ProposalLock | -- | Retract a vote, removing it from the 'lockedBy' field. See 'ProposalLock'. -- This action checks for permission of the 'Proposal'. Finished proposals are - -- always allowed to be retracted with. + -- always allowed to have votes retracted and won't affect the Proposal datum, + -- allowing 'Stake's to be unlocked. RetractVotes [ProposalLock] deriving stock (Show, GHC.Generic) @@ -166,7 +167,7 @@ data StakeDatum = StakeDatum -- 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 + -- ^ The current proposals locking this stake. This field must be empty -- for the stake to be usable for deposits and withdrawals. } deriving stock (Show, GHC.Generic) diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index 71eee81..3f48a1f 100644 --- a/agora/Agora/Treasury.hs +++ b/agora/Agora/Treasury.hs @@ -57,7 +57,7 @@ treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do gatCs <- plet $ pconstant gatCs' - passert "singleAuthorityTokenBurned" $ singleAuthorityTokenBurned gatCs txInfo' mint + passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint popaque $ pconstant ()