Merge branch 'master' into connor/governor

2022-05-11 17:40:38 +08:00 · 2022-05-11 17:40:38 +08:00 · cee0f4a67a
commit cee0f4a67a
parent f121688990 3d414b334a
9 changed files with 421 additions and 24 deletions
--- a/5
+++ b/5
@ -1,7 +1,7 @@
 # This really ought to be `/usr/bin/env bash`, but nix flakes don't like that.
 SHELL := /bin/sh

-.PHONY: hoogle format haddock usage format_nix format_haskell format_check
+.PHONY: hoogle format haddock usage format_nix format_haskell format_check lint

 usage:
 	@echo "usage: make <command> [OPTIONS]"
@ -14,6 +14,7 @@ usage:
 	@echo "  format_haskell -- Format haskell stuff, including source code and cabal files"
 	@echo "  format_nix -- Format *.nix files only"
 	@echo "  format_check -- Check if all haskell stuff have been formatted correctly"
+	@echo "  lint -- Get hlint suggestions for project"

 hoogle:
 	pkill hoogle || true
@ -43,3 +44,5 @@ haddock:
 tag:
 	hasktags -x agora agora-bench agora-test

+lint:
+	hlint agora agora-bench agora-test
--- a/agora-test/Spec.hs
+++ b/agora-test/Spec.hs
@ -1,5 +1,3 @@
--------------------------------------------------------------------------------
-
 import Prelude

 --------------------------------------------------------------------------------
@ -14,6 +12,7 @@ import Spec.Governor qualified as Governor
 import Spec.Model.MultiSig qualified as MultiSig
 import Spec.Proposal qualified as Proposal
 import Spec.Stake qualified as Stake
+import Spec.Treasury qualified as Treasury

 -- | The Agora test suite.
 main :: IO ()
@ -33,6 +32,18 @@ main =
      , testGroup
          "Proposal tests"
          Proposal.tests
+      , testGroup
+          "AuthorityToken tests"
+          AuthorityToken.tests
+      , testGroup
+          "Treasury tests"
+          Treasury.tests
+      , testGroup
+          "AuthorityToken tests"
+          AuthorityToken.tests
+      , testGroup
+          "Governor tests"
+          Governor.tests
      , testGroup
          "Multisig tests"
          [ testGroup
@ -41,10 +52,4 @@ main =
              , MultiSig.genTests
              ]
          ]
-      , testGroup
-          "AuthorityToken tests"
-          AuthorityToken.tests
-      , testGroup
-          "Governor tests"
-          Governor.tests
      ]
--- a/agora-test/Spec/Sample/Shared.hs
+++ b/agora-test/Spec/Sample/Shared.hs
@ -40,8 +40,17 @@ module Spec.Sample.Shared (
  -- ** Authority
  authorityToken,
  authorityTokenSymbol,
+
+  -- ** Treasury
+  treasuryOut,
+  gatTn,
+  gatCs,
+  mockTrEffect,
+  trCredential,
+  wrongEffHash,
 ) where

+import Agora.Effect.NoOp (noOpValidator)
 import Agora.AuthorityToken
 import Agora.Governor (
  Governor (Governor),
@ -66,10 +75,13 @@ import Agora.Proposal (
  ProposalThresholds (..),
 )
 import Agora.Stake (Stake (..))
+import Agora.Treasury (treasuryValidator)
+import Agora.Utils (validatorHashToTokenName)
 import Plutarch.Api.V1 (
  mintingPolicySymbol,
  mkMintingPolicy,
  mkValidator,
+  validatorHash
 )
 import Plutarch.SafeMoney
 import Plutus.V1.Ledger.Address (scriptHashAddress)
@ -82,8 +94,11 @@ import Plutus.V1.Ledger.Api (
  TxOutRef (TxOutRef),
  Value,
 )
-import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
-import Plutus.V1.Ledger.Value (AssetClass)
+import Plutus.V1.Ledger.Contexts (
+  TxOut (..),
+ )
+import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (..))
+import Plutus.V1.Ledger.Value (TokenName, AssetClass)
 import Plutus.V1.Ledger.Value qualified as Value

 --------------------------------------------------------------------------------
@ -163,11 +178,52 @@ defaultProposalThresholds =
    , startVoting = Tagged 10
    }

-minAda :: Value
-minAda = Value.singleton "" "" 10_000_000
-
 authorityToken :: AuthorityToken
 authorityToken = authorityTokenFromGovernor governor

 authorityTokenSymbol :: CurrencySymbol
 authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
+
+------------------------------------------------------------------
+
+treasuryOut :: TxOut
+treasuryOut =
+  TxOut
+    { txOutAddress = Address trCredential Nothing
+    , txOutValue = minAda
+    , txOutDatumHash = Nothing
+    }
+
+{- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol'
+     of a valid governance authority token (GAT).
+-}
+gatCs :: CurrencySymbol
+gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+
+trValidator :: Validator
+trValidator = mkValidator (treasuryValidator gatCs)
+
+-- | `ScriptCredential` used for the dummy treasury validator.
+trCredential :: Credential
+trCredential = ScriptCredential $ validatorHash trValidator
+
+-- | `TokenName` for GAT generated from address of `mockTrEffect`.
+gatTn :: TokenName
+gatTn = validatorHashToTokenName $ validatorHash mockTrEffect
+
+-- | Mock treasury effect script, used for testing.
+mockTrEffect :: Validator
+mockTrEffect = mkValidator $ noOpValidator gatCs
+
+{- | A SHA-256 hash which (in all certainty) should not match the
+     hash of the dummy effect script.
+-}
+wrongEffHash :: ValidatorHash
+wrongEffHash =
+  ValidatorHash
+    "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"
+
+------------------------------------------------------------------
+
+minAda :: Value
+minAda = Value.singleton "" "" 10_000_000
--- a/agora-test/Spec/Sample/Treasury.hs
+++ b/agora-test/Spec/Sample/Treasury.hs
@ -0,0 +1,163 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+{- |
+Module: Spec.Sample.Treasury
+Description: Sample data for `Spec.Treasury`.
+Maintainer: jack@mlabs.city
+
+This module contains sample data, used in the tests written in
+`Spec.Treasury`.
+-}
+module Spec.Sample.Treasury (
+  gatCs,
+  validCtx,
+  treasuryRef,
+  gatTn,
+  walletIn,
+  trCtxGATNameNotAddress,
+) where
+
+import Plutarch.Api.V1 (validatorHash)
+import Plutus.V1.Ledger.Address (Address (..))
+import Plutus.V1.Ledger.Api (
+  BuiltinByteString,
+  Credential (PubKeyCredential),
+  PubKeyHash (PubKeyHash),
+ )
+import Plutus.V1.Ledger.Contexts (
+  ScriptContext (..),
+  ScriptPurpose (Minting),
+  TxInInfo (..),
+  TxInfo (..),
+  TxOut (..),
+  TxOutRef (..),
+ )
+import Plutus.V1.Ledger.Credential (Credential (ScriptCredential))
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Scripts (
+  ValidatorHash (ValidatorHash),
+ )
+import Plutus.V1.Ledger.Value qualified as Value
+import Spec.Sample.Shared (
+  gatCs,
+  gatTn,
+  minAda,
+  mockTrEffect,
+  signer,
+  treasuryOut,
+  wrongEffHash,
+ )
+import Spec.Util (datumPair)
+
+{- | A `ScriptContext` that should be compatible with treasury
+     transactions.
+-}
+validCtx :: ScriptContext
+validCtx =
+  ScriptContext
+    { scriptContextPurpose = Minting gatCs
+    , scriptContextTxInfo =
+        TxInfo
+          { txInfoInputs =
+              [ treasuryIn
+              , effectIn
+              ]
+          , txInfoOutputs =
+              [ treasuryOut
+              ]
+          , -- Ensure sufficient ADA for transaction costs.
+            txInfoFee = Value.singleton "" "" 2 -- 2 ADA.
+          , -- Burn the GAT.
+            txInfoMint = Value.singleton gatCs gatTn (-1)
+          , txInfoDCert = []
+          , txInfoWdrl = []
+          , txInfoValidRange = Interval.always
+          , txInfoSignatories = [signer]
+          , txInfoData =
+              [ datumPair treasuryIn
+              , datumPair treasuryOut
+              , datumPair effectIn
+              ]
+          , txInfoId =
+              "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+          }
+    }
+  where
+    treasuryIn =
+      TxInInfo
+        { txInInfoOutRef = treasuryRef
+        , txInInfoResolved = treasuryOut
+        }
+    effectIn =
+      TxInInfo
+        { txInInfoOutRef = effectRef
+        , txInInfoResolved =
+            TxOut
+              { txOutAddress =
+                  Address (ScriptCredential $ validatorHash mockTrEffect) Nothing
+              , txOutValue =
+                  mconcat
+                    [ Value.singleton gatCs gatTn 1
+                    , minAda
+                    ]
+              , txOutDatumHash = Nothing
+              }
+        }
+
+-- | Reference to treasury output.
+treasuryRef :: TxOutRef
+treasuryRef =
+  TxOutRef
+    "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+    1
+
+-- | Reference to dummy effect output.
+effectRef :: TxOutRef
+effectRef =
+  TxOutRef
+    "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
+    0
+
+-- | Input representing a user wallet with a valid GAT.
+walletIn :: TxInInfo
+walletIn =
+  TxInInfo
+    { txInInfoOutRef =
+        TxOutRef
+          "cf4a8b33dd8e4493187e3339ecc3802d0cc000c947fb5559b7614153947d4e83"
+          0
+    , txInInfoResolved =
+        TxOut
+          { txOutDatumHash = Nothing
+          , txOutValue = Value.singleton gatCs gatTn 1
+          , txOutAddress =
+              Address
+                (PubKeyCredential $ PubKeyHash addressBs)
+                Nothing
+          }
+    }
+
+addressBs :: BuiltinByteString
+(ValidatorHash addressBs) = validatorHash mockTrEffect
+
+trCtxGATNameNotAddress :: ScriptContext
+trCtxGATNameNotAddress =
+  let txInfo = validCtx.scriptContextTxInfo
+      inputs = txInfo.txInfoInputs
+      effectIn = inputs !! 1
+      invalidEff =
+        effectIn
+          { txInInfoResolved =
+              effectIn.txInInfoResolved
+                { txOutAddress = Address (ScriptCredential wrongEffHash) Nothing
+                }
+          }
+   in validCtx
+        { scriptContextTxInfo =
+            txInfo
+              { txInfoInputs =
+                  [ head inputs
+                  , invalidEff
+                  ]
+              }
+        }
--- a/agora-test/Spec/Treasury.hs
+++ b/agora-test/Spec/Treasury.hs
@ -0,0 +1,142 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+{- |
+Module: Spec.Treasury
+Description: Tests for Agora treasury.
+Maintainer: jack@mlabs.city
+
+This module exports `tests`, a list of `TestTree`s, which ensure
+that Agora's treasury component works as desired.
+
+Tests need to fail when:
+
+  1. The reedeemer is of inproper form. TODO: Inquire.
+  2. The script purpose is not minting.
+  3. `singleAuthorityTokenBurned` returns false.
+    a. @n /= -1@ GATs burned.
+    b. An input returns 'False' for 'authorityTokensValidIn'
+      i. A wallet input has a GAT.
+      ii. A script has a GAT, the token name for which does /not/
+          match the script's validator hash.
+-}
+module Spec.Treasury (tests) where
+
+import Agora.Treasury (
+  TreasuryRedeemer (SpendTreasuryGAT),
+  treasuryValidator,
+ )
+import Plutus.V1.Ledger.Api (
+  DCert (DCertDelegRegKey),
+ )
+import Plutus.V1.Ledger.Contexts (
+  ScriptContext (scriptContextPurpose, scriptContextTxInfo),
+  ScriptPurpose (Certifying, Rewarding, Spending),
+  TxInfo (txInfoInputs, txInfoMint),
+ )
+import Plutus.V1.Ledger.Credential (
+  StakingCredential (StakingHash),
+ )
+import Plutus.V1.Ledger.Value qualified as Value
+import Spec.Sample.Shared (
+  trCredential,
+ )
+import Spec.Sample.Treasury (
+  gatCs,
+  gatTn,
+  trCtxGATNameNotAddress,
+  treasuryRef,
+  validCtx,
+  walletIn,
+ )
+import Spec.Util (validatorFailsWith, validatorSucceedsWith)
+import Test.Tasty (TestTree, testGroup)
+
+tests :: [TestTree]
+tests =
+  [ testGroup
+      "Validator"
+      [ testGroup
+          "Positive"
+          [ validatorSucceedsWith
+              "Allows for effect changes"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              validCtx
+          ]
+      , testGroup
+          "Negative"
+          [ testGroup
+              "Fails with ScriptPurpose not Minting"
+              [ validatorFailsWith
+                  "Spending"
+                  (treasuryValidator gatCs)
+                  ()
+                  SpendTreasuryGAT
+                  validCtx
+                    { scriptContextPurpose = Spending treasuryRef
+                    }
+              , validatorFailsWith
+                  "Rewarding"
+                  (treasuryValidator gatCs)
+                  ()
+                  SpendTreasuryGAT
+                  validCtx
+                    { scriptContextPurpose =
+                        Rewarding $
+                          StakingHash trCredential
+                    }
+              , validatorFailsWith
+                  "Certifying"
+                  (treasuryValidator gatCs)
+                  ()
+                  SpendTreasuryGAT
+                  validCtx
+                    { scriptContextPurpose =
+                        Certifying $
+                          DCertDelegRegKey $
+                            StakingHash trCredential
+                    }
+              ]
+          , validatorFailsWith -- TODO: Use QuickCheck.
+              "Fails when multiple GATs burned"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              validCtx
+                { scriptContextTxInfo =
+                    validCtx.scriptContextTxInfo
+                      { txInfoMint =
+                          Value.singleton
+                            gatCs
+                            gatTn
+                            (-2)
+                      }
+                }
+          , validatorFailsWith
+              "Fails when GAT token name is not script address"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              trCtxGATNameNotAddress
+          , validatorFailsWith
+              "Fails with wallet as input"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              ( let txInfo = validCtx.scriptContextTxInfo
+                    inputs = txInfo.txInfoInputs
+                    newInputs =
+                      [ head inputs
+                      , walletIn
+                      ]
+                 in validCtx
+                      { scriptContextTxInfo =
+                          txInfo
+                            { txInfoInputs = newInputs
+                            }
+                      }
+              )
+          ]
+      ]
+  ]
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@ -3,7 +3,24 @@ Module     : Spec.Util
 Maintainer : emi@haskell.fyi
 Description: Utility functions for testing Plutarch scripts with ScriptContext

-Utility functions for testing Plutarch scripts with ScriptContext
+Utility functions for testing Plutarch scripts with ScriptContext:
+
+  - 'policySucceedsWith': checks that a minting policy succeeds.
+
+  - 'policyFailsWith': checks that a minting policy fails.
+
+  - 'validatorSucceedsWith': checks that validator succeeds.
+
+  - 'validatorFailsWith': checks that validator fails.
+
+  - 'effectSucceedsWith': checks that effect succeeds.
+
+  - 'effectFailsWith': checks that effect fails.
+
+  - 'scriptSucceeds': checks that an arbitrary script does not
+    `perror`.
+
+  - 'scriptFails': checks that an arbitrary script `perror`s out.
 -}
 module Spec.Util (
  -- * Testing utils
@ -131,7 +148,9 @@ validatorFailsWith tag validator datum redeemer scriptContext =
          # pconstant scriptContext
      )

