diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index 6442ae8..2f443cd 100644 --- a/agora-test/Spec.hs +++ b/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 ] diff --git a/agora-test/Spec/AuthorityToken.hs b/agora-test/Spec/AuthorityToken.hs new file mode 100644 index 0000000..da1e371 --- /dev/null +++ b/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 + ] + ) + ] + ] diff --git a/agora.cabal b/agora.cabal index 4c447e0..041af40 100644 --- a/agora.cabal +++ b/agora.cabal @@ -155,6 +155,7 @@ test-suite agora-test Spec.Sample.Stake Spec.Stake Spec.Util + Spec.AuthorityToken build-depends: agora