finished first draft of treasury tests

agora-test/Spec/Sample/Treasury.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -Wwarn #-}
 
 {- |
 Module: Spec.Sample.Treasury
@@ -15,10 +14,14 @@ module Spec.Sample.Treasury (
   validCtx,
   treasuryRef,
   gatTn,
+  walletIn,
+  trCredential,
 ) where
 
 import Agora.Effect.NoOp (noOpValidator)
-import Agora.Treasury (TreasuryRedeemer (SpendTreasuryGAT), treasuryValidator)
+import Agora.Treasury (
+  treasuryValidator,
+ )
 import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
 import Plutarch.Api.V1 (mkValidator, validatorHash)
@@ -28,7 +31,11 @@ import Plutarch.DataRepr (
  )
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import Plutus.V1.Ledger.Address (Address (..))
-import Plutus.V1.Ledger.Api (BuiltinByteString)
+import Plutus.V1.Ledger.Api (
+  BuiltinByteString,
+  Credential (PubKeyCredential),
+  PubKeyHash (PubKeyHash),
+ )
 import Plutus.V1.Ledger.Contexts (
   ScriptContext (..),
   ScriptPurpose (Minting),
@@ -39,8 +46,14 @@ import Plutus.V1.Ledger.Contexts (
  )
 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.Scripts (
-import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName (TokenName))
+  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)
@@ -107,34 +120,64 @@ validCtx =
         }
     treasuryOut :: TxOut =
       TxOut
-        { txOutAddress =
+        { txOutAddress = Address trCredential Nothing
-            Address
-              (ScriptCredential $ validatorHash trValidator)
-              Nothing
         , txOutValue = Value.singleton "" "" 0
         , txOutDatumHash = Just (toDatumHash ())
         }
 
+-- | Reference to treasury output.
 treasuryRef :: TxOutRef
-treasuryRef = TxOutRef "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" 1
+treasuryRef =
+  TxOutRef
+    "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+    1
 
+-- | Reference to dummy effect output.
 effectRef :: TxOutRef
-effectRef = TxOutRef "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" 0
+effectRef =
+  TxOutRef
+    "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
+    0
 
+-- | `ScriptCredential` used for the dummy treasury validator.
+trCredential :: Credential
+trCredential = ScriptCredential $ validatorHash trValidator
+
+-- | Mock effect script, used for testing.
 mockEffect :: Validator
 mockEffect = mkValidator $ noOpValidator gatCs
 
+-- | The hash of the mock effect script.
 addressBs :: BuiltinByteString
 (ValidatorHash addressBs) = validatorHash mockEffect
 
+-- | `TokenName` for GAT generated from address of `mockEffect`.
 gatTn :: TokenName
 gatTn = TokenName addressBs
 
-------------------------------------------------------------------
+-- | 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
+          }
+    }
 
--- Invalid treasury redeemer.
+-- | Unsupported treasury redeemer.
-
+data BadTreasuryRedeemer
-data BadTreasuryRedeemer = NukeTheSystem
+  = -- | Unsupported treasury redeemer.
+    NukeTheSystem Integer
   deriving stock (Eq, Show, GHC.Generic)
 
 PlutusTx.makeIsDataIndexed
