Added treasury samples and tests

agora-test/Spec.hs

@@ -1,4 +1,11 @@
-{-# OPTIONS_GHC -Wwarn #-}
+{- |
+Module: Main
+Description: Agora test suite.
+Maintainer: emi@haskell.fyi
+
+This module is the root of Agora's test suite.
+-}
+module Main (main) where
 
 --------------------------------------------------------------------------------
 
@@ -15,6 +22,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 ()
@@ -45,4 +53,7 @@ main =
       , testGroup
           "AuthorityToken tests"
           AuthorityToken.tests
+      , testGroup
+          "Treasury tests"
+          Treasury.tests
       ]

agora-test/Spec/Sample/Treasury.hs

@@ -1 +1,164 @@
-module Spec.Sample.Treasury () where
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wwarn #-}
+
+{- |
+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 (
+  BadTreasuryRedeemer (NukeTheSystem),
+  gatCs,
+  validCtx,
+  treasuryRef,
+  gatTn,
+) where
+
+import Agora.Effect.NoOp (noOpValidator)
+import Agora.Treasury (TreasuryRedeemer (SpendTreasuryGAT), treasuryValidator)
+import GHC.Generics qualified as GHC
+import Generics.SOP (Generic, I (I))
+import Plutarch.Api.V1 (mkValidator, validatorHash)
+import Plutarch.DataRepr (
+  DerivePConstantViaData (..),
+  PIsDataReprInstances (..),
+ )
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
+import Plutus.V1.Ledger.Address (Address (..))
+import Plutus.V1.Ledger.Api (BuiltinByteString)
+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 (Validator, ValidatorHash (ValidatorHash))
+import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName (TokenName))
+import Plutus.V1.Ledger.Value qualified as Value
+import PlutusTx qualified
+import Spec.Sample.Shared (signer)
+import Spec.Util (datumPair, toDatumHash)
+
+{- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol'
+     of a valid governance authority token (GAT).
+-}
+gatCs :: CurrencySymbol
+gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+
+trValidator :: Validator
+trValidator = mkValidator (treasuryValidator gatCs)
+
+{- | 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 mockEffect) Nothing
+              , txOutValue = Value.singleton gatCs gatTn 1
+              , txOutDatumHash = Just (toDatumHash ())
+              }
+        }
+    treasuryOut :: TxOut =
+      TxOut
+        { txOutAddress =
+            Address
+              (ScriptCredential $ validatorHash trValidator)
+              Nothing
+        , txOutValue = Value.singleton "" "" 0
+        , txOutDatumHash = Just (toDatumHash ())
+        }
+
+treasuryRef :: TxOutRef
+treasuryRef = TxOutRef "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" 1
+
+effectRef :: TxOutRef
+effectRef = TxOutRef "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" 0
+
+mockEffect :: Validator
+mockEffect = mkValidator $ noOpValidator gatCs
+
+addressBs :: BuiltinByteString
+(ValidatorHash addressBs) = validatorHash mockEffect
+
+gatTn :: TokenName
+gatTn = TokenName addressBs
+
+------------------------------------------------------------------
+
+-- Invalid treasury redeemer.
+
+data BadTreasuryRedeemer = NukeTheSystem
+  deriving stock (Eq, Show, GHC.Generic)
+
+PlutusTx.makeIsDataIndexed
+  ''BadTreasuryRedeemer
+  [ ('NukeTheSystem, 0)
+  ]
+
+data PBadTreasuryRedeemer (s :: S)
+  = PNukeTheSystem (Term s (PDataRecord '[]))
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic)
+  deriving anyclass (PIsDataRepr)
+  deriving
+    (PlutusType, PIsData)
+    via PIsDataReprInstances PBadTreasuryRedeemer
+
+instance PUnsafeLiftDecl PBadTreasuryRedeemer where
+  type PLifted PBadTreasuryRedeemer = BadTreasuryRedeemer
+deriving via
+  ( DerivePConstantViaData
+      BadTreasuryRedeemer
+      PBadTreasuryRedeemer
+  )
+  instance
+    (PConstantDecl BadTreasuryRedeemer)
+
+------------------------------------------------------------------

agora-test/Spec/Treasury.hs

@@ -1,10 +1,102 @@
+{-# OPTIONS_GHC -Wwarn #-}
+
+{- |
+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.
+-}
 module Spec.Treasury (tests) where
 
+import Agora.Treasury (
+  TreasuryRedeemer (SpendTreasuryGAT),
+  treasuryValidator,
+ )
+import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
+import Plutus.V1.Ledger.Contexts (
+  ScriptContext (scriptContextPurpose, scriptContextTxInfo),
+  ScriptPurpose (Spending),
+  TxInfo (txInfoMint),
+ )
+import Plutus.V1.Ledger.Value qualified as Value
+import PlutusTx qualified
+import Spec.Sample.Treasury (
+  BadTreasuryRedeemer (NukeTheSystem),
+  gatCs,
+  gatTn,
+  treasuryRef,
+  validCtx,
+ )
+import Spec.Util (validatorFailsWith, validatorSucceedsWith)
 import Test.Tasty (TestTree, testGroup)
 
+{-
+
+`Spec.Util` provides a number of useful functions:
+
+  - policySucceedsWith: checks that a minting policy succeeds.
+
+  - policyFailsWith: checks that a minting policy fails.
+
+  - validatorSucceedsWith: checks that validator succeeds.
+
+  - validatorFailsWith: checks that validator fails.
+
+  - scriptSucceeds: checks that an arbitrary script does not
+    `perror`.
+
+  - scriptFails: checks that an arbitrary script `perror`s out.
+
+-}
+
+{-
+
+Tests need to fail when:
+
+  1. The reedeemer is of inproper form.
+  2. The script purpose is not minting.
+  3. `singleAuthorityTokenBurned` returns false.
+    a. Multiple GATs burned.
+    b. An input returns 'False' for 'authorityTokensValidIn'
+
+-}
+
 tests :: [TestTree]
 tests =
   [ testGroup
-      "treasury"
-      []
+      "validator"
+      [ validatorSucceedsWith
+          "Allows for effect changes"
+          (treasuryValidator gatCs)
+          ()
+          SpendTreasuryGAT
+          validCtx
+      , validatorFailsWith
+          "Fails with invalid redeemer"
+          (treasuryValidator gatCs)
+          ()
+          (NukeTheSystem)
+          validCtx
+      , validatorFailsWith
+          "Fails with ScriptPurpose not Minting"
+          (treasuryValidator gatCs)
+          ()
+          SpendTreasuryGAT
+          validCtx
+            { scriptContextPurpose = Spending treasuryRef
+            }
+      , validatorFailsWith
+          "Fails when multiple GATs burned"
+          (treasuryValidator gatCs)
+          ()
+          SpendTreasuryGAT
+          validCtx
+            { scriptContextTxInfo =
+                validCtx.scriptContextTxInfo
+                  { txInfoMint = Value.singleton gatCs gatTn (-2)
+                  }
+            }
+      ]
   ]

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)