-- | Check that a validator script succeeds, given a name and arguments.
+{- | Check that a validator script succeeds, given a name and arguments.
+     TODO: Change docstring.
+-}
 effectSucceedsWith ::
  ( PLift datum
  , PlutusTx.ToData (PLifted datum)
@ -143,7 +162,11 @@ effectSucceedsWith ::
  TestTree
 effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()

-- | Check that a validator script fails, given a name and arguments.
+-- TODO: Change docstring.
+
+{- | Check that a validator script fails, given a name and arguments.
+     TODO: Change docstring.
+-}
 effectFailsWith ::
  ( PLift datum
  , PlutusTx.ToData (PLifted datum)
--- a/agora.cabal
+++ b/agora.cabal
@ -111,6 +111,7 @@ common deps

 common test-deps
  build-depends:
+    , agora
    , apropos
    , apropos-tx
    , QuickCheck
@ -137,11 +138,10 @@ library
    Agora.Stake
    Agora.Stake.Scripts
    Agora.Treasury
-
-  other-modules:
    Agora.Utils
    Agora.Utils.Value

+  other-modules:
  hs-source-dirs:  agora

 library pprelude
@ -169,7 +169,9 @@ test-suite agora-test
    Spec.Sample.Proposal
    Spec.Sample.Shared
    Spec.Sample.Stake
+    Spec.Sample.Treasury
    Spec.Stake
+    Spec.Treasury
    Spec.Util

  build-depends:  agora
--- a/agora/Agora/AuthorityToken.hs
+++ b/agora/Agora/AuthorityToken.hs
@ -2,7 +2,6 @@
 Module     : Agora.AuthorityToken
 Maintainer : emi@haskell.fyi
 Description: Tokens acting as redeemable proofs of DAO authority.
-
 Tokens acting as redeemable proofs of DAO authority.
 -}
 module Agora.AuthorityToken (
@ -63,7 +62,6 @@ newtype AuthorityToken = AuthorityToken
     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.
 -}
--- a/agora/Agora/Treasury.hs
+++ b/agora/Agora/Treasury.hs
@ -60,8 +60,12 @@ deriving via
  instance
    PTryFrom PData (PAsData PTreasuryRedeemer)

-instance PUnsafeLiftDecl PTreasuryRedeemer where type PLifted PTreasuryRedeemer = TreasuryRedeemer
-deriving via (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer) instance (PConstantDecl TreasuryRedeemer)
+instance PUnsafeLiftDecl PTreasuryRedeemer where
+  type PLifted PTreasuryRedeemer = TreasuryRedeemer
+deriving via
+  (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer)
+  instance
+    (PConstantDecl TreasuryRedeemer)

 --------------------------------------------------------------------------------

@ -91,6 +95,7 @@ treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> P.do

  gatCs <- plet $ pconstant gatCs'

-  passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
+  passert "A single authority token has been burned" $
+    singleAuthorityTokenBurned gatCs txInfo' mint

  popaque $ pconstant ()