@@ -142,8 +185,9 @@ PlutusTx.makeIsDataIndexed
   [ ('NukeTheSystem, 0)
   ]
 
+-- | Plutarch implementation of `BadTreasuryRedeemer`.
 data PBadTreasuryRedeemer (s :: S)
-  = PNukeTheSystem (Term s (PDataRecord '[]))
+  = PNukeTheSystem (Term s (PDataRecord '["_0" ':= PInteger]))
   deriving stock (GHC.Generic)
   deriving anyclass (Generic)
   deriving anyclass (PIsDataRepr)
@@ -160,5 +204,3 @@ deriving via
   )
   instance
     (PConstantDecl BadTreasuryRedeemer)
-
-------------------------------------------------------------------

agora-test/Spec/Treasury.hs

@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 {- |
 Module: Spec.Treasury
@@ -7,6 +7,17 @@ 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
 
@@ -14,89 +25,162 @@ import Agora.Treasury (
   TreasuryRedeemer (SpendTreasuryGAT),
   treasuryValidator,
  )
-import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
+import Plutus.V1.Ledger.Address (Address (Address))
+import Plutus.V1.Ledger.Api (
+  BuiltinByteString,
+  DCert (DCertDelegRegKey),
+ )
 import Plutus.V1.Ledger.Contexts (
   ScriptContext (scriptContextPurpose, scriptContextTxInfo),
-  ScriptPurpose (Spending),
+  ScriptPurpose (Certifying, Rewarding, Spending),
-  TxInfo (txInfoMint),
+  TxInfo (txInfoInputs, txInfoMint),
+  txInInfoResolved,
+  txOutAddress,
+ )
+import Plutus.V1.Ledger.Credential (
+  Credential (ScriptCredential),
+  StakingCredential (StakingHash),
+ )
+import Plutus.V1.Ledger.Scripts (
+  ValidatorHash (ValidatorHash),
  )
 import Plutus.V1.Ledger.Value qualified as Value
-import PlutusTx qualified
 import Spec.Sample.Treasury (
   BadTreasuryRedeemer (NukeTheSystem),
   gatCs,
   gatTn,
+  trCredential,
   treasuryRef,
   validCtx,
+  walletIn,
  )
 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
-      "validator"
+      "Validator"
-      [ validatorSucceedsWith
+      [ testGroup
-          "Allows for effect changes"
+          "Positive"
-          (treasuryValidator gatCs)
+          [ validatorSucceedsWith
-          ()
+              "Allows for effect changes"
-          SpendTreasuryGAT
+              (treasuryValidator gatCs)
-          validCtx
+              ()
-      , validatorFailsWith
+              SpendTreasuryGAT
-          "Fails with invalid redeemer"
+              validCtx
-          (treasuryValidator gatCs)
+          ]
-          ()
+      , testGroup
-          (NukeTheSystem)
+          "Negative"
-          validCtx
+          [ testGroup
-      , validatorFailsWith
+              "Fails with ScriptPurpose not Minting"
-          "Fails with ScriptPurpose not Minting"
+              [ validatorFailsWith
-          (treasuryValidator gatCs)
+                  "Spending"
-          ()
+                  (treasuryValidator gatCs)
-          SpendTreasuryGAT
+                  ()
-          validCtx
+                  SpendTreasuryGAT
-            { scriptContextPurpose = Spending treasuryRef
+                  validCtx
-            }
+                    { scriptContextPurpose = Spending treasuryRef
-      , validatorFailsWith
+                    }
-          "Fails when multiple GATs burned"
+              , validatorFailsWith
-          (treasuryValidator gatCs)
+                  "Rewarding"
-          ()
+                  (treasuryValidator gatCs)
-          SpendTreasuryGAT
+                  ()
-          validCtx
+                  SpendTreasuryGAT
-            { scriptContextTxInfo =
+                  validCtx
-                validCtx.scriptContextTxInfo
+                    { scriptContextPurpose =
-                  { txInfoMint = Value.singleton gatCs gatTn (-2)
+                        Rewarding $
-                  }
+                          StakingHash trCredential
-            }
+                    }
+              , validatorFailsWith
+                  "Certifying"
+                  (treasuryValidator gatCs)
+                  ()
+                  SpendTreasuryGAT
+                  validCtx
+                    { scriptContextPurpose =
+                        Certifying $
+                          DCertDelegRegKey $
+                            StakingHash trCredential
+                    }
+              ]
+          , -- , validatorFailsWith -- TODO: Check.
+            --     "Fails with invalid redeemer"
+            --     (treasuryValidator gatCs)
+            --     ()
+            --     (NukeTheSystem 72)
+            --     validCtx
+
+            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
+              ( let txInfo = validCtx.scriptContextTxInfo
+                    inputs = txInfo.txInfoInputs
+                    effectIn = inputs !! 1
+                    invalidEff =
+                      effectIn
+                        { txInInfoResolved =
+                            effectIn.txInInfoResolved
+                              { txOutAddress =
+                                  Address
+                                    ( ScriptCredential $
+                                        ValidatorHash
+                                          wrongHash
+                                    )
+                                    Nothing
+                              }
+                        }
+                 in validCtx
+                      { scriptContextTxInfo =
+                          txInfo
+                            { txInfoInputs =
+                                [ inputs !! 0
+                                , invalidEff
+                                ]
+                            }
+                      }
+              )
+          , validatorFailsWith
+              "Fails with wallet as input"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              ( let txInfo = validCtx.scriptContextTxInfo
+                    inputs = txInfo.txInfoInputs
+                    newInputs =
+                      [ inputs !! 0
+                      , walletIn
+                      ]
+                 in validCtx
+                      { scriptContextTxInfo =
+                          txInfo
+                            { txInfoInputs = newInputs
+                            }
+                      }
+              )
+          ]
       ]
   ]
+
+{- | A SHA-256 hash which (in all certainty) should not match the
+     hash of the dummy effect script.
+-}
+wrongHash :: BuiltinByteString
+wrongHash = "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"

agora.cabal

@@ -113,6 +113,7 @@ common test-deps
   build-depends:
     , apropos
     , apropos-tx
+    , lens
     , QuickCheck
     , quickcheck-instances
     , tasty

agora/Agora/Treasury.hs

@@ -60,8 +60,12 @@ deriving via
   instance
     PTryFrom PData (PAsData PTreasuryRedeemer)
 
-instance PUnsafeLiftDecl PTreasuryRedeemer where type PLifted PTreasuryRedeemer = TreasuryRedeemer
+instance PUnsafeLiftDecl PTreasuryRedeemer where
-deriving via (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer) instance (PConstantDecl TreasuryRedeemer)
+  type PLifted PTreasuryRedeemer = TreasuryRedeemer
+deriving via
+  (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer)
+  instance
+    (PConstantDecl TreasuryRedeemer)
 
 --------------------------------------------------------------------------------