From 7c59888b452b5d9d7c9e85cd8fff3abe32168715 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 20 Apr 2022 18:36:45 +0200 Subject: [PATCH 1/3] drop `allInputs`, fix `authorityTokensValidIn` --- agora/Agora/AuthorityToken.hs | 30 ++++++++++++++++++------------ agora/Agora/Utils.hs | 25 ------------------------- 2 files changed, 18 insertions(+), 37 deletions(-) diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index dadabe4..1956fb6 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -34,7 +34,6 @@ import Prelude -------------------------------------------------------------------------------- import Agora.Utils ( - allInputs, allOutputs, passert, passetClassValueOf, @@ -81,15 +80,16 @@ authorityTokensValidIn = phoistAcyclic $ pmatch (pfield @"credential" # address) $ \case PPubKeyCredential _ -> -- GATs should only be sent to Effect validators - pconstant False + ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> P.do PMap tokenMap <- pmatch tokenMap' - pall - # plam - ( \pair -> - pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred) - ) - # tokenMap + ptraceIfFalse "authorityTokensValidIn: GAT TokenName doesn't match ScriptHash" $ + pall + # plam + ( \pair -> + pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred) + ) + # tokenMap PNothing -> -- No GATs exist at this output! pconstant True @@ -105,14 +105,20 @@ singleAuthorityTokenBurned gatCs txInfo mint = P.do let gatAmountMinted :: Term _ PInteger gatAmountMinted = psymbolValueOf # gatCs # mint + txInfoF <- pletFields @'["inputs"] $ txInfo + foldr1 (#&&) [ ptraceIfFalse "GAT not burned." $ gatAmountMinted #== -1 , ptraceIfFalse "All inputs only have valid GATs" $ - allInputs @PUnit # pfromData txInfo #$ plam $ \txOut _value _address _datum -> - authorityTokensValidIn - # gatCs - # txOut + pall + # plam + ( \txInInfo' -> P.do + PTxInInfo txInInfo <- pmatch (pfromData txInInfo') + let txOut' = pfield @"resolved" # txInInfo + authorityTokensValidIn # gatCs # pfromData txOut' + ) + # txInfoF.inputs ] -- | Policy given 'AuthorityToken' params. diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index e05e4ee..48e5af3 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -32,7 +32,6 @@ module Agora.Utils ( anyOutput, allOutputs, anyInput, - allInputs, findTxOutByTxOutRef, scriptHashFromAddress, findOutputsToAddress, @@ -376,30 +375,6 @@ anyInput = phoistAcyclic $ ) # pfromData txInfo.inputs --- | Check if all (resolved) inputs match the predicate. -allInputs :: - forall (datum :: PType) s. - ( PIsData datum - ) => - Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool) -allInputs = phoistAcyclic $ - plam $ \txInfo' predicate -> P.do - txInfo <- pletFields @'["inputs"] txInfo' - pall - # plam - ( \txInInfo'' -> P.do - PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'') - let txOut'' = pfield @"resolved" # txInInfo' - PTxOut txOut' <- pmatch (pfromData txOut'') - txOut <- pletFields @'["value", "datumHash", "address"] txOut' - PDJust dh <- pmatch txOut.datumHash - pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case - PJust datum -> P.do - predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum - PNothing -> pcon PFalse - ) - # pfromData txInfo.inputs - -- | Create a value with a single asset class. psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) psingletonValue = phoistAcyclic $ From a6ef476beb5bd9fb93efbf8191c8f126db16b8d0 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 20 Apr 2022 20:06:15 +0200 Subject: [PATCH 2/3] add tests for authority token function 'singleAuthorityTokenBurned' --- agora-test/Spec.hs | 4 + agora-test/Spec/AuthorityToken.hs | 154 ++++++++++++++++++++++++++++++ agora.cabal | 1 + 3 files changed, 159 insertions(+) create mode 100644 agora-test/Spec/AuthorityToken.hs 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 From b8b62695919f11dcb1901d99b52cedbc0454aa6a Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 21 Apr 2022 11:09:07 +0200 Subject: [PATCH 3/3] improve trace error message --- agora/Agora/AuthorityToken.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index 1956fb6..8239242 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -109,8 +109,8 @@ singleAuthorityTokenBurned gatCs txInfo mint = P.do foldr1 (#&&) - [ ptraceIfFalse "GAT not burned." $ gatAmountMinted #== -1 - , ptraceIfFalse "All inputs only have valid GATs" $ + [ ptraceIfFalse "singleAuthorityTokenBurned: Must burn exactly 1 GAT" $ gatAmountMinted #== -1 + , ptraceIfFalse "singleAuthorityTokenBurned: All GAT tokens must be valid at the inputs" $ pall # plam ( \txInInfo' -> P.do