Merge pull request #31 from Liqwid-Labs/jhodgdev/treasury

jhodgdev/treasury

.gitignore

@@ -21,3 +21,7 @@ TAGS
 # direnv files
 .envrc
 .direnv/
+
+# Haddock files and Hoogle databases 
+haddock 
+hoo

Makefile

@@ -1,6 +1,6 @@
 SHELL := /usr/bin/env bash
 
-.PHONY: hoogle format usage
+.PHONY: hoogle format haddock usage
 
 usage:
 	@echo "usage: make <command> [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

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

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

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.

flake.lock

@@ -440,6 +440,8 @@
         "hpc-coveralls": "hpc-coveralls",
         "nix-tools": "nix-tools",
         "nixpkgs": [
+          "plutarch",
+          "haskell-nix",
           "nixpkgs-2111"
         ],
         "nixpkgs-2003": "nixpkgs-2003",

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 ())

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

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 $

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

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

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)