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-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index 85b95ac..08bd0e1 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" @@ -94,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 @@ -122,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 @@ -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. } @@ -154,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} @@ -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-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.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/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..e8c3794 100644 --- a/agora/Agora/Effect.hs +++ b/agora/Agora/Effect.hs @@ -5,33 +5,61 @@ Description: Helpers for constructing effects Helpers for constructing effects. -} -module Agora.Effect (makeEffect) where +module Agora.Effect ( + makeEffect, + noopEffect, +) where -import Plutarch.Api.V1 (PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator) +import Agora.AuthorityToken (singleAuthorityTokenBurned) +import Agora.Utils (passert) +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) -------------------------------------------------------------------------------- --- | 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). + forall (datum :: PType). PIsData datum => - (Term s datum -> Term s PTxOutRef -> Term s PTxInfo -> Term s POpaque) -> - Term s PValidator -makeEffect f = + CurrencySymbol -> + (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 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 _ PValue + mint = txInfo.mint - f datum' txOutRef' txInfo' + gatCs <- plet $ pconstant gatCs' + + passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint + + 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 33584e1..db24681 100644 --- a/agora/Agora/Governor.hs +++ b/agora/Agora/Governor.hs @@ -5,14 +5,29 @@ 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 (..), -import Agora.Proposal (ProposalThresholds) + -- * Plutarch-land + + -- * Scripts + governorPolicy, + governorValidator, +) where + +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 @@ -31,3 +46,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/Proposal.hs b/agora/Agora/Proposal.hs index ddad144..a7df633 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -14,11 +14,20 @@ module Agora.Proposal ( ProposalStatus (..), ProposalThresholds (..), ProposalVotes (..), + ProposalTag (..), ResultTag (..), -- * Plutarch-land PProposalDatum (..), + PProposalStatus (..), + PProposalThresholds (..), + PProposalVotes (..), + PProposalTag (..), PResultTag (..), + + -- * Scripts + proposalValidator, + proposalPolicy, ) where import GHC.Generics qualified as GHC @@ -26,19 +35,26 @@ 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 (Discrete, GTTag, PDiscrete) +import Agora.SafeMoney (GTTag) +import Plutarch (popaque) +import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..)) +import Plutarch.SafeMoney (PDiscrete, Tagged) -------------------------------------------------------------------------------- -- Haskell-land @@ -51,7 +67,7 @@ import Agora.SafeMoney (Discrete, GTTag, PDiscrete) @ -} 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, @@ -84,6 +100,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)] @@ -92,14 +109,15 @@ 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') } + deriving stock (Eq, Show, GHC.Generic) PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)] @@ -115,9 +133,10 @@ 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) -- | Haskell-level datum for Proposal scripts. data ProposalDatum = ProposalDatum @@ -135,9 +154,19 @@ 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. + 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) + -- | Parameters that identify the Proposal validator script. data Proposal = Proposal @@ -148,6 +177,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'. @@ -162,6 +207,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 :: @@ -181,11 +229,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 :: @@ -206,3 +263,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/SafeMoney.hs b/agora/Agora/SafeMoney.hs index d8c3da0..f94ae8d 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 extras 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..234510c 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, @@ -22,7 +24,7 @@ module Agora.Stake ( import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) -import Prelude +import Prelude hiding (Num (..)) -------------------------------------------------------------------------------- @@ -43,76 +45,148 @@ 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.SafeMoney ( - AssetClassRef (..), - Discrete, - GTTag, - PDiscrete, - paddDiscrete, - pdiscreteValue, - pgeqDiscrete, - pzeroDiscrete, - ) +import Agora.Proposal (PProposalTag, PResultTag, ProposalTag (..), ResultTag (..)) +import Agora.SafeMoney (GTTag) import Agora.Utils ( anyInput, anyOutput, paddValue, passert, - passetClassValueOf', pfindTxInByTxOutRef, pgeqByClass, pgeqByClass', pgeqBySymbol, + pnotNull, psingletonValue, psymbolValueOf, 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 +{- | A lock placed on a Stake datum in order to prevent + depositing and withdrawing when votes are in place. + + 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 validator and the proposal + validator are only able to check for one another 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. 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. - DepositWithdraw (Discrete GTTag) + -- 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 have votes retracted and won't affect the Proposal datum, + -- allowing 'Stake's to be unlocked. + RetractVotes [ProposalLock] deriving stock (Show, GHC.Generic) -PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)] +PlutusTx.makeIsDataIndexed + ''StakeRedeemer + [ ('DepositWithdraw, 0) + , ('Destroy, 1) + , ('PermitVote, 2) + , ('RetractVotes, 3) + ] + +-- | 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 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) + +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) @@ -121,14 +195,46 @@ 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) +instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum +deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum) -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 '[])) + | PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock])) + | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList PProposalLock])) + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (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 @@ -146,10 +252,7 @@ PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)] -------------------------------------------------------------------------------- -- | 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' @@ -223,7 +326,7 @@ stakePolicy stake = foldr1 (#&&) [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue - , pgeqByClass' stake.gtClassRef.getAssetClass + , pgeqByClass' (untag stake.gtClassRef) # value # expectedValue , pgeqByClass @@ -242,17 +345,14 @@ 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' 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 @@ -264,28 +364,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 @@ -300,16 +420,13 @@ 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) - -- 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. @@ -317,7 +434,7 @@ stakeValidator stake = foldr1 (#&&) [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue - , pgeqByClass' stake.gtClassRef.getAssetClass + , pgeqByClass' (untag stake.gtClassRef) # value # expectedValue , pgeqBySymbol @@ -340,6 +457,7 @@ 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 # locks diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index ff4ab36..3f48a1f 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, @@ -21,23 +21,25 @@ import Plutus.V1.Ledger.Value (CurrencySymbol) -------------------------------------------------------------------------------- -import Agora.AuthorityToken (authorityTokensValidIn) -import Agora.Utils (allInputs, passert, psymbolValueOf) +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 :: - forall {s :: S}. +treasuryValidator :: CurrencySymbol -> - Term - s - ( PAsData PTreasuryDatum - :--> PAsData PTreasuryRedeemer - :--> PAsData PScriptContext - :--> PUnit - ) -treasuryV cs = 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' @@ -45,25 +47,19 @@ treasuryV cs = 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 txInfo <- pletFields @'["mint"] txInfo' - let mint :: Term s PValue + let mint :: Term _ 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 "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint - pconstant () + popaque $ pconstant () {- | Plutarch level type representing datum of the treasury. Contains: 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. diff --git a/flake.lock b/flake.lock index 039aca4..73e7d0d 100644 --- a/flake.lock +++ b/flake.lock @@ -939,8 +939,6 @@ "hpc-coveralls": "hpc-coveralls_3", "nix-tools": "nix-tools_3", "nixpkgs": [ - "plutarch", - "haskell-nix", "nixpkgs-2111" ], "nixpkgs-2003": "nixpkgs-2003_3", @@ -1623,17 +1621,17 @@ "validity": "validity" }, "locked": { - "lastModified": 1648578429, - "narHash": "sha256-nEB6ujvX5aSpSk1EJ7/tAxW2lxB/eWXzJmyj7qyInpQ=", + "lastModified": 1648639396, + "narHash": "sha256-pAkEsIDXJckVYufVPUzD/4sq4/uE7iyV0IR2BuLhZjY=", "owner": "peter-mlabs", "repo": "plutarch", - "rev": "b4e71dc0f685d0d0c325eabbaac8c5b3352bfcf8", + "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 73a36e2..9f5a7a7 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"; @@ -25,7 +27,6 @@ inputs.apropos.inputs.nixpkgs.follows = "plutarch/haskell-nix/nixpkgs-unstable"; - outputs = inputs@{ self, nixpkgs, haskell-nix, plutarch, ... }: let supportedSystems = with nixpkgs.lib.systems.supported; @@ -57,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; @@ -98,6 +104,7 @@ ps.apropos ps.plutarch-extra ps.plutarch-numeric + ps.plutarch-safemoney ps.plutarch-test ps.apropos ];