Merge pull request #65 from Liqwid-Labs/emiflake/drop-allInputs
drop `allInputs`, fix `authorityTokensValidIn`
This commit is contained in:
Emily
GitHub
commit
41a88204fa
5 changed files with 179 additions and 39 deletions
|
|
@ -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
|
||||
]
|
||||
|
|
|
|||
154
agora-test/Spec/AuthorityToken.hs
Normal file
154
agora-test/Spec/AuthorityToken.hs
Normal file
|
|
@ -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
|
||||
]
|
||||
)
|
||||
]
|
||||
]
|
||||
|
|
@ -155,6 +155,7 @@ test-suite agora-test
|
|||
Spec.Sample.Stake
|
||||
Spec.Stake
|
||||
Spec.Util
|
||||
Spec.AuthorityToken
|
||||
|
||||
build-depends: agora
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ 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
|
||||
PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
|
||||
let txOut' = pfield @"resolved" # txInInfo
|
||||
authorityTokensValidIn # gatCs # pfromData txOut'
|
||||
)
|
||||
# txInfoF.inputs
|
||||
]
|
||||
|
||||
-- | Policy given 'AuthorityToken' params.
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue