finished first draft of treasury tests

2022-05-05 12:03:10 +01:00 · 2022-05-05 12:03:10 +01:00 · a64f10c712
commit a64f10c712
parent 4fe380b4c2
4 changed files with 219 additions and 88 deletions
--- a/agora-test/Spec/Sample/Treasury.hs
+++ b/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.Value (CurrencySymbol, TokenName (TokenName))
+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)
@ -107,34 +120,64 @@ validCtx =
        }
    treasuryOut :: TxOut =
      TxOut
-        { txOutAddress =
-            Address
-              (ScriptCredential $ validatorHash trValidator)
-              Nothing
+        { txOutAddress = Address trCredential 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.
-
-data BadTreasuryRedeemer = NukeTheSystem
+-- | Unsupported treasury redeemer.
+data BadTreasuryRedeemer
+  = -- | 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)
-
------------------------------------------------------------------
--- a/agora-test/Spec/Treasury.hs
+++ b/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),
-  TxInfo (txInfoMint),
+  ScriptPurpose (Certifying, Rewarding, Spending),
+  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"
-      [ 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)
-                  }
-            }
+      "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: 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"
--- a/agora.cabal
+++ b/agora.cabal
@ -113,6 +113,7 @@ common test-deps
  build-depends:
    , apropos
    , apropos-tx
+    , lens
    , QuickCheck
    , quickcheck-instances
    , tasty
--- 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)

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