Sulkta-OSS/agora
3
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

auth check tokens instead of effect validator

Browse source
This commit is contained in:
Emily Martins 2022-08-22 19:43:48 +02:00
parent 029b6d848e
commit f335bf98df
10 changed files with 503 additions and 410 deletions
Download patch file Download diff file Expand all files Collapse all files

24
agora/Agora/AuthorityToken.hs
View file

@ -29,7 +29,6 @@ import Plutarch.Api.V2 (
PTxInfo (..),
PTxOut (..),
)
import Plutarch.Builtin (pforgetData)
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
import Plutarch.Extra.List (plookup)
import Plutarch.Extra.ScriptContext (pisTokenSpent)
@ -68,6 +67,9 @@ newtype AuthorityToken = AuthorityToken
In other words, check that all assets of a particular currency symbol
are tagged with a TokenName that matches where they live.
As of version 1.0.0, this has been weakened in order to be compatible
with RATs.
@since 0.1.0
-}
authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool)
@ -80,24 +82,20 @@ authorityTokensValidIn = phoistAcyclic $
PMap value <- pmatchC value'
pure $
pmatch (plookup # pdata authorityTokenSym # value) $ \case
PJust (pfromData -> tokenMap') ->
PJust (pfromData -> _tokenMap') ->
pmatch (pfield @"credential" # address) $ \case
PPubKeyCredential _ ->
-- GATs should only be sent to Effect validators
ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False
PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> unTermCont $ do
PMap tokenMap <- pmatchC tokenMap'
pure $
ptraceIfFalse "authorityTokensValidIn: GAT TokenName doesn't match ScriptHash" $
pall
# plam
( \pair ->
pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred)
)
# tokenMap
PScriptCredential _ ->
-- NOTE: We no longer can perform a check on `TokenName` content here.
-- Instead, the auth check system uses `TokenName`s, but it cannot
-- check for GATs incorrectly escaping scripts. The effect scripts
-- need to be written very carefully in order to disallow this.
pcon PTrue
PNothing ->
-- No GATs exist at this output!
pconstant True
pcon PTrue
{- | Assert that a single authority token has been burned.

58
agora/Agora/Effect.hs
View file

@ -10,10 +10,13 @@ module Agora.Effect (makeEffect) where
import Agora.AuthorityToken (singleAuthorityTokenBurned)
import Plutarch.Api.V1 (
PCurrencySymbol,
PValue,
PMap (PMap),
PValue (PValue),
)
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V2 (
PScriptPurpose (PSpending),
PTxInInfo (PTxInInfo),
PTxInfo,
PTxOutRef,
PValidator,
@ -34,30 +37,63 @@ makeEffect ::
forall (datum :: PType).
(PTryFrom PData datum, PIsData datum) =>
CurrencySymbol ->
(forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
( forall (s :: S).
Term s PCurrencySymbol ->
Term s datum ->
Term s PTxOutRef ->
Term s (PAsData PTxInfo) ->
Term s POpaque
) ->
ClosedTerm PValidator
makeEffect gatCs' f =
plam $ \datum _redeemer ctx' -> unTermCont $ do
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
-- convert input datum, PData, into desierable type
-- Convert input datum, PData, into desierable type
-- the way this conversion is performed should be defined
-- by PTryFrom for each datum in effect script.
(datum', _) <- ptryFromC datum
datum' <- fst <$> ptryFromC datum
-- ensure purpose is Spending.
-- Ensure purpose is Spending. Why? The only way that this
-- effect script can actually pass any validation onto other
-- scripts is by preventing the spend of the GAT.
--
-- - In the case of GATs which don't get burned, that will
-- allow reuse of the GAT.
--
-- - In the case of GATs which get _referenced_, this script
-- won't be run at all, in which case. The auth check needs
-- to be especially written with that in mind.
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
txOutRef' <- pletC (pfield @"_0" # txOutRef)
-- fetch minted values to ensure single GAT is burned
txInfo <- pletFieldsC @'["mint", "inputs"] ctx.txInfo
let mint :: Term _ (PValue _ _)
mint = txInfo.mint
-- fetch script context
gatCs <- pletC $ pconstant gatCs'
pguardC "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo.inputs mint
-- FIXME(emiflake): This is somewhat inefficient, we could roll these two loops together.
let inputsWithGAT =
pfoldr
# plam
( \txInInfo' acc ->
unTermCont $ do
PTxInInfo txInInfo <- pmatchC txInInfo'
let txOut' = pfield @"resolved" # txInInfo
PValue value <- pmatchC $ pfield @"value" # txOut'
pure $
pmatch (plookup # gatCs # value) $ \case
PNothing -> acc
PJust tokenMap' -> unTermCont $ do
PMap tokenMap <- pmatchC tokenMap'
pure $ acc + plength # tokenMap
)
# (0 :: Term _ PInteger)
# txInfo.inputs
pguardC "Only one GAT must exist at the inputs" $
inputsWithGAT #== 1
pguardC "A single authority token has been burned" $
singleAuthorityTokenBurned gatCs txInfo.inputs txInfo.mint
-- run effect function
pure $ f gatCs datum' txOutRef' ctx.txInfo

54
agora/Agora/Governor/Scripts.hs
View file

@ -51,10 +51,14 @@ import Agora.Stake (
pnumCreatedProposals,
)
import Agora.Utils (
pscriptHashToTokenName,
validatorHashToAddress,
)
import Plutarch.Api.V1 (
PCurrencySymbol,
PMap (PMap),
PTokenName,
PValue (PValue),
)
import Plutarch.Api.V1.AssocMap qualified as AssocMap
import Plutarch.Api.V2 (
@ -64,14 +68,16 @@ import Plutarch.Api.V2 (
PTxOut,
PValidator,
)
import Plutarch.Builtin (ppairDataBuiltin)
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.IsData (pmatchEnumFromData)
import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Map (
plookup,
plookup',
)
import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pfromJust, pmaybeData, pnothing)
import Plutarch.Extra.Maybe (passertPJust, pfromJust, pmaybeData, pnothing)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.ScriptContext (
pfindOutputsToAddress,
@ -478,7 +484,7 @@ governorValidator as =
gatCount <- pletC $ plength #$ pto $ pto effectGroup
pguardC "Required amount of GATs should be minted" $
psymbolValueOf # patSymbol # txInfoF.mint #== gatCount
psymbolValueOf # atSymbol # txInfoF.mint #== gatCount
-- Ensure that every GAT goes to one of the effects in the winner effect group.
outputsWithGAT <-
@ -487,7 +493,7 @@ governorValidator as =
# phoistAcyclic
( plam
( \((pfield @"value" #) -> value) ->
0 #< psymbolValueOf # patSymbol # value
0 #< psymbolValueOf # atSymbol # value
)
)
# pfromData txInfoF.outputs
@ -495,40 +501,42 @@ governorValidator as =
pguardC "Output GATs is more than minted GATs" $
plength # outputsWithGAT #== gatCount
-- For a given output, check if it contains a single valid GAT
-- and whether it correctly belongs to the group.
let validateGATOutput' :: Term s (PProposalEffectGroup :--> PTxOut :--> PBool)
validateGATOutput' =
phoistAcyclic $
plam
( \effects output -> unTermCont $ do
outputF <- pletFieldsC @'["address", "datum", "referenceScript"] output
outputF <- pletFieldsC @'["address", "datum", "value"] output
PValue value <- pmatchC $ outputF.value
PMap authorityTokens <-
pmatchC $
passertPJust # "validateGATOutput': Must have GAT in GAT output"
#$ plookup # atSymbol # value
let receiverScriptHash =
let tagToken :: Term _ PTokenName
tagToken =
pmaybeData # pconstant "" # plam (pscriptHashToTokenName . pfromData)
#$ psndTuple # effect
receiverScriptHash =
passertPJust # "GAT receiver should be a script"
#$ pscriptHashFromAddress # outputF.address
effect =
passertPJust # "Receiver should be in the effect group"
#$ AssocMap.plookup # receiverScriptHash # effects
hasCorrectReferenceScript =
pmaybeData
# pconstant True
# plam
( ( passertPDJust
# "Output UTXO should have a reference script"
# outputF.referenceScript
#==
)
. pfromData
)
# (psndTuple # effect)
valueGATCorrect =
authorityTokens
#== psingleton # (ppairDataBuiltin # pdata tagToken # pdata 1)
hasCorrectDatum =
pfstTuple # effect #== pfromDatumHash # outputF.datum
pure $
foldr1
(#&&)
[ ptraceIfFalse "GAT valid" $ authorityTokensValidIn # patSymbol # output
[ ptraceIfFalse "GAT valid" $ authorityTokensValidIn # atSymbol # output
, ptraceIfFalse "Correct datum" hasCorrectDatum
, ptraceIfFalse "Reference script correct" hasCorrectReferenceScript
, ptraceIfFalse "Value correctly encodes Auth Check script" valueGATCorrect
]
)
@ -539,7 +547,7 @@ governorValidator as =
# plam
( \txOut r ->
let value = pfield @"value" # txOut
atValue = psymbolValueOf # patSymbol # value
atValue = psymbolValueOf # atSymbol # value
in pif (atValue #== 0) r $
pif (atValue #== 1) (r #&& validateGATOutput # txOut) $ pconstant False
)
@ -553,7 +561,7 @@ governorValidator as =
Just MutateGovernor -> unTermCont $ do
-- Check that a GAT is burnt.
pguardC "One valid GAT burnt" $
singleAuthorityTokenBurned patSymbol txInfoF.inputs txInfoF.mint
singleAuthorityTokenBurned atSymbol txInfoF.inputs txInfoF.mint
pure $ popaque $ pconstant ()
@ -561,8 +569,8 @@ governorValidator as =
Nothing -> ptraceError "Unknown redeemer"
where
-- The currency symbol of authority token.
patSymbol :: Term s PCurrencySymbol
patSymbol = pconstant $ authorityTokenSymbol as
atSymbol :: Term s PCurrencySymbol
atSymbol = pconstant $ authorityTokenSymbol as
-- The currency symbol of the proposal state token.
ppstSymbol :: Term s PCurrencySymbol

34
agora/Agora/Utils.hs
View file

@ -1,5 +1,4 @@
{-# LANGUAGE QuantifiedConstraints #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{- |
Module : Agora.Utils
@ -16,12 +15,19 @@ module Agora.Utils (
CompiledValidator (..),
CompiledMintingPolicy (..),
CompiledEffect (..),
pvalidatorHashToTokenName,
pscriptHashToTokenName,
scriptHashToTokenName,
) where
import Plutarch.Api.V1 (PTokenName, PValidatorHash)
import Plutarch.Api.V2 (PScriptHash)
import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V2 (
Address (Address),
Credential (ScriptCredential),
MintingPolicy,
ScriptHash (ScriptHash),
TokenName (TokenName),
Validator,
ValidatorHash (ValidatorHash),
@ -31,7 +37,7 @@ import PlutusLedgerApi.V2 (
All of these functions are quite inefficient.
-}
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
{- | Safely convert a 'ValidatorHash' into a 'TokenName'. This can be useful for tagging
tokens for extra safety.
@since 0.1.0
@ -39,6 +45,30 @@ import PlutusLedgerApi.V2 (
validatorHashToTokenName :: ValidatorHash -> TokenName
validatorHashToTokenName (ValidatorHash hash) = TokenName hash
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
tokens for extra safety.
@since 1.0.0
-}
pvalidatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName
pvalidatorHashToTokenName = punsafeCoerce
{- | Safely convert a 'PScriptHash' into a 'PTokenName'. This can be useful for tagging
tokens for extra safety.
@since 1.0.0
-}
scriptHashToTokenName :: ScriptHash -> TokenName
scriptHashToTokenName (ScriptHash hash) = TokenName hash
{- | Safely convert a 'PScriptHash' into a 'PTokenName'. This can be useful for tagging
tokens for extra safety.
@since 1.0.0
-}
pscriptHashToTokenName :: forall (s :: S). Term s PScriptHash -> Term s PTokenName
pscriptHashToTokenName = punsafeCoerce
{- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
@since 0.1.0