add tests for authority token function 'singleAuthorityTokenBurned'

agora-test/Spec.hs

@@ -8,6 +8,7 @@ import Test.Tasty (defaultMain, testGroup)
 
 --------------------------------------------------------------------------------
 
+import Spec.AuthorityToken qualified as AuthorityToken
 import Spec.Model.MultiSig qualified as MultiSig
 import Spec.Stake qualified as Stake
 
@@ -28,4 +29,7 @@ main =
               , MultiSig.genTests
               ]
           ]
+      , testGroup
+          "AuthorityToken tests"
+          AuthorityToken.tests
       ]

agora-test/Spec/AuthorityToken.hs

@@ -0,0 +1,154 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+{- |
+Module     : Spec.AuthorityToken
+Maintainer : emi@haskell.fyi
+Description: Tests for Authority token functions
+
+Tests for Authority token functions
+-}
+module Spec.AuthorityToken (tests) where
+
+--------------------------------------------------------------------------------
+
+import Agora.AuthorityToken (singleAuthorityTokenBurned)
+import Plutarch
+import Test.Tasty (TestTree, testGroup)
+import Prelude
+
+--------------------------------------------------------------------------------
+
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (PubKeyCredential, ScriptCredential),
+  CurrencySymbol,
+  Script,
+  TxInInfo (TxInInfo),
+  TxInfo (..),
+  TxOut (TxOut),
+  TxOutRef (TxOutRef),
+  ValidatorHash (ValidatorHash),
+  Value,
+ )
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
+import Spec.Util (scriptFails, scriptSucceeds)
+
+currencySymbol :: CurrencySymbol
+currencySymbol = "deadbeef"
+
+mkTxInfo :: Value -> [TxOut] -> TxInfo
+mkTxInfo mint outs =
+  TxInfo
+    { txInfoInputs = fmap (TxInInfo (TxOutRef "" 0)) outs
+    , txInfoOutputs = []
+    , txInfoFee = Value.singleton "" "" 1000
+    , txInfoMint = mint
+    , txInfoDCert = []
+    , txInfoWdrl = []
+    , txInfoValidRange = Interval.always
+    , txInfoSignatories = []
+    , txInfoData = []
+    , txInfoId = ""
+    }
+
+singleAuthorityTokenBurnedTest :: Value -> [TxOut] -> Script
+singleAuthorityTokenBurnedTest mint outs =
+  let actual :: ClosedTerm PBool
+      actual = singleAuthorityTokenBurned (pconstant currencySymbol) (pconstantData (mkTxInfo mint outs)) (pconstant mint)
+      s :: ClosedTerm POpaque
+      s =
+        pif
+          actual
+          (popaque (pconstant ()))
+          perror
+   in compile s
+
+tests :: [TestTree]
+tests =
+  [ -- This is better suited for plutarch-test
+    testGroup
+      "singleAuthorityTokenBurned"
+      [ scriptSucceeds
+          "Correct simple"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-1)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 1)
+                  Nothing
+              ]
+          )
+      , scriptSucceeds
+          "Correct many inputs"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-1)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton "aaabcc" "hello-token" 1)
+                  Nothing
+              , TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 1)
+                  Nothing
+              , TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton "" "" 1_000_000_000)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect no burn"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.Value AssocMap.empty
+              )
+              []
+          )
+      , scriptFails
+          "Incorrect no GAT burn"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton "aabbcc" "not a GAT!" (-100)
+              )
+              []
+          )
+      , scriptFails
+          "Incorrect script mismatch"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "i'm not deadbeef!" (-1)
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "i'm not deadbeef!" 1)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect spent from PK"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "doesn't matter" (-1)
+              )
+              [ TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton currencySymbol "doesn't matter" 1)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect two GATs"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-2)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 2)
+                  Nothing
+              ]
+          )
+      ]
+  ]

agora.cabal

@@ -155,6 +155,7 @@ test-suite agora-test
     Spec.Sample.Stake
     Spec.Stake
     Spec.Util
+    Spec.AuthorityToken
 
   build-depends:  agora