diff --git a/.gitignore b/.gitignore index 5ae1889..a2329d2 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,7 @@ TAGS # direnv files .envrc .direnv/ + +# Haddock files and Hoogle databases +haddock +hoo diff --git a/Makefile b/Makefile index 35cd401..feb2a3d 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ SHELL := /usr/bin/env bash -.PHONY: hoogle format usage +.PHONY: hoogle format haddock usage usage: @echo "usage: make [OPTIONS]" @@ -8,13 +8,18 @@ usage: @echo "Available commands:" @echo " hoogle -- Start local hoogle" @echo " format -- Format the project" + @echo " haddock -- Generate Haddock docs for project" -HOOGLE_PORT=8081 -hoogle: - hoogle server --local --port $(HOOGLE_PORT) > /dev/null & +hoogle: + hoogle generate --local=haddock --database=hoo/local.hoo + hoogle server --local -p 8081 >> /dev/null & + hoogle server --local --database=hoo/local.hoo -p 8082 >> /dev/null & FORMAT_EXTENSIONS := -o -XQuasiQuotes -o -XTemplateHaskell -o -XTypeApplications -o -XImportQualifiedPost -o -XPatternSynonyms -o -XOverloadedRecordDot format: find -name '*.hs' -not -path './dist-*/*' | xargs fourmolu $(FORMAT_EXTENSIONS) -m inplace git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.nix' | xargs nixfmt git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.cabal' | xargs cabal-fmt -i + +haddock: + cabal haddock --haddock-html --haddock-hoogle --builddir=haddock diff --git a/agora.cabal b/agora.cabal index 1a68b80..3d8cdf0 100644 --- a/agora.cabal +++ b/agora.cabal @@ -75,10 +75,10 @@ common lang TypeFamilies TypeOperators TypeSynonymInstances + UndecidableInstances ViewPatterns OverloadedRecordDot QualifiedDo - UndecidableInstances default-language: Haskell2010 @@ -119,9 +119,15 @@ library Agora.SafeMoney Agora.SafeMoney.QQ Agora.Stake + Agora.Treasury Agora.Voting - other-modules: Agora.Utils + other-modules: + Agora.Utils + Agora.Utils.Value + Plutarch.Api.V1.These + Plutarch.These + hs-source-dirs: src library pprelude diff --git a/bench.csv b/bench.csv index a467473..ef76a58 100644 --- a/bench.csv +++ b/bench.csv @@ -1,4 +1,4 @@ name,cpu,mem,size -full_scripts:authorityTokenPolicy,1399431,4800,421 +full_scripts:authorityTokenPolicy,1756707,6000,841 full_scripts:stakePolicy,3751498,12700,1610 full_scripts:stakeValidator,3126265,10600,1500 diff --git a/docs/tech-design/treasury.md b/docs/tech-design/treasury.md index abd977a..8d3993b 100644 --- a/docs/tech-design/treasury.md +++ b/docs/tech-design/treasury.md @@ -2,7 +2,7 @@ | Specification | Implementation | Last revision | |:-----------:|:--------------:|:-------------:| -| WIP | WIP | v0.1 2022-02-07 | +| Draft | WIP | v0.1 2022-03-04 | --- @@ -12,7 +12,7 @@ - [Jack Hodgkinson] -**Implementation ownership:** _unassigned_ +**Implementation ownership:** [Jack Hodgkinson] [Jack Hodgkinson]: https://github.com/jhodgdev @@ -20,7 +20,8 @@ **Current Status**: -Initial conceptual draft. Requires review from [Emily Martins]. +- Conceptual draft agreed upon. +- Implementation incomplete; documentation subject to change. --- @@ -46,3 +47,37 @@ The treasury will further be the initial holder of all a governance system's GT. 3. How much do they receive in their reward? are all, naturally, protocol-specific. A simple method for creating such a bespoke reward structure is **not** considered in-scope for Agora v1. Agora v1 will offer a simple, prescribed reward structure, that allows the treasury to determine the reward eligibility of a user and allow them to redeem said amount. + +## Script + +The script for an Agora treasury is described in this section. For clarity, all data types and functions are written in _traditional Haskell_, rather than at the Plutarch level. + +### Datum + +```hs +newtype TreasuryDatum = TreasuryDatum + { -- | Currency symbol of the treasury state thread. + stateThread :: CurrencySymbol + } +``` + +### Redeemers + +```hs +newtype TreasuryRedeemer = AlterTreasuryParams +``` + +At the current stage, it is sufficient to allow users to simply grant funds to the treasury, without an explicit redeemer. The only redeemer that is required is `AlterTreasuryParams`, for when the treasury's parameters are subject to change by a proposal effect. + +### Validators + +```hs +treasuryV :: + CurrencySymbol -> + TreasuryDatum -> + TreasuryRedeemer -> + ScriptContext -> + () +``` + +The only redeemer the validator handles at present is `AlterTrParams`. The validator ensures that a valid governance authority token is burned, when a proposal effect is attempting to alter the parameters of the treasury. diff --git a/flake.lock b/flake.lock index 6247424..f5ab6be 100644 --- a/flake.lock +++ b/flake.lock @@ -440,6 +440,8 @@ "hpc-coveralls": "hpc-coveralls", "nix-tools": "nix-tools", "nixpkgs": [ + "plutarch", + "haskell-nix", "nixpkgs-2111" ], "nixpkgs-2003": "nixpkgs-2003", diff --git a/src/Agora/AuthorityToken.hs b/src/Agora/AuthorityToken.hs index 64dcfc7..3a00148 100644 --- a/src/Agora/AuthorityToken.hs +++ b/src/Agora/AuthorityToken.hs @@ -7,16 +7,23 @@ Tokens acting as redeemable proofs of DAO authority. -} module Agora.AuthorityToken ( authorityTokenPolicy, + authorityTokensValidIn, AuthorityToken (..), ) where import Plutarch.Api.V1 ( + PAddress (..), + PCredential (..), + PCurrencySymbol (..), + PMap (..), PScriptContext (..), PScriptPurpose (..), PTxInInfo (..), PTxInfo (..), PTxOut (..), + PValue (..), ) +import Plutarch.Builtin (pforgetData) import Plutarch.List (pfoldr') import Plutarch.Monadic qualified as P import Plutus.V1.Ledger.Value (AssetClass) @@ -25,7 +32,7 @@ import Prelude -------------------------------------------------------------------------------- -import Agora.Utils (passert, passetClassValueOf, passetClassValueOf') +import Agora.Utils (allOutputs, passert, passetClassValueOf, passetClassValueOf', plookup) -------------------------------------------------------------------------------- @@ -42,6 +49,42 @@ newtype AuthorityToken = AuthorityToken -------------------------------------------------------------------------------- +{- | Check that all GATs are valid in a particular TxOut. + How this is checked: an AuthorityToken should never leave + the Effect it was initially sent to, so we simply check that + the script address the token resides in matches the TokenName. + Since the TokenName was tagged upon mint with the Effect script + it was sent to, this is enough to prove validity. + + In other words, check that all assets of a particular currency symbol + are tagged with a TokenName that matches where they live. +-} +authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool) +authorityTokensValidIn = phoistAcyclic $ + plam $ \authorityTokenSym txOut'' -> P.do + PTxOut txOut' <- pmatch txOut'' + txOut <- pletFields @'["address", "value"] $ txOut' + PAddress address <- pmatch txOut.address + PValue value' <- pmatch txOut.value + PMap value <- pmatch value' + pmatch (plookup # pdata authorityTokenSym # value) $ \case + PJust (pfromData -> tokenMap') -> + pmatch (pfield @"credential" # address) $ \case + PPubKeyCredential _ -> + -- GATs should only be sent to Effect validators + pconstant False + PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> P.do + PMap tokenMap <- pmatch tokenMap' + pall + # plam + ( \pair -> + pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred) + ) + # tokenMap + PNothing -> + -- No GATs exist at this output! + pconstant True + -- | Policy given 'AuthorityToken' params. authorityTokenPolicy :: AuthorityToken -> @@ -71,5 +114,13 @@ authorityTokenPolicy params = let mintedATs = passetClassValueOf # ownSymbol # pconstant "" # mintedValue pif (0 #< mintedATs) - (passert "Authority token did not move in minting GATs" tokenMoved (pconstant ())) + ( P.do + passert "Parent token did not move in minting GATs" tokenMoved + passert "All outputs only emit valid GATs" $ + allOutputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum -> + authorityTokensValidIn + # ownSymbol + # txOut + pconstant () + ) (pconstant ()) diff --git a/src/Agora/Treasury.hs b/src/Agora/Treasury.hs new file mode 100644 index 0000000..ff4ab36 --- /dev/null +++ b/src/Agora/Treasury.hs @@ -0,0 +1,100 @@ +{- | +Module: Agora.Treasury +Maintainer: jack@mlabs.city +Description: Treasury scripts. + +Contains the datum, redeemer and validator for a template DAO +treasury. +-} +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.Value (PCurrencySymbol, PValue) +import Plutarch.DataRepr ( + PDataFields, + PIsDataReprInstances (PIsDataReprInstances), + ) +import Plutarch.Monadic qualified as P +import Plutus.V1.Ledger.Value (CurrencySymbol) + +-------------------------------------------------------------------------------- + +import Agora.AuthorityToken (authorityTokensValidIn) +import Agora.Utils (allInputs, passert, psymbolValueOf) + +{- | Validator ensuring that transactions consuming the treasury + do so in a valid manner. +-} +treasuryV :: + forall {s :: S}. + CurrencySymbol -> + Term + s + ( PAsData PTreasuryDatum + :--> PAsData PTreasuryRedeemer + :--> PAsData PScriptContext + :--> PUnit + ) +treasuryV cs = plam $ \_d r ctx' -> P.do + -- plet required fields from script context. + ctx <- pletFields @["txInfo", "purpose"] ctx' + + -- Ensure that script is for burning i.e. minting a negative amount. + PMinting _ <- pmatch ctx.purpose + + -- Ensure redeemer type is valid. + PAlterTreasuryParams _ <- pmatch $ pfromData r + + -- Get the minted value from txInfo. + txInfo' <- plet ctx.txInfo + 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 + + passert "All inputs only have valid GATs" $ + allInputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum -> + authorityTokensValidIn + # pconstant cs + # txOut + + pconstant () + +{- | Plutarch level type representing datum of the treasury. + Contains: + + - @stateThread@ representing the asset class of the + treasury's state thread token. +-} +newtype PTreasuryDatum (s :: S) + = PTreasuryDatum + ( Term + s + ( PDataRecord + '[ "stateThread" ':= PCurrencySymbol + ] + ) + ) + deriving stock (GHC.Generic) + deriving anyclass (Generic, PIsDataRepr) + deriving + (PlutusType, PIsData, PDataFields) + via PIsDataReprInstances PTreasuryDatum + +{- | Plutarch level type representing valid redeemers of the + treasury. +-} +newtype PTreasuryRedeemer (s :: S) + = -- | Alters treasury parameters, subject to the burning of a + -- governance authority token. + PAlterTreasuryParams (Term s (PDataRecord '[])) + deriving stock (GHC.Generic) + deriving anyclass (Generic, PIsDataRepr) + deriving + (PlutusType, PIsData) + via PIsDataReprInstances PTreasuryRedeemer diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs index 124c57b..2afa33a 100644 --- a/src/Agora/Utils.hs +++ b/src/Agora/Utils.hs @@ -25,7 +25,9 @@ module Agora.Utils ( -- * Functions which should (probably) not be upstreamed anyOutput, + allOutputs, anyInput, + allInputs, ) where -------------------------------------------------------------------------------- @@ -256,7 +258,9 @@ pfindTxInByTxOutRef = phoistAcyclic $ #$ (pfield @"inputs" # txInfo) -------------------------------------------------------------------------------- --- Functions which should (probably) not be upstreamed +{- Functions which should (probably) not be upstreamed + All of these functions are quite inefficient. +-} -- | Check if any output matches the predicate. anyOutput :: @@ -280,6 +284,28 @@ anyOutput = phoistAcyclic $ ) # pfromData txInfo.outputs +-- | Check if all outputs match the predicate. +allOutputs :: + forall (datum :: PType) s. + ( PIsData datum + ) => + Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool) +allOutputs = phoistAcyclic $ + plam $ \txInfo' predicate -> P.do + txInfo <- pletFields @'["outputs"] txInfo' + pall + # plam + ( \txOut'' -> P.do + PTxOut txOut' <- pmatch (pfromData txOut'') + txOut <- pletFields @'["value", "datumHash", "address"] txOut' + PDJust dh <- pmatch txOut.datumHash + pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case + PJust datum -> P.do + predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum + PNothing -> pcon PFalse + ) + # pfromData txInfo.outputs + -- | Check if any (resolved) input matches the predicate. anyInput :: forall (datum :: PType) s. @@ -304,6 +330,30 @@ anyInput = phoistAcyclic $ ) # pfromData txInfo.inputs +-- | Check if all (resolved) inputs match the predicate. +allInputs :: + forall (datum :: PType) s. + ( PIsData datum + ) => + Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool) +allInputs = phoistAcyclic $ + plam $ \txInfo' predicate -> P.do + txInfo <- pletFields @'["inputs"] txInfo' + pall + # plam + ( \txInInfo'' -> P.do + PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'') + let txOut'' = pfield @"resolved" # txInInfo' + PTxOut txOut' <- pmatch (pfromData txOut'') + txOut <- pletFields @'["value", "datumHash", "address"] txOut' + PDJust dh <- pmatch txOut.datumHash + pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case + PJust datum -> P.do + predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum + PNothing -> pcon PFalse + ) + # pfromData txInfo.inputs + -- | Create a value with a single asset class. psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) psingletonValue = phoistAcyclic $ diff --git a/src/Agora/Utils/Value.hs b/src/Agora/Utils/Value.hs new file mode 100644 index 0000000..e20bb5b --- /dev/null +++ b/src/Agora/Utils/Value.hs @@ -0,0 +1,93 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Agora.Utils.Value (pgeq, pleq, pgt, plt) where + +import Plutarch.Api.V1.AssocMap (PMap (PMap)) +import Plutarch.Api.V1.These (PTheseData (..)) +import Plutarch.Api.V1.Tuple (ptupleFromBuiltin) +import Plutarch.Api.V1.Value (PCurrencySymbol, PTokenName, PValue) +import Plutarch.Lift (PUnsafeLiftDecl) +import Plutarch.List (pconvertLists) +import Plutarch.Monadic qualified as P + +punionVal :: + Term + s + ( PValue + :--> PValue + :--> PMap + PCurrencySymbol + (PMap PTokenName (PTheseData PInteger PInteger)) + ) +punionVal = undefined + +-- | Determines if a condition is true for all values in a map. +pmapAll :: + (PUnsafeLiftDecl v, PIsData v) => + Term s ((v :--> PBool) :--> PMap k v :--> PBool) +pmapAll = plam $ \f m -> P.do + PMap builtinMap <- pmatch m + + let getV = plam $ \bip -> P.do + let tuple = pfromData $ ptupleFromBuiltin (pdata bip) + pfromData $ pfield @"_1" # tuple + + let vs = pmap # getV # builtinMap + pall # f # vs + +pcheckPred :: + forall {s :: S}. + Term + s + ( (PTheseData PInteger PInteger :--> PBool) + :--> PValue + :--> PValue + :--> PBool + ) +pcheckPred = plam $ \_f _l _r -> P.do + undefined + +-- let inner :: Term s (PMap PTokenName (PTheseData PInteger PInteger) :--> PBool) +-- inner = pmapAll # f +-- pmapAll # inner # (punionVal # l # r) + +pcheckBinRel :: + forall {s :: S}. + Term + s + ( (PInteger :--> PInteger :--> PBool) + :--> PValue + :--> PValue + :--> PBool + ) +pcheckBinRel = plam $ \f l r -> P.do + let unThese :: Term s (PTheseData PInteger PInteger :--> PBool) + unThese = plam $ \k' -> + pmatch k' $ \case + PDThis r -> f # (pfield @"_0" # r) # 0 + PDThat r -> f # 0 # (pfield @"_0" # r) + PDThese r -> f # (pfield @"_0" # r) # (pfield @"_1" # r) + pcheckPred # unThese # l # r + +-- | Establishes if a value is less than or equal to another. +pleq :: Term s (PValue :--> PValue :--> PBool) +pleq = plam $ \v0 v1 -> (pcheckBinRel # pleq') # v0 # v1 + +pleq' :: Term s (PInteger :--> PInteger :--> PBool) +pleq' = plam $ \m n -> m #<= n + +-- | Establishes if a value is strictly less than another. +plt :: Term s (PValue :--> PValue :--> PBool) +plt = plam $ \v0 v1 -> (pcheckBinRel # plt') # v0 # v1 + +plt' :: Term s (PInteger :--> PInteger :--> PBool) +plt' = plam $ \m n -> m #< n + +-- | Establishes if a value is greater than or equal to another. +pgeq :: Term s (PValue :--> PValue :--> PBool) +pgeq = plam $ \v0 v1 -> pnot #$ plt # v0 # v1 + +-- | Establishes if a value is strictly greater than another. +pgt :: Term s (PValue :--> PValue :--> PBool) +pgt = plam $ \v0 v1 -> pnot #$ pleq # v0 # v1 diff --git a/src/Plutarch/Api/V1/These.hs b/src/Plutarch/Api/V1/These.hs new file mode 100644 index 0000000..e1ae1ed --- /dev/null +++ b/src/Plutarch/Api/V1/These.hs @@ -0,0 +1,62 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Plutarch.Api.V1.These (PTheseData (..)) where + +import GHC.Generics qualified as GHC +import Generics.SOP +import Plutarch.DataRepr (PIsDataReprInstances (PIsDataReprInstances)) +import Plutarch.Lift ( + PConstantRepr, + PConstanted, + PLifted, + PUnsafeLiftDecl, + pconstantFromRepr, + pconstantToRepr, + ) +import Plutus.V1.Ledger.Api qualified as Plutus +import PlutusTx.These qualified as PlutusThese + +data PTheseData (a :: PType) (b :: PType) (s :: S) + = PDThis (Term s (PDataRecord '["_0" ':= a])) + | PDThat (Term s (PDataRecord '["_0" ':= b])) + | PDThese (Term s (PDataRecord '["_0" ':= a, "_1" ':= b])) + deriving stock (GHC.Generic) + deriving anyclass (Generic, PIsDataRepr) + deriving + (PlutusType, PIsData) + via PIsDataReprInstances (PTheseData a b) + +instance + ( Plutus.ToData (PLifted a) + , Plutus.ToData (PLifted b) + , Plutus.FromData (PLifted a) + , Plutus.FromData (PLifted b) + , PLift a + , PLift b + ) => + PUnsafeLiftDecl (PTheseData a b) + where + type PLifted (PTheseData a b) = PlutusThese.These (PLifted a) (PLifted b) + +{- TODO: Make PTheseData an instance of PConstant: + https://github.com/Plutonomicon/plutarch/pull/355 +-} + +instance + ( PLifted (PConstanted a) ~ a + , Plutus.ToData b + , Plutus.FromData b + , Plutus.ToData a + , Plutus.FromData a + , PConstant a + , PLifted (PConstanted b) ~ b + , Plutus.FromData b + , Plutus.ToData b + , PConstant b + ) => + PConstant (PlutusThese.These a b) + where + type PConstantRepr (PlutusThese.These a b) = [(Plutus.Data, Plutus.Data)] + type PConstanted (PlutusThese.These a b) = PTheseData (PConstanted a) (PConstanted b) + pconstantToRepr _t = undefined + pconstantFromRepr _t = undefined diff --git a/src/Plutarch/These.hs b/src/Plutarch/These.hs new file mode 100644 index 0000000..f9b225a --- /dev/null +++ b/src/Plutarch/These.hs @@ -0,0 +1,12 @@ +module Plutarch.These (PThese (..)) where + +import GHC.Generics qualified as GHC +import Generics.SOP + +-- | Plutus These type with Scott-encoded representation. +data PThese (a :: PType) (b :: PType) (s :: S) + = PThis (Term s a) + | PThat (Term s b) + | PThese (Term s a) (Term s b) + deriving stock (GHC.Generic) + deriving anyclass (Generic, PlutusType)