Added treasury samples and 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)
+
+------------------------------------------------------------------