From 27263486650641828edec1b128e773b962ebec71 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 13 Apr 2022 16:39:08 +0200 Subject: [PATCH] refactor out ptokenSpent --- agora/Agora/AuthorityToken.hs | 31 +++++++++-------------- agora/Agora/Proposal.hs | 46 +++++++++++++++++++++++++++++------ agora/Agora/Utils.hs | 37 +++++++++++++++------------- 3 files changed, 70 insertions(+), 44 deletions(-) diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index 8239242..cd04507 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -18,16 +18,14 @@ import Plutarch.Api.V1 ( PCurrencySymbol (..), PScriptContext (..), PScriptPurpose (..), - PTxInInfo (..), PTxInfo (..), PTxOut (..), ) import Plutarch.Api.V1.AssocMap (PMap (PMap)) import Plutarch.Api.V1.Value (PValue (PValue)) import Plutarch.Builtin (pforgetData) -import Plutarch.List (pfoldr') import Plutarch.Monadic qualified as P -import Plutus.V1.Ledger.Value (AssetClass) +import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) import Prelude @@ -36,11 +34,11 @@ import Prelude import Agora.Utils ( allOutputs, passert, - passetClassValueOf, - passetClassValueOf', plookup, psymbolValueOf, + ptokenSpent, ) +import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) -------------------------------------------------------------------------------- @@ -132,26 +130,19 @@ authorityTokenPolicy params = PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo txInfo <- pletFields @'["inputs", "mint"] txInfo' let inputs = txInfo.inputs - let authorityTokenInputs = - pfoldr' @PBuiltinList - ( \txInInfo' acc -> P.do - PTxInInfo txInInfo <- pmatch (pfromData txInInfo') - PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo - txOut <- pletFields @'["value"] txOut' - let txOutValue = pfromData txOut.value - passetClassValueOf' params.authority # txOutValue + acc - ) - # 0 - # inputs - let mintedValue = pfromData txInfo.mint - let tokenMoved = 0 #< authorityTokenInputs + mintedValue = pfromData txInfo.mint + AssetClass (govCs, govTn) = params.authority + govAc = passetClass # pconstant govCs # pconstant govTn + govTokenSpent = ptokenSpent # govAc # inputs + PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose + let ownSymbol = pfromData $ pfield @"_0" # ownSymbol' - let mintedATs = passetClassValueOf # ownSymbol # pconstant "" # mintedValue + mintedATs = passetClassValueOf # mintedValue # (passetClass # ownSymbol # pconstant "") pif (0 #< mintedATs) ( P.do - passert "Parent token did not move in minting GATs" tokenMoved + passert "Parent token did not move in minting GATs" govTokenSpent passert "All outputs only emit valid GATs" $ allOutputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum -> authorityTokensValidIn diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 4b1062c..eea1c0c 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} {- | Module : Agora.Proposal @@ -39,6 +38,9 @@ import Plutarch.Api.V1 ( PMap, PMintingPolicy, PPubKeyHash, + PScriptContext (PScriptContext), + PScriptPurpose (PMinting, PSpending), + PTxInfo (PTxInfo), PValidator, PValidatorHash, ) @@ -54,14 +56,15 @@ import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- import Agora.SafeMoney (GTTag) -import Agora.Utils (pnotNull) +import Agora.Utils (passert, pnotNull, ptokenSpent) import Plutarch (popaque) +import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) import Plutarch.Builtin (PBuiltinMap) import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P import Plutarch.SafeMoney (PDiscrete, Tagged) import Plutarch.Unsafe (punsafeCoerce) -import Plutus.V1.Ledger.Value (AssetClass) +import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) -------------------------------------------------------------------------------- -- Haskell-land @@ -282,17 +285,46 @@ deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PCo {- | Policy for Proposals. This needs to perform two checks: - Governor is happy with mint. - - Datum is valid + - Exactly 1 token is minted. + + NOTE: The governor needs to check that the datum is correct + and sent to the right address. -} proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy -proposalPolicy _ = - plam $ \_redeemer _ctx' -> P.do +proposalPolicy proposal = + plam $ \_redeemer ctx' -> P.do + PScriptContext ctx' <- pmatch ctx' + ctx <- pletFields @'["txInfo", "purpose"] ctx' + PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo + txInfo <- pletFields @'["inputs", "mint"] txInfo' + PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose + + let inputs = txInfo.inputs + mintedValue = pfromData txInfo.mint + AssetClass (govCs, govTn) = proposal.governorSTAssetClass + + PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose + let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "") + + passert "Governance state-thread token must move" $ + ptokenSpent + # (passetClass # pconstant govCs # pconstant govTn) + # inputs + + passert "Minted exactly one proposal ST" $ + mintedProposalST #== 1 + popaque (pconstant ()) -- | Validator for Proposals. proposalValidator :: Proposal -> ClosedTerm PValidator proposalValidator _ = - plam $ \_datum _redeemer _ctx' -> P.do + plam $ \_datum _redeemer ctx' -> P.do + PScriptContext ctx' <- pmatch ctx' + ctx <- pletFields @'["txInfo", "purpose"] ctx' + PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo + _txInfo <- pletFields @'["inputs", "mint"] txInfo' + PSpending _txOutRef <- pmatch $ pfromData ctx.purpose popaque (pconstant ()) {- | Check for various invariants a proposal must uphold. diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 48e5af3..58c350a 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -17,8 +17,6 @@ module Agora.Utils ( plookup, pfromMaybe, psymbolValueOf, - passetClassValueOf, - passetClassValueOf', pgeqByClass, pgeqBySymbol, pgeqByClass', @@ -27,6 +25,7 @@ module Agora.Utils ( pfindMap, pnotNull, pisJust, + ptokenSpent, -- * Functions which should (probably) not be upstreamed anyOutput, @@ -63,6 +62,7 @@ import Plutarch.Api.V1 ( PValue, ) import Plutarch.Api.V1.AssocMap (PMap (PMap)) +import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf) import Plutarch.Api.V1.Value (PValue (PValue)) import Plutarch.Builtin (ppairDataBuiltin) import Plutarch.Internal (punsafeCoerce) @@ -183,30 +183,17 @@ psymbolValueOf = PMap m <- pmatch (pfromData m') pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m --- | Extract amount from PValue belonging to a Plutarch-level asset class. -passetClassValueOf :: - Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger) -passetClassValueOf = - phoistAcyclic $ - plam $ \sym token value'' -> P.do - PValue value' <- pmatch value'' - PMap value <- pmatch value' - m' <- pexpectJust 0 (plookup # pdata sym # value) - PMap m <- pmatch (pfromData m') - v <- pexpectJust 0 (plookup # pdata token # m) - pfromData v - -- | Extract amount from PValue belonging to a Haskell-level AssetClass. passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) passetClassValueOf' (AssetClass (sym, token)) = - passetClassValueOf # pconstant sym # pconstant token + phoistAcyclic $ plam $ \value -> pvalueOf # value # pconstant sym # pconstant token -- | Return '>=' on two values comparing by only a particular AssetClass. pgeqByClass :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool) pgeqByClass = phoistAcyclic $ plam $ \cs tn a b -> - passetClassValueOf # cs # tn # b #<= passetClassValueOf # cs # tn # a + pvalueOf # b # cs # tn #<= pvalueOf # a # cs # tn -- | Return '>=' on two values comparing by only a particular CurrencySymbol. pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool) @@ -421,3 +408,19 @@ findTxOutDatum = phoistAcyclic $ case datumHash' of PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # info _ -> pcon PNothing + +-- | Check if a particular asset class has been spent in the input list. +ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool) +ptokenSpent = + plam $ \tokenClass inputs -> + 0 + #< pfoldr @PBuiltinList + # ( plam $ \txInInfo' acc -> P.do + PTxInInfo txInInfo <- pmatch (pfromData txInInfo') + PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo + txOut <- pletFields @'["value"] txOut' + let txOutValue = pfromData txOut.value + acc + passetClassValueOf # txOutValue # tokenClass + ) + # 0 + # inputs