126 lines
4.6 KiB
Haskell
126 lines
4.6 KiB
Haskell
{- |
|
|
Module : Agora.AuthorityToken
|
|
Maintainer : emi@haskell.fyi
|
|
Description: Tokens acting as redeemable proofs of DAO authority.
|
|
|
|
Tokens acting as redeemable proofs of DAO authority.
|
|
-}
|
|
module Agora.AuthorityToken (
|
|
authorityTokenPolicy,
|
|
authorityTokensValidIn,
|
|
AuthorityToken (..),
|
|
) where
|
|
|
|
import Plutarch.Api.V1 (
|
|
PAddress (..),
|
|
PCredential (..),
|
|
PCurrencySymbol (..),
|
|
PMap (..),
|
|
PScriptContext (..),
|
|
PScriptPurpose (..),
|
|
PTxInInfo (..),
|
|
PTxInfo (..),
|
|
PTxOut (..),
|
|
PValue (..),
|
|
)
|
|
import Plutarch.Builtin (pforgetData)
|
|
import Plutarch.List (pfoldr')
|
|
import Plutarch.Monadic qualified as P
|
|
import Plutus.V1.Ledger.Value (AssetClass)
|
|
|
|
import Prelude
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
import Agora.Utils (allOutputs, passert, passetClassValueOf, passetClassValueOf', plookup)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
{- | An AuthorityToken represents a proof that a particular token
|
|
moved while this token was minted. In effect, this means that
|
|
the validator that locked such a token must have approved
|
|
said transaction. Said validator should be made aware of
|
|
*this* token's existence in order to prevent incorrect minting.
|
|
-}
|
|
newtype AuthorityToken = AuthorityToken
|
|
{ authority :: AssetClass
|
|
-- ^ Token that must move in order for minting this to be valid.
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
{- | Check that all GATs are valid in a particular TxOut.
|
|
How this is checked: an AuthorityToken should never leave
|
|
the Effect it was initially sent to, so we simply check that
|
|
the script address the token resides in matches the TokenName.
|
|
Since the TokenName was tagged upon mint with the Effect script
|
|
it was sent to, this is enough to prove validity.
|
|
|
|
In other words, check that all assets of a particular currency symbol
|
|
are tagged with a TokenName that matches where they live.
|
|
-}
|
|
authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool)
|
|
authorityTokensValidIn = phoistAcyclic $
|
|
plam $ \authorityTokenSym txOut'' -> P.do
|
|
PTxOut txOut' <- pmatch txOut''
|
|
txOut <- pletFields @'["address", "value"] $ txOut'
|
|
PAddress address <- pmatch txOut.address
|
|
PValue value' <- pmatch txOut.value
|
|
PMap value <- pmatch value'
|
|
pmatch (plookup # pdata authorityTokenSym # value) $ \case
|
|
PJust (pfromData -> tokenMap') ->
|
|
pmatch (pfield @"credential" # address) $ \case
|
|
PPubKeyCredential _ ->
|
|
-- GATs should only be sent to Effect validators
|
|
pconstant False
|
|
PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> P.do
|
|
PMap tokenMap <- pmatch tokenMap'
|
|
pall
|
|
# plam
|
|
( \pair ->
|
|
pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred)
|
|
)
|
|
# tokenMap
|
|
PNothing ->
|
|
-- No GATs exist at this output!
|
|
pconstant True
|
|
|
|
-- | Policy given 'AuthorityToken' params.
|
|
authorityTokenPolicy ::
|
|
AuthorityToken ->
|
|
Term s (PData :--> PScriptContext :--> PUnit)
|
|
authorityTokenPolicy params =
|
|
plam $ \_redeemer ctx' ->
|
|
pmatch ctx' $ \(PScriptContext ctx') -> P.do
|
|
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
|
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
|
|
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
|
|
let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
|
|
let mintedATs = passetClassValueOf # ownSymbol # pconstant "" # mintedValue
|
|
pif
|
|
(0 #< mintedATs)
|
|
( P.do
|
|
passert "Parent token did not move in minting GATs" tokenMoved
|
|
passert "All outputs only emit valid GATs" $
|
|
allOutputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
|
|
authorityTokensValidIn
|
|
# ownSymbol
|
|
# txOut
|
|
pconstant ()
|
|
)
|
|
(pconstant ())
|