154 lines
4.7 KiB
Haskell
154 lines
4.7 KiB
Haskell
{-# 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 Test.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
|
|
]
|
|
)
|
|
]
|
|
]
|