Merge pull request #37 from Liqwid-Labs/jhodgdev/treasury-tests

jhodgdev/treasury tests

Makefile

@@ -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
+.PHONY: hoogle format haddock usage tag lint
 
 usage:
 	@echo "usage: make <command> [OPTIONS]"
@@ -11,6 +11,7 @@ usage:
 	@echo "  format -- Format the project"
 	@echo "  haddock -- Generate Haddock docs for project"
 	@echo "  tag -- Generate CTAGS and ETAGS files for project"
+	@echo "  lint -- Get hlint suggestions for project"
 
 hoogle:
 	pkill hoogle || true
@@ -40,3 +41,5 @@ haddock:
 tag:
 	hasktags -x agora agora-bench agora-test
 
+lint:
+	hlint agora agora-bench agora-test

agora-test/Spec.hs

@@ -1,5 +1,3 @@
---------------------------------------------------------------------------------
-
 import Prelude
 
 --------------------------------------------------------------------------------
@@ -13,6 +11,7 @@ import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
 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 ()
@@ -32,6 +31,12 @@ main =
       , testGroup
           "Proposal tests"
           Proposal.tests
+      , testGroup
+          "AuthorityToken tests"
+          AuthorityToken.tests
+      , testGroup
+          "Treasury tests"
+          Treasury.tests
       , testGroup
           "Multisig tests"
           [ testGroup
@@ -40,7 +45,4 @@ main =
               , MultiSig.genTests
               ]
           ]
-      , testGroup
-          "AuthorityToken tests"
-          AuthorityToken.tests
       ]

agora-test/Spec/Sample/Shared.hs

@@ -9,6 +9,7 @@ module Spec.Sample.Shared (
   -- * Misc
   signer,
   signer2,
+  minAda,
 
   -- * Components
 
@@ -30,8 +31,17 @@ module Spec.Sample.Shared (
   proposalPolicySymbol,
   proposalValidatorHash,
   proposalValidatorAddress,
+
+  -- ** Treasury
+  treasuryOut,
+  gatTn,
+  gatCs,
+  mockTrEffect,
+  trCredential,
+  wrongEffHash,
 ) where
 
+import Agora.Effect.NoOp (noOpValidator)
 import Agora.Governor (
   Governor (Governor),
   governorPolicy,
@@ -47,6 +57,8 @@ import Agora.Proposal.Scripts (
  )
 import Agora.Stake (Stake (..))
 import Agora.Stake.Scripts (stakePolicy, stakeValidator)
+import Agora.Treasury (treasuryValidator)
+import Agora.Utils (validatorHashToTokenName)
 import Plutarch.Api.V1 (
   mintingPolicySymbol,
   mkMintingPolicy,
@@ -62,7 +74,11 @@ import Plutus.V1.Ledger.Api (
   MintingPolicy (..),
   PubKeyHash,
  )
-import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
+import Plutus.V1.Ledger.Contexts (
+  TxOut (..),
+ )
+import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (..))
+import Plutus.V1.Ledger.Value (TokenName, Value)
 import Plutus.V1.Ledger.Value qualified as Value
 
 --------------------------------------------------------------------------------
@@ -131,3 +147,47 @@ defaultProposalThresholds =
     , create = Tagged 1
     , startVoting = Tagged 10
     }
+
+------------------------------------------------------------------
+
+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

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
+                  ]
+              }
+        }

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
+                            }
+                      }
+              )
+          ]
+      ]
+  ]

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)

agora.cabal

@@ -111,6 +111,7 @@ common deps
 
 common test-deps
   build-depends:
+    , agora
     , apropos
     , apropos-tx
     , QuickCheck
@@ -136,11 +137,10 @@ library
     Agora.Stake
     Agora.Stake.Scripts
     Agora.Treasury
-
-  other-modules:
     Agora.Utils
     Agora.Utils.Value
 
+  other-modules:
   hs-source-dirs:  agora
 
 library pprelude
@@ -166,7 +166,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

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 (
@@ -62,7 +61,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.
 -}

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