Reset progress on treasury testing; will continue without apropos
This commit is contained in:
Jack Hodgkinson
commit
f81deaf062
37 changed files with 3029 additions and 1191 deletions
|
|
@ -2,7 +2,6 @@
|
|||
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 (
|
||||
|
|
@ -18,30 +17,28 @@ import Plutarch.Api.V1 (
|
|||
PCurrencySymbol (..),
|
||||
PScriptContext (..),
|
||||
PScriptPurpose (..),
|
||||
PTxInInfo (..),
|
||||
PTxInInfo (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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Utils (
|
||||
allInputs,
|
||||
allOutputs,
|
||||
passert,
|
||||
passetClassValueOf,
|
||||
passetClassValueOf',
|
||||
plookup,
|
||||
psymbolValueOf,
|
||||
ptokenSpent,
|
||||
)
|
||||
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -64,53 +61,35 @@ newtype AuthorityToken = AuthorityToken
|
|||
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 $ -- /Lift/ the `Term`.
|
||||
authorityTokensValidIn = phoistAcyclic $
|
||||
plam $ \authorityTokenSym txOut'' -> P.do
|
||||
-- Extract the desired fields: address and value, from the
|
||||
-- transaction output info.
|
||||
PTxOut txOut' <- pmatch txOut''
|
||||
txOut <- pletFields @'["address", "value"] $ txOut'
|
||||
PAddress address <- pmatch txOut.address
|
||||
PValue value' <- pmatch txOut.value
|
||||
PMap value <- pmatch value'
|
||||
|
||||
-- Search the transaction output info's value for the
|
||||
-- provided currency symbol for the authority token.
|
||||
pmatch (plookup # pdata authorityTokenSym # value) $ \case
|
||||
-- In the case of `PNothing`, no GATs exist at this output
|
||||
-- and ipso facto they are all valid.
|
||||
PNothing -> pconstant True
|
||||
-- This is the case wherein a TokenName/Integer map /has/
|
||||
-- been found for the given currency symbol.
|
||||
PJust (pfromData -> tokenMap') ->
|
||||
-- Now we need to look at the transaction output's
|
||||
-- address.
|
||||
pmatch (pfield @"credential" # address) $ \case
|
||||
-- GATs should only be sent to Effect validators,
|
||||
-- therefore we consider this invalid and return False.
|
||||
PPubKeyCredential _ -> pconstant False
|
||||
-- This is a script address. We need to ensure that
|
||||
-- the the `TokenName`s associated with the given
|
||||
-- currency symbol are all equal to this script
|
||||
-- address.
|
||||
PPubKeyCredential _ ->
|
||||
-- GATs should only be sent to Effect validators
|
||||
ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False
|
||||
PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> P.do
|
||||
-- Unwrap the `TokenName`/`Integer` map.
|
||||
PMap tokenMap <- pmatch tokenMap'
|
||||
|
||||
-- Check that the `TokenName` is equal to the validator
|
||||
-- hash for all of the `TokenName` keys in the map.
|
||||
pall
|
||||
# plam
|
||||
( \tnMap ->
|
||||
pforgetData (pfstBuiltin # tnMap)
|
||||
#== 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
|
||||
|
||||
-- | Assert that a single authority token has been burned.
|
||||
singleAuthorityTokenBurned ::
|
||||
|
|
@ -123,14 +102,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.
|
||||
|
|
@ -144,28 +129,21 @@ 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 ->
|
||||
allOutputs @PData # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
|
||||
authorityTokensValidIn
|
||||
# ownSymbol
|
||||
# txOut
|
||||
|
|
|
|||
|
|
@ -5,17 +5,13 @@ Description: Helpers for constructing effects
|
|||
|
||||
Helpers for constructing effects.
|
||||
-}
|
||||
module Agora.Effect (
|
||||
makeEffect,
|
||||
noopEffect,
|
||||
) where
|
||||
module Agora.Effect (makeEffect) where
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.Utils (passert)
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.TryFrom (PTryFrom, ptryFrom)
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -28,7 +24,7 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
|
|||
-}
|
||||
makeEffect ::
|
||||
forall (datum :: PType).
|
||||
PIsData datum =>
|
||||
(PIsData datum, PTryFrom PData datum) =>
|
||||
CurrencySymbol ->
|
||||
(forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
|
||||
ClosedTerm PValidator
|
||||
|
|
@ -37,29 +33,24 @@ makeEffect gatCs' f =
|
|||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
|
||||
-- TODO: Use PTryFrom
|
||||
let datum' :: Term _ datum
|
||||
datum' = pfromData $ punsafeCoerce datum
|
||||
-- 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', _) <- ptryFrom @datum datum
|
||||
|
||||
-- ensure purpose is Spending.
|
||||
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
|
||||
txOutRef' <- plet (pfield @"_0" # txOutRef)
|
||||
|
||||
-- fetch minted values to ensure single GAT is burned
|
||||
txInfo <- pletFields @'["mint"] txInfo'
|
||||
let mint :: Term _ PValue
|
||||
mint = txInfo.mint
|
||||
|
||||
-- fetch script context
|
||||
gatCs <- plet $ pconstant gatCs'
|
||||
|
||||
passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
|
||||
|
||||
-- run effect function
|
||||
f gatCs datum' txOutRef' txInfo'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Dummy effect which can only burn its GAT.
|
||||
noopEffect :: CurrencySymbol -> ClosedTerm PValidator
|
||||
noopEffect =
|
||||
( `makeEffect`
|
||||
\_gatCs (_datum :: Term _ PUnit) _txOutRef _txInfo -> P.do
|
||||
popaque (pconstant ())
|
||||
)
|
||||
|
|
|
|||
33
agora/Agora/Effect/NoOp.hs
Normal file
33
agora/Agora/Effect/NoOp.hs
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
{- |
|
||||
Module : Agora.Effect.NoOp
|
||||
Maintainer : seungheon.ooh@gmail.com
|
||||
Description: Dummy dumb dumb effect.
|
||||
|
||||
A dumb effect that only burns its GAT.
|
||||
-}
|
||||
module Agora.Effect.NoOp (noOpValidator, PNoOp) where
|
||||
|
||||
import Control.Applicative (Const)
|
||||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Plutarch.Api.V1 (PValidator)
|
||||
import Plutarch.TryFrom (PTryFrom (..))
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
|
||||
-- | Dummy datum for NoOp effect.
|
||||
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
|
||||
deriving (PlutusType, PIsData) via (DerivePNewtype PNoOp PUnit)
|
||||
|
||||
instance PTryFrom PData PNoOp where
|
||||
type PTryFromExcess PData PNoOp = Const ()
|
||||
ptryFrom' _ cont =
|
||||
-- JUSTIFICATION:
|
||||
-- We don't care anything about data.
|
||||
-- It should always be reduced to Unit.
|
||||
cont (pcon $ PNoOp (pconstant ()), ())
|
||||
|
||||
-- | Dummy effect which can only burn its GAT.
|
||||
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
|
||||
noOpValidator curr = makeEffect curr $
|
||||
\_ (_datum :: Term s PNoOp) _ _ -> P.do
|
||||
popaque (pconstant ())
|
||||
176
agora/Agora/Effect/TreasuryWithdrawal.hs
Normal file
176
agora/Agora/Effect/TreasuryWithdrawal.hs
Normal file
|
|
@ -0,0 +1,176 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.Effect.TreasuryWithdrawal
|
||||
Maintainer : seungheon.ooh@gmail.com
|
||||
Description: An Effect that withdraws treasury deposit
|
||||
|
||||
An Effect that withdraws treasury deposit
|
||||
-}
|
||||
module Agora.Effect.TreasuryWithdrawal (
|
||||
TreasuryWithdrawalDatum (..),
|
||||
PTreasuryWithdrawalDatum (..),
|
||||
treasuryWithdrawalValidator,
|
||||
) where
|
||||
|
||||
import Control.Applicative (Const)
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Agora.Utils (findTxOutByTxOutRef, paddValue, passert)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (..),
|
||||
PTuple,
|
||||
PValidator,
|
||||
PValue,
|
||||
ptuple,
|
||||
)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (..),
|
||||
)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.TryFrom (PTryFrom (..))
|
||||
import Plutus.V1.Ledger.Credential (Credential)
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
|
||||
import PlutusTx qualified
|
||||
|
||||
{- | Datum that encodes behavior of Treasury Withdrawal effect.
|
||||
|
||||
Note: This Datum acts like a "predefined redeemer". Which is to say that
|
||||
it encodes the properties a redeemer would, but is locked in-place until
|
||||
spend.
|
||||
-}
|
||||
data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
|
||||
{ receivers :: [(Credential, Value)]
|
||||
-- ^ AssocMap for Value sent to each receiver from the treasury.
|
||||
, treasuries :: [Credential]
|
||||
-- ^ What Credentials is spending from legal.
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
||||
PlutusTx.makeLift ''TreasuryWithdrawalDatum
|
||||
PlutusTx.makeIsDataIndexed ''TreasuryWithdrawalDatum [('TreasuryWithdrawalDatum, 0)]
|
||||
|
||||
-- | Haskell-level version of 'TreasuryWithdrawalDatum'.
|
||||
newtype PTreasuryWithdrawalDatum (s :: S)
|
||||
= PTreasuryWithdrawalDatum
|
||||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))
|
||||
, "treasuries" ':= PBuiltinList (PAsData PCredential)
|
||||
]
|
||||
)
|
||||
)
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic, PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via PIsDataReprInstances PTreasuryWithdrawalDatum
|
||||
|
||||
instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
|
||||
type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum
|
||||
|
||||
deriving via
|
||||
(DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
|
||||
instance
|
||||
(PConstantDecl TreasuryWithdrawalDatum)
|
||||
|
||||
instance PTryFrom PData PTreasuryWithdrawalDatum where
|
||||
type PTryFromExcess PData PTreasuryWithdrawalDatum = Const ()
|
||||
ptryFrom' opq cont =
|
||||
-- TODO: This should not use 'punsafeCoerce'.
|
||||
-- Blocked by 'PCredential', and 'PTuple'.
|
||||
cont (punsafeCoerce opq, ())
|
||||
|
||||
{- | Withdraws given list of values to specific target addresses.
|
||||
It can be evoked by burning GAT. The transaction should have correct
|
||||
outputs to the users and any left overs should be paid back to the treasury.
|
||||
|
||||
The validator does not accept any Redeemer as all "parameters" are provided
|
||||
via encoded Datum.
|
||||
|
||||
Note:
|
||||
It should check...
|
||||
1. Transaction outputs should contain all of what Datum specified
|
||||
2. Left over assets should be redirected back to Treasury
|
||||
It can be more flexiable over...
|
||||
- The number of outputs themselves
|
||||
-}
|
||||
treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
|
||||
treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
|
||||
\_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
|
||||
datum <- pletFields @'["receivers", "treasuries"] datum'
|
||||
txInfo <- pletFields @'["outputs", "inputs"] txInfo'
|
||||
PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo.inputs
|
||||
effInput <- pletFields @'["address", "value"] $ txOut
|
||||
outputValues <-
|
||||
plet $
|
||||
pmap
|
||||
# plam
|
||||
( \(pfromData -> txOut') -> P.do
|
||||
txOut <- pletFields @'["address", "value"] $ txOut'
|
||||
let cred = pfield @"credential" # pfromData txOut.address
|
||||
pdata $ ptuple # cred # txOut.value
|
||||
)
|
||||
# txInfo.outputs
|
||||
inputValues <-
|
||||
plet $
|
||||
pmap
|
||||
# plam
|
||||
( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do
|
||||
txOut <- pletFields @'["address", "value"] $ txOut'
|
||||
let cred = pfield @"credential" # pfromData txOut.address
|
||||
pdata $ ptuple # cred # txOut.value
|
||||
)
|
||||
# txInfo.inputs
|
||||
let ofTreasury =
|
||||
pfilter
|
||||
# plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
|
||||
sumValues =
|
||||
pfoldr
|
||||
# plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
|
||||
# pconstant (mempty :: Value)
|
||||
treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
|
||||
treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
|
||||
receiverValuesSum = sumValues # datum.receivers
|
||||
isPubkey = plam $ \cred -> P.do
|
||||
pmatch cred $ \case
|
||||
PPubKeyCredential _ -> pcon PTrue
|
||||
PScriptCredential _ -> pcon PFalse
|
||||
|
||||
-- Constraints
|
||||
outputContentMatchesRecivers =
|
||||
pall # plam (\out -> pelem # out # outputValues)
|
||||
#$ datum.receivers
|
||||
excessShouldBePaidToInputs =
|
||||
pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum
|
||||
shouldNotPayToEffect =
|
||||
pnot #$ pany
|
||||
# plam
|
||||
( \x ->
|
||||
effInput.address #== pfield @"address" # pfromData x
|
||||
)
|
||||
# pfromData txInfo.outputs
|
||||
inputsAreOnlyTreasuriesOrCollateral =
|
||||
pall
|
||||
# plam
|
||||
( \((pfield @"_0" #) . pfromData -> cred) ->
|
||||
cred #== pfield @"credential" # effInput.address
|
||||
#|| pelem # cred # datum.treasuries
|
||||
#|| isPubkey # pfromData cred
|
||||
)
|
||||
# inputValues
|
||||
|
||||
passert "Transaction should not pay to effects" shouldNotPayToEffect
|
||||
passert "Transaction output does not match receivers" outputContentMatchesRecivers
|
||||
passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
|
||||
passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuriesOrCollateral
|
||||
popaque $ pconstant ()
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.Governor
|
||||
Maintainer : emi@haskell.fyi
|
||||
|
|
@ -19,8 +21,8 @@ module Agora.Governor (
|
|||
) where
|
||||
|
||||
import Agora.Proposal (ProposalId, ProposalThresholds)
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Api.V1 (PMintingPolicy, PValidator)
|
||||
import PlutusTx qualified
|
||||
|
||||
-- | Datum for the Governor script.
|
||||
data GovernorDatum = GovernorDatum
|
||||
|
|
@ -30,6 +32,8 @@ data GovernorDatum = GovernorDatum
|
|||
-- ^ What tag the next proposal will get upon creating.
|
||||
}
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
|
||||
|
||||
{- | Redeemer for Governor script. The governor has two primary
|
||||
responsibilities:
|
||||
|
||||
|
|
@ -43,6 +47,8 @@ data GovernorRedeemer
|
|||
-- and allows minting GATs for each effect script.
|
||||
MintGATs
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''GovernorRedeemer [('CreateProposal, 0), ('MintGATs, 1)]
|
||||
|
||||
-- | Parameters for creating Governor scripts.
|
||||
data Governor
|
||||
= Governor
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ import Plutarch.DataRepr (
|
|||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Lift (
|
||||
PConstantDecl,
|
||||
PLifted,
|
||||
PUnsafeLiftDecl,
|
||||
)
|
||||
|
|
@ -73,7 +74,7 @@ newtype PMultiSig (s :: S) = PMultiSig
|
|||
via (PIsDataReprInstances PMultiSig)
|
||||
|
||||
instance PUnsafeLiftDecl PMultiSig where type PLifted PMultiSig = MultiSig
|
||||
deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstant MultiSig)
|
||||
deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstantDecl MultiSig)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -11,23 +11,25 @@ module Agora.Proposal (
|
|||
-- * Haskell-land
|
||||
Proposal (..),
|
||||
ProposalDatum (..),
|
||||
ProposalRedeemer (..),
|
||||
ProposalStatus (..),
|
||||
ProposalThresholds (..),
|
||||
ProposalVotes (..),
|
||||
ProposalId (..),
|
||||
ResultTag (..),
|
||||
emptyVotesFor,
|
||||
|
||||
-- * Plutarch-land
|
||||
PProposalDatum (..),
|
||||
PProposalRedeemer (..),
|
||||
PProposalStatus (..),
|
||||
PProposalThresholds (..),
|
||||
PProposalVotes (..),
|
||||
PProposalId (..),
|
||||
PResultTag (..),
|
||||
|
||||
-- * Scripts
|
||||
proposalValidator,
|
||||
proposalPolicy,
|
||||
-- * Plutarch helpers
|
||||
proposalDatumValid,
|
||||
) where
|
||||
|
||||
import GHC.Generics qualified as GHC
|
||||
|
|
@ -35,30 +37,44 @@ import Generics.SOP (Generic, I (I))
|
|||
import Plutarch.Api.V1 (
|
||||
PDatumHash,
|
||||
PMap,
|
||||
PMintingPolicy,
|
||||
PPubKeyHash,
|
||||
PValidator,
|
||||
PValidatorHash,
|
||||
)
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
|
||||
import PlutusTx qualified
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..))
|
||||
import Agora.Utils (pkeysEqual, pnotNull)
|
||||
import Control.Applicative (Const)
|
||||
import Control.Arrow (first)
|
||||
import Plutarch.Builtin (PBuiltinMap)
|
||||
import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..))
|
||||
import Plutarch.Lift (
|
||||
DerivePConstantViaNewtype (..),
|
||||
PConstantDecl,
|
||||
PUnsafeLiftDecl (..),
|
||||
)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.SafeMoney (PDiscrete, Tagged)
|
||||
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
|
||||
import Plutus.V1.Ledger.Value (AssetClass)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Haskell-land
|
||||
|
||||
{- | Identifies a Proposal, issued upon creation of a proposal. In practice,
|
||||
this number starts at zero, and increments by one for each proposal.
|
||||
The 100th proposal will be @'ProposalId' 99@. This counter lives
|
||||
in the 'Agora.Governor.Governor'. See 'Agora.Governor.nextProposalId', and
|
||||
'Agora.Governor.pgetNextProposalId'.
|
||||
-}
|
||||
newtype ProposalId = ProposalId {proposalTag :: Integer}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
{- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
|
||||
|
||||
@
|
||||
|
|
@ -70,8 +86,10 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
|
|||
deriving stock (Eq, Show, Ord)
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
|
||||
{- | The "status" of the proposal. This is only useful for state transitions,
|
||||
as opposed to time-based "phases".
|
||||
{- | The "status" of the proposal. This is only useful for state transitions that
|
||||
need to happen as a result of a transaction as opposed to time-based "periods".
|
||||
|
||||
See the note on wording & the state machine in the tech-design.
|
||||
|
||||
If the proposal is 'VotingReady', for instance, that doesn't necessarily
|
||||
mean that voting is possible, as this also requires the timing to be right.
|
||||
|
|
@ -92,28 +110,39 @@ data ProposalStatus
|
|||
-- This means that once the timing requirements align,
|
||||
-- proposal will be able to be voted on.
|
||||
VotingReady
|
||||
| -- | The proposal has been voted on, and the votes have been locked
|
||||
-- permanently. The proposal now goes into a locking time after the
|
||||
-- normal voting time. After this, it's possible to execute the proposal.
|
||||
Locked
|
||||
| -- | The proposal has finished.
|
||||
--
|
||||
-- This can mean it's been voted on and completed, but it can also mean
|
||||
-- the proposal failed due to time constraints or didn't
|
||||
-- the proposal failed due to time constraints or didn't
|
||||
-- get to 'VotingReady' first.
|
||||
--
|
||||
-- At this stage, the 'votes' field of 'ProposalDatum' is frozen.
|
||||
--
|
||||
-- See 'AdvanceProposal' for documentation on state transitions.
|
||||
--
|
||||
-- TODO: The owner of the proposal may choose to reclaim their proposal.
|
||||
Finished
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Finished, 2)]
|
||||
PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Locked, 2), ('Finished, 3)]
|
||||
|
||||
{- | The threshold values for various state transitions to happen.
|
||||
This data is stored centrally (in the 'Agora.Governor.Governor') and copied over
|
||||
to 'Proposal's when they are created.
|
||||
-}
|
||||
data ProposalThresholds = ProposalThresholds
|
||||
{ execute :: Tagged GTTag Integer
|
||||
{ countVoting :: Tagged GTTag Integer
|
||||
-- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass.
|
||||
, draft :: Tagged GTTag Integer
|
||||
, create :: Tagged GTTag Integer
|
||||
-- ^ How much GT required to "create" a proposal.
|
||||
, vote :: Tagged GTTag Integer
|
||||
--
|
||||
-- It is recommended this be a high enough amount, in order to prevent DOS from bad
|
||||
-- actors.
|
||||
, startVoting :: Tagged GTTag Integer
|
||||
-- ^ How much GT required to allow voting to happen.
|
||||
-- (i.e. to move into 'VotingReady')
|
||||
}
|
||||
|
|
@ -138,9 +167,15 @@ newtype ProposalVotes = ProposalVotes
|
|||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
-- | Create a 'ProposalVotes' that has the same shape as the 'effects' field.
|
||||
emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
|
||||
emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)
|
||||
|
||||
-- | Haskell-level datum for Proposal scripts.
|
||||
data ProposalDatum = ProposalDatum
|
||||
{ -- TODO: could we encode this more efficiently?
|
||||
{ proposalId :: ProposalId
|
||||
-- ^ Identification of the proposal.
|
||||
, -- TODO: could we encode this more efficiently?
|
||||
-- This is shaped this way for future proofing.
|
||||
-- See https://github.com/Liqwid-Labs/agora/issues/39
|
||||
effects :: AssocMap.Map ResultTag [(ValidatorHash, DatumHash)]
|
||||
|
|
@ -158,17 +193,62 @@ data ProposalDatum = ProposalDatum
|
|||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
|
||||
|
||||
{- | Identifies a Proposal, issued upon creation of a proposal.
|
||||
In practice, this number starts at zero, and increments by one
|
||||
for each proposal. The 100th proposal will be @'ProposalId' 99@.
|
||||
This counter lives in the 'Governor', see 'nextProposalId'.
|
||||
-}
|
||||
newtype ProposalId = ProposalId {proposalTag :: Integer}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
-- | Haskell-level redeemer for Proposal scripts.
|
||||
data ProposalRedeemer
|
||||
= -- | Cast one or more votes towards a particular 'ResultTag'.
|
||||
Vote ResultTag
|
||||
| -- | Add one or more public keys to the cosignature list.
|
||||
-- Must be signed by those cosigning.
|
||||
--
|
||||
-- This is particularly used in the 'Draft' 'ProposalStatus',
|
||||
-- where matching 'Agora.Stake.Stake's can be called to advance the proposal,
|
||||
-- provided enough GT is shared among them.
|
||||
Cosign [PubKeyHash]
|
||||
| -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
|
||||
Unlock ResultTag
|
||||
| -- | Advance the proposal, performing the required checks for whether that is legal.
|
||||
--
|
||||
-- These are roughly the checks for each possible transition:
|
||||
--
|
||||
-- === @'Draft' -> 'VotingReady'@:
|
||||
--
|
||||
-- 1. The sum of all of the cosigner's GT is larger than the 'startVoting' field of 'ProposalThresholds'.
|
||||
-- 2. The proposal's current time ensures 'isDraftPeriod'.
|
||||
--
|
||||
-- === @'VotingReady' -> 'Locked'@:
|
||||
--
|
||||
-- 1. The sum of all votes is larger than 'countVoting'.
|
||||
-- 2. The winning 'ResultTag' has more votes than all other 'ResultTag's.
|
||||
-- 3. The proposal's current time ensures 'isVotingPeriod'.
|
||||
--
|
||||
-- === @'Locked' -> 'Finished'@:
|
||||
--
|
||||
-- 1. The proposal's current time ensures 'isExecutionPeriod'.
|
||||
-- 2. The transaction mints the GATs to the receiving effects.
|
||||
--
|
||||
-- === @* -> 'Finished'@:
|
||||
--
|
||||
-- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible
|
||||
-- to transition into 'Finished' status, because it has expired (and failed).
|
||||
AdvanceProposal
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
''ProposalRedeemer
|
||||
[ ('Vote, 0)
|
||||
, ('Cosign, 1)
|
||||
, ('Unlock, 2)
|
||||
, ('AdvanceProposal, 3)
|
||||
]
|
||||
|
||||
-- | Parameters that identify the Proposal validator script.
|
||||
data Proposal = Proposal
|
||||
{ governorSTAssetClass :: AssetClass
|
||||
, stakeSTAssetClass :: AssetClass
|
||||
, maximumCosigners :: Integer
|
||||
-- ^ Arbitrary limit for maximum amount of cosigners on a proposal.
|
||||
}
|
||||
deriving stock (Show, Eq)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Plutarch-land
|
||||
|
|
@ -181,17 +261,37 @@ instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag
|
|||
deriving via
|
||||
(DerivePConstantViaNewtype ResultTag PResultTag PInteger)
|
||||
instance
|
||||
(PConstant ResultTag)
|
||||
(PConstantDecl ResultTag)
|
||||
|
||||
-- FIXME: This instance and the one below, for 'PProposalId', should be derived.
|
||||
-- Soon this will be possible through 'DerivePNewtype'.
|
||||
instance PTryFrom PData (PAsData PResultTag) where
|
||||
type PTryFromExcess PData (PAsData PResultTag) = PTryFromExcess PData (PAsData PInteger)
|
||||
ptryFrom' d k =
|
||||
ptryFrom' @_ @(PAsData PInteger) d $
|
||||
-- JUSTIFICATION:
|
||||
-- We are coercing from @PAsData PInteger@ to @PAsData PResultTag@.
|
||||
-- Since 'PResultTag' is a simple newtype, their shape is the same.
|
||||
k . first punsafeCoerce
|
||||
|
||||
-- | Plutarch-level version of 'PProposalId'.
|
||||
newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalId PInteger)
|
||||
|
||||
instance PTryFrom PData (PAsData PProposalId) where
|
||||
type PTryFromExcess PData (PAsData PProposalId) = PTryFromExcess PData (PAsData PInteger)
|
||||
ptryFrom' d k =
|
||||
ptryFrom' @_ @(PAsData PInteger) d $
|
||||
-- JUSTIFICATION:
|
||||
-- We are coercing from @PAsData PInteger@ to @PAsData PProposalId@.
|
||||
-- Since 'PProposalId' is a simple newtype, their shape is the same.
|
||||
k . first punsafeCoerce
|
||||
|
||||
instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
|
||||
deriving via
|
||||
(DerivePConstantViaNewtype ProposalId PProposalId PInteger)
|
||||
instance
|
||||
(PConstant ProposalId)
|
||||
(PConstantDecl ProposalId)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalStatus'.
|
||||
data PProposalStatus (s :: S)
|
||||
|
|
@ -199,6 +299,7 @@ data PProposalStatus (s :: S)
|
|||
-- e.g. like Tilde used 'pmatchEnum'.
|
||||
PDraft (Term s (PDataRecord '[]))
|
||||
| PVotingReady (Term s (PDataRecord '[]))
|
||||
| PLocked (Term s (PDataRecord '[]))
|
||||
| PFinished (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
|
@ -208,7 +309,7 @@ data PProposalStatus (s :: S)
|
|||
via PIsDataReprInstances PProposalStatus
|
||||
|
||||
instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
|
||||
deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstant ProposalStatus)
|
||||
deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalThresholds'.
|
||||
newtype PProposalThresholds (s :: S) = PProposalThresholds
|
||||
|
|
@ -230,7 +331,7 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
|
|||
via (PIsDataReprInstances PProposalThresholds)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
|
||||
deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstant ProposalThresholds)
|
||||
deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstantDecl ProposalThresholds)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalVotes'.
|
||||
newtype PProposalVotes (s :: S)
|
||||
|
|
@ -241,7 +342,7 @@ instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = Prop
|
|||
deriving via
|
||||
(DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap PResultTag PInteger))
|
||||
instance
|
||||
(PConstant ProposalVotes)
|
||||
(PConstantDecl ProposalVotes)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalDatum'.
|
||||
newtype PProposalDatum (s :: S) = PProposalDatum
|
||||
|
|
@ -249,9 +350,10 @@ newtype PProposalDatum (s :: S) = PProposalDatum
|
|||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
|
||||
'[ "proposalId" ':= PProposalId
|
||||
, "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
|
||||
, "status" ':= PProposalStatus
|
||||
, "cosigners" ':= PBuiltinList PPubKeyHash
|
||||
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
|
||||
, "thresholds" ':= PProposalThresholds
|
||||
, "votes" ':= PProposalVotes
|
||||
]
|
||||
|
|
@ -264,19 +366,71 @@ newtype PProposalDatum (s :: S) = PProposalDatum
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalDatum)
|
||||
|
||||
-- TODO: Derive this.
|
||||
instance PTryFrom PData (PAsData PProposalDatum) where
|
||||
type PTryFromExcess PData (PAsData PProposalDatum) = Const ()
|
||||
ptryFrom' d k =
|
||||
k (punsafeCoerce d, ())
|
||||
|
||||
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
|
||||
deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum)
|
||||
deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalRedeemer'.
|
||||
data PProposalRedeemer (s :: S)
|
||||
= PVote (Term s (PDataRecord '["resultTag" ':= PResultTag]))
|
||||
| PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)]))
|
||||
| PUnlock (Term s (PDataRecord '["resultTag" ':= PResultTag]))
|
||||
| PAdvanceProposal (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PProposalRedeemer
|
||||
|
||||
-- See below.
|
||||
instance PTryFrom PData (PAsData PProposalRedeemer) where
|
||||
type PTryFromExcess PData (PAsData PProposalRedeemer) = Const ()
|
||||
ptryFrom' d k =
|
||||
k (punsafeCoerce d, ())
|
||||
|
||||
-- TODO: Waiting on PTryFrom for 'PPubKeyHash'
|
||||
-- deriving via
|
||||
-- PAsData (PIsDataReprInstances PProposalRedeemer)
|
||||
-- instance
|
||||
-- PTryFrom PData (PAsData PProposalRedeemer)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
|
||||
deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Policy for Proposals.
|
||||
proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
|
||||
proposalPolicy _ =
|
||||
plam $ \_redeemer _ctx' -> P.do
|
||||
popaque (pconstant ())
|
||||
{- | Check for various invariants a proposal must uphold.
|
||||
This can be used to check both upon creation and
|
||||
upon any following state transitions in the proposal.
|
||||
-}
|
||||
proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool)
|
||||
proposalDatumValid proposal =
|
||||
phoistAcyclic $
|
||||
plam $ \datum' -> P.do
|
||||
datum <- pletFields @'["effects", "cosigners", "votes"] $ datum'
|
||||
|
||||
-- | Validator for Proposals.
|
||||
proposalValidator :: Proposal -> ClosedTerm PValidator
|
||||
proposalValidator _ =
|
||||
plam $ \_datum _redeemer _ctx' -> P.do
|
||||
popaque (pconstant ())
|
||||
let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash))
|
||||
effects =
|
||||
-- JUSTIFICATION:
|
||||
-- @datum.effects : PMap PResultTag (PMap PValidatorHash PDatumHash)@
|
||||
-- @PMap PResultTag (PMap PValidatorHash PDatumHash)@ is equivalent to
|
||||
-- @PBuiltinMap PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)@
|
||||
punsafeCoerce datum.effects
|
||||
|
||||
atLeastOneNegativeResult :: Term _ PBool
|
||||
atLeastOneNegativeResult =
|
||||
pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
|
||||
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
|
||||
, ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
|
||||
, ptraceIfFalse "Proposal has fewer cosigners than the limit" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners
|
||||
, ptraceIfFalse "Proposal votes and effects are compatible with each other" $ pkeysEqual # datum.effects # pto (pfromData datum.votes)
|
||||
]
|
||||
|
|
|
|||
228
agora/Agora/Proposal/Scripts.hs
Normal file
228
agora/Agora/Proposal/Scripts.hs
Normal file
|
|
@ -0,0 +1,228 @@
|
|||
{- |
|
||||
Module : Agora.Proposal.Scripts
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Plutus Scripts for Proposals.
|
||||
|
||||
Plutus Scripts for Proposals.
|
||||
-}
|
||||
module Agora.Proposal.Scripts (
|
||||
proposalValidator,
|
||||
proposalPolicy,
|
||||
) where
|
||||
|
||||
import Agora.Proposal (
|
||||
PProposalDatum (PProposalDatum),
|
||||
PProposalRedeemer (..),
|
||||
Proposal (governorSTAssetClass, stakeSTAssetClass),
|
||||
)
|
||||
import Agora.Record (mkRecordConstr, (.&), (.=))
|
||||
import Agora.Stake (findStakeOwnedBy)
|
||||
import Agora.Utils (
|
||||
anyOutput,
|
||||
findTxOutByTxOutRef,
|
||||
getMintingPolicySymbol,
|
||||
passert,
|
||||
pisUniq,
|
||||
psymbolValueOf,
|
||||
ptokenSpent,
|
||||
ptxSignedBy,
|
||||
pvalueSpent,
|
||||
)
|
||||
import Plutarch.Api.V1 (
|
||||
PMintingPolicy,
|
||||
PScriptContext (PScriptContext),
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
PTxInfo (PTxInfo),
|
||||
PValidator,
|
||||
)
|
||||
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.TryFrom (ptryFrom)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
|
||||
{- | Policy for Proposals.
|
||||
|
||||
== What this policy does
|
||||
|
||||
=== For minting:
|
||||
|
||||
- Governor is happy with mint.
|
||||
|
||||
* The governor must do most of the checking for the validity of the
|
||||
transaction. For example, the governor must check that the datum
|
||||
is correct, and that the ST is correctly paid to the right validator.
|
||||
|
||||
- Exactly 1 token is minted.
|
||||
|
||||
=== For burning:
|
||||
|
||||
- This policy cannot be burned.
|
||||
-}
|
||||
proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
|
||||
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 ())
|
||||
|
||||
{- | The validator for Proposals.
|
||||
|
||||
The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
|
||||
|
||||
== What this validator does
|
||||
|
||||
=== Voting/unlocking
|
||||
|
||||
When voting and unlocking, the proposal must witness a state transition
|
||||
occuring in the relevant Stake. This transition must place a lock on
|
||||
the stake that is tagged with the right 'Agora.Proposal.ResultTag', and 'Agora.Proposal.ProposalId'.
|
||||
|
||||
=== Periods
|
||||
|
||||
Most redeemers are time-sensitive.
|
||||
|
||||
A list of all time-sensitive redeemers and their requirements:
|
||||
|
||||
- 'Agora.Proposal.Vote' can only be used when both the status is in 'Agora.Proposal.VotingReady',
|
||||
and 'Agora.Proposal.Time.isVotingPeriod' is true.
|
||||
- 'Agora.Proposal.Cosign' can only be used when both the status is in 'Agora.Proposal.Draft',
|
||||
and 'Agora.Proposal.Time.isDraftPeriod' is true.
|
||||
- 'Agora.Proposal.AdvanceProposal' can only be used when the status can be advanced
|
||||
(see 'Agora.Proposal.AdvanceProposal' docs).
|
||||
- 'Agora.Proposal.Unlock' is always valid.
|
||||
-}
|
||||
proposalValidator :: Proposal -> ClosedTerm PValidator
|
||||
proposalValidator proposal =
|
||||
plam $ \datum redeemer ctx' -> P.do
|
||||
PScriptContext ctx' <- pmatch ctx'
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- plet $ pfromData ctx.txInfo
|
||||
PTxInfo txInfo' <- pmatch txInfo
|
||||
txInfoF <- pletFields @'["inputs", "mint", "datums", "signatories"] txInfo'
|
||||
PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
|
||||
|
||||
PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
|
||||
txOutF <- pletFields @'["address", "value"] $ txOut
|
||||
|
||||
(pfromData -> proposalDatum, _) <-
|
||||
ptryFrom @(PAsData PProposalDatum) datum
|
||||
(pfromData -> proposalRedeemer, _) <-
|
||||
ptryFrom @(PAsData PProposalRedeemer) redeemer
|
||||
|
||||
proposalF <-
|
||||
pletFields
|
||||
@'[ "proposalId"
|
||||
, "effects"
|
||||
, "status"
|
||||
, "cosigners"
|
||||
, "thresholds"
|
||||
, "votes"
|
||||
]
|
||||
proposalDatum
|
||||
|
||||
ownAddress <- plet $ txOutF.address
|
||||
|
||||
let stCurrencySymbol =
|
||||
pconstant $ getMintingPolicySymbol (proposalPolicy proposal)
|
||||
valueSpent <- plet $ pvalueSpent # txInfoF.inputs
|
||||
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
|
||||
let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
|
||||
stakeSTAssetClass <-
|
||||
plet $ passetClass # pconstant stakeSym # pconstant stakeTn
|
||||
spentStakeST <-
|
||||
plet $ passetClassValueOf # valueSpent # stakeSTAssetClass
|
||||
|
||||
signedBy <- plet $ ptxSignedBy # txInfoF.signatories
|
||||
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
pmatch proposalRedeemer $ \case
|
||||
PVote _r -> P.do
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PCosign r -> P.do
|
||||
newSigs <- plet $ pfield @"newCosigners" # r
|
||||
|
||||
passert "Cosigners are unique" $
|
||||
pisUniq # newSigs
|
||||
|
||||
passert "Signed by all new cosigners" $
|
||||
pall # signedBy # newSigs
|
||||
|
||||
passert "As many new cosigners as Stake datums" $
|
||||
spentStakeST #== plength # newSigs
|
||||
|
||||
passert "All new cosigners are witnessed by their Stake datums" $
|
||||
pall
|
||||
# plam
|
||||
( \sig ->
|
||||
pmatch
|
||||
( findStakeOwnedBy # stakeSTAssetClass
|
||||
# pfromData sig
|
||||
# txInfoF.datums
|
||||
# txInfoF.inputs
|
||||
)
|
||||
$ \case
|
||||
PNothing -> pcon PFalse
|
||||
PJust _ -> pcon PTrue
|
||||
)
|
||||
# newSigs
|
||||
|
||||
passert "Signatures are correctly added to cosignature list" $
|
||||
anyOutput @PProposalDatum # ctx.txInfo
|
||||
#$ plam
|
||||
$ \newValue address newProposalDatum -> P.do
|
||||
let updatedSigs = pconcat # newSigs # proposalF.cosigners
|
||||
correctDatum =
|
||||
pdata newProposalDatum
|
||||
#== pdata
|
||||
( mkRecordConstr
|
||||
PProposalDatum
|
||||
( #proposalId .= proposalF.proposalId
|
||||
.& #effects .= proposalF.effects
|
||||
.& #status .= proposalF.status
|
||||
.& #cosigners .= pdata updatedSigs
|
||||
.& #thresholds .= proposalF.thresholds
|
||||
.& #votes .= proposalF.votes
|
||||
)
|
||||
)
|
||||
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Datum must be correct" correctDatum
|
||||
, ptraceIfFalse "Value should be correct" $
|
||||
pdata txOutF.value #== pdata newValue
|
||||
, ptraceIfFalse "Must be sent to Proposal's address" $
|
||||
ownAddress #== pdata address
|
||||
]
|
||||
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PUnlock _r -> P.do
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PAdvanceProposal _r -> P.do
|
||||
popaque (pconstant ())
|
||||
262
agora/Agora/Proposal/Time.hs
Normal file
262
agora/Agora/Proposal/Time.hs
Normal file
|
|
@ -0,0 +1,262 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.Proposal.Time
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Time functions for proposal phases.
|
||||
|
||||
Time functions for proposal phases.
|
||||
-}
|
||||
module Agora.Proposal.Time (
|
||||
-- * Haskell-land
|
||||
ProposalTime (..),
|
||||
ProposalTimingConfig (..),
|
||||
ProposalStartingTime (..),
|
||||
|
||||
-- * Plutarch-land
|
||||
PProposalTime (..),
|
||||
PProposalTimingConfig (..),
|
||||
PProposalStartingTime (..),
|
||||
|
||||
-- * Compute periods given config and starting time.
|
||||
currentProposalTime,
|
||||
isDraftPeriod,
|
||||
isVotingPeriod,
|
||||
isLockingPeriod,
|
||||
isExecutionPeriod,
|
||||
) where
|
||||
|
||||
import Agora.Record (mkRecordConstr, (.&), (.=))
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Plutarch.Api.V1 (
|
||||
PExtended (PFinite),
|
||||
PInterval (PInterval),
|
||||
PLowerBound (PLowerBound),
|
||||
PPOSIXTime,
|
||||
PPOSIXTimeRange,
|
||||
PUpperBound (PUpperBound),
|
||||
)
|
||||
import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.Numeric (AdditiveSemigroup ((+)))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import Plutus.V1.Ledger.Time (POSIXTime)
|
||||
import PlutusTx qualified
|
||||
import Prelude hiding ((+))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | == Establishing timing in Proposal interactions.
|
||||
|
||||
In Plutus, it's impossible to determine time exactly. It's also impossible
|
||||
to get a single point in time, yet often we need to check
|
||||
various constraints on time.
|
||||
|
||||
For the purposes of proposals, there's a single most important feature:
|
||||
The ability to determine if we can perform an action. In order to correctly
|
||||
determine if we are able to perform certain actions, we need to know what
|
||||
time it roughly is, compared to when the proposal was created.
|
||||
|
||||
'ProposalTime' represents "the time according to the proposal".
|
||||
Its representation is opaque, and doesn't matter.
|
||||
|
||||
Various functions work simply on 'ProposalTime' and 'ProposalTimingConfig'.
|
||||
In particular, 'currentProposalTime' is useful for extracting the time
|
||||
from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field
|
||||
of 'Plutus.V1.Ledger.Api.TxInfo'.
|
||||
|
||||
We avoid 'PPOSIXTimeRange' where we can in order to save on operations.
|
||||
-}
|
||||
data ProposalTime = ProposalTime
|
||||
{ lowerBound :: POSIXTime
|
||||
, upperBound :: POSIXTime
|
||||
}
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalTime [('ProposalTime, 0)]
|
||||
|
||||
-- | Represents the starting time of the proposal.
|
||||
newtype ProposalStartingTime = ProposalStartingTime
|
||||
{ getProposalStartingTime :: POSIXTime
|
||||
}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
{- | Configuration of proposal timings.
|
||||
|
||||
See: https://github.com/Liqwid-Labs/agora/blob/master/docs/tech-design/proposals.md#when-may-interactions-occur
|
||||
-}
|
||||
data ProposalTimingConfig = ProposalTimingConfig
|
||||
{ draftTime :: POSIXTime
|
||||
-- ^ "D": the length of the draft period.
|
||||
, votingTime :: POSIXTime
|
||||
-- ^ "V": the length of the voting period.
|
||||
, lockingTime :: POSIXTime
|
||||
-- ^ "L": the length of the locking period.
|
||||
, executingTime :: POSIXTime
|
||||
-- ^ "E": the length of the execution period.
|
||||
}
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Plutarch-level version of 'ProposalTime'.
|
||||
newtype PProposalTime (s :: S)
|
||||
= PProposalTime
|
||||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "lowerBound" ':= PPOSIXTime
|
||||
, "upperBound" ':= PPOSIXTime
|
||||
]
|
||||
)
|
||||
)
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalTime)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalStartingTime'.
|
||||
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalStartingTime PPOSIXTime)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalTimingConfig'.
|
||||
newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
|
||||
{ getProposalTimingConfig ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "draftTime" ':= PPOSIXTime
|
||||
, "votingTime" ':= PPOSIXTime
|
||||
, "lockingTime" ':= PPOSIXTime
|
||||
, "executingTime" ':= PPOSIXTime
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalTimingConfig)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- FIXME: Orphan instance, move this to plutarch-extra.
|
||||
instance AdditiveSemigroup (Term s PPOSIXTime) where
|
||||
(punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
|
||||
|
||||
{- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field.
|
||||
|
||||
If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is
|
||||
an infinity) then we error out.
|
||||
-}
|
||||
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
|
||||
currentProposalTime = phoistAcyclic $
|
||||
plam $ \iv -> P.do
|
||||
PInterval iv' <- pmatch iv
|
||||
ivf <- pletFields @'["from", "to"] iv'
|
||||
PLowerBound lb <- pmatch ivf.from
|
||||
PUpperBound ub <- pmatch ivf.to
|
||||
lbf <- pletFields @'["_0", "_1"] lb
|
||||
ubf <- pletFields @'["_0", "_1"] ub
|
||||
mkRecordConstr PProposalTime $
|
||||
#lowerBound
|
||||
.= pmatch
|
||||
lbf._0
|
||||
( \case
|
||||
PFinite ((pfield @"_0" #) -> d) -> d
|
||||
_ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
|
||||
)
|
||||
.& #upperBound
|
||||
.= pmatch
|
||||
ubf._0
|
||||
( \case
|
||||
PFinite ((pfield @"_0" #) -> d) -> d
|
||||
_ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
|
||||
)
|
||||
|
||||
-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
|
||||
proposalTimeWithin ::
|
||||
Term
|
||||
s
|
||||
( PPOSIXTime
|
||||
:--> PPOSIXTime
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
proposalTimeWithin = phoistAcyclic $
|
||||
plam $ \l h proposalTime' -> P.do
|
||||
PProposalTime proposalTime <- pmatch proposalTime'
|
||||
ptf <- pletFields @'["lowerBound", "upperBound"] proposalTime
|
||||
foldr1
|
||||
(#&&)
|
||||
[ l #<= pfromData ptf.lowerBound
|
||||
, pfromData ptf.upperBound #<= h
|
||||
]
|
||||
|
||||
-- | True if the 'PProposalTime' is in the draft period.
|
||||
isDraftPeriod ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PProposalTimingConfig
|
||||
:--> PProposalStartingTime
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
isDraftPeriod = phoistAcyclic $
|
||||
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
|
||||
proposalTimeWithin # s # (s + pfield @"draftTime" # config)
|
||||
|
||||
-- | True if the 'PProposalTime' is in the voting period.
|
||||
isVotingPeriod ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PProposalTimingConfig
|
||||
:--> PProposalStartingTime
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
isVotingPeriod = phoistAcyclic $
|
||||
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
|
||||
pletFields @'["draftTime", "votingTime"] config $ \f ->
|
||||
proposalTimeWithin # s # (s + f.draftTime + f.votingTime)
|
||||
|
||||
-- | True if the 'PProposalTime' is in the locking period.
|
||||
isLockingPeriod ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PProposalTimingConfig
|
||||
:--> PProposalStartingTime
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
isLockingPeriod = phoistAcyclic $
|
||||
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
|
||||
pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f ->
|
||||
proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
|
||||
|
||||
-- | True if the 'PProposalTime' is in the execution period.
|
||||
isExecutionPeriod ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PProposalTimingConfig
|
||||
:--> PProposalStartingTime
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
isExecutionPeriod = phoistAcyclic $
|
||||
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
|
||||
pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f ->
|
||||
proposalTimeWithin # s
|
||||
# (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime)
|
||||
108
agora/Agora/Record.hs
Normal file
108
agora/Agora/Record.hs
Normal file
|
|
@ -0,0 +1,108 @@
|
|||
{- |
|
||||
Module : Agora.Record
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: PDataRecord helper functions.
|
||||
|
||||
'PDataRecord' helper functions.
|
||||
-}
|
||||
module Agora.Record (
|
||||
mkRecord,
|
||||
mkRecordConstr,
|
||||
(.=),
|
||||
(.&),
|
||||
RecordMorphism,
|
||||
FieldName,
|
||||
) where
|
||||
|
||||
import Control.Category (Category (..))
|
||||
import Data.Coerce (coerce)
|
||||
import GHC.OverloadedLabels (IsLabel (fromLabel))
|
||||
import GHC.TypeLits (Symbol)
|
||||
import Plutarch.DataRepr (PDataRecord (PDCons))
|
||||
import Prelude hiding (id, (.))
|
||||
|
||||
-- | Like 'Data.Proxy.Proxy' but local to this module.
|
||||
data FieldName (sym :: Symbol) = FieldName
|
||||
|
||||
{- | The use of two different 'Symbol's here allows unification to happen,
|
||||
ensuring 'FieldName' has a fully inferred 'Symbol'.
|
||||
|
||||
For example, @'mkRecord' (#foo .= 'pconstantData' (42 :: 'Integer'))@ gets
|
||||
the correct type. Namely, @'Term' s ('PDataRecord' '["foo" ':= 'PInteger'])@.
|
||||
-}
|
||||
instance forall (sym :: Symbol) (sym' :: Symbol). sym ~ sym' => IsLabel sym (FieldName sym) where
|
||||
fromLabel = FieldName
|
||||
|
||||
-- | Turn a constant 'RecordMorphism' into a fully built 'PDataRecord'.
|
||||
mkRecord :: forall (r :: [PLabeledType]) (s :: S). RecordMorphism s '[] r -> Term s (PDataRecord r)
|
||||
mkRecord f = f.runRecordMorphism pdnil
|
||||
|
||||
{- | 'mkRecord' but for known data-types.
|
||||
|
||||
This allows you to dynamically construct a record type constructor.
|
||||
|
||||
=== Example:
|
||||
@
|
||||
'mkRecordConstr'
|
||||
'Agora.Stake.PStakeDatum'
|
||||
( #stakedAmount '.=' 'pconstantData' ('Plutarch.SafeMoney.Tagged' @GTTag 42)
|
||||
'.&' #owner '.=' 'pconstantData' "aabbcc"
|
||||
'.&' #lockedBy '.=' 'pdata' pnil
|
||||
)
|
||||
@
|
||||
Is the same as
|
||||
|
||||
@
|
||||
'pconstant' ('Agora.Stake.StakeDatum' ('Plutarch.SafeMoney.Tagged' 42) "aabbcc" [])
|
||||
@
|
||||
-}
|
||||
mkRecordConstr ::
|
||||
forall (r :: [PLabeledType]) (s :: S) (pt :: PType).
|
||||
PlutusType pt =>
|
||||
-- | The constructor. This is just the Haskell-level constructor for the type.
|
||||
-- For 'Plutarch.Api.V1.Maybe.PMaybeData', this would
|
||||
-- be 'Plutarch.Api.V1.Maybe.PDJust', or 'Plutarch.Api.V1.Maybe.PNothing'.
|
||||
(forall s'. Term s' (PDataRecord r) -> pt s') ->
|
||||
-- | The morphism that builds the record.
|
||||
RecordMorphism s '[] r ->
|
||||
Term s pt
|
||||
mkRecordConstr ctr = pcon . ctr . mkRecord
|
||||
|
||||
-- | A morphism from one 'PDataRecord' to another, representing some sort of consing of data.
|
||||
newtype RecordMorphism (s :: S) (as :: [PLabeledType]) (bs :: [PLabeledType]) = RecordMorphism
|
||||
{ runRecordMorphism ::
|
||||
Term s (PDataRecord as) ->
|
||||
Term s (PDataRecord bs)
|
||||
}
|
||||
|
||||
instance Category (RecordMorphism s) where
|
||||
id = RecordMorphism id
|
||||
f . g = coerce $ f.runRecordMorphism . g.runRecordMorphism
|
||||
|
||||
infix 7 .=
|
||||
|
||||
-- | Cons a labeled type as a 'RecordMorphism'.
|
||||
(.=) ::
|
||||
forall (sym :: Symbol) (a :: PType) (as :: [PLabeledType]) (s :: S).
|
||||
-- | The field name. You can use @-XOverloadedLabels@ to enable the syntax:
|
||||
-- @#hello ~ 'FieldName' "hello"@
|
||||
FieldName sym ->
|
||||
-- | The value at that field. This must be 'PAsData', because the underlying
|
||||
-- type is @'PlutusCore.Data.Constr' 'Integer' ['PlutusCore.Data.Data']@.
|
||||
Term s (PAsData a) ->
|
||||
RecordMorphism s as ((sym ':= a) ': as)
|
||||
_ .= x = RecordMorphism $ pcon . PDCons x
|
||||
|
||||
infixr 6 .&
|
||||
|
||||
-- | Compose two 'RecordMorphism's.
|
||||
(.&) ::
|
||||
forall
|
||||
(s :: S)
|
||||
(a :: [PLabeledType])
|
||||
(b :: [PLabeledType])
|
||||
(c :: [PLabeledType]).
|
||||
RecordMorphism s b c ->
|
||||
RecordMorphism s a b ->
|
||||
RecordMorphism s a c
|
||||
(.&) = (.)
|
||||
|
|
@ -8,16 +8,20 @@ Description: Vote-lockable stake UTXOs holding GT.
|
|||
Vote-lockable stake UTXOs holding GT.
|
||||
-}
|
||||
module Agora.Stake (
|
||||
PStakeDatum (..),
|
||||
PStakeRedeemer (..),
|
||||
-- * Haskell-land
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (..),
|
||||
ProposalLock (..),
|
||||
PProposalLock (..),
|
||||
Stake (..),
|
||||
stakePolicy,
|
||||
stakeValidator,
|
||||
ProposalLock (..),
|
||||
|
||||
-- * Plutarch-land
|
||||
PStakeDatum (..),
|
||||
PStakeRedeemer (..),
|
||||
PProposalLock (..),
|
||||
|
||||
-- * Utility functions
|
||||
stakeLocked,
|
||||
findStakeOwnedBy,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -33,16 +37,14 @@ import PlutusTx qualified
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PMintingPolicy,
|
||||
PDatum,
|
||||
PDatumHash,
|
||||
PMaybeData (PDJust, PDNothing),
|
||||
PPubKeyHash,
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
PTokenName,
|
||||
PValidator,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
PTuple,
|
||||
PTxInInfo (PTxInInfo),
|
||||
PTxOut (PTxOut),
|
||||
)
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
|
|
@ -50,43 +52,34 @@ import Plutarch.DataRepr (
|
|||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (..))
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
import Plutus.V1.Ledger.Value (AssetClass)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Utils (
|
||||
anyInput,
|
||||
anyOutput,
|
||||
paddValue,
|
||||
passert,
|
||||
pfindTxInByTxOutRef,
|
||||
pgeqByClass,
|
||||
pgeqByClass',
|
||||
pgeqBySymbol,
|
||||
pnotNull,
|
||||
psingletonValue,
|
||||
psymbolValueOf,
|
||||
ptxSignedBy,
|
||||
pvalueSpent,
|
||||
ptryFindDatum,
|
||||
)
|
||||
import Plutarch.Numeric
|
||||
import Control.Applicative (Const)
|
||||
import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf)
|
||||
import Plutarch.Numeric ()
|
||||
import Plutarch.SafeMoney (
|
||||
PDiscrete,
|
||||
Tagged (..),
|
||||
pdiscreteValue,
|
||||
untag,
|
||||
)
|
||||
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Parameters for creating Stake scripts.
|
||||
newtype Stake = Stake
|
||||
data Stake = Stake
|
||||
{ gtClassRef :: Tagged GTTag AssetClass
|
||||
-- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
|
||||
, proposalSTClass :: AssetClass
|
||||
}
|
||||
|
||||
{- | A lock placed on a Stake datum in order to prevent
|
||||
|
|
@ -135,17 +128,20 @@ data StakeRedeemer
|
|||
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
|
||||
-- Stake must be unlocked.
|
||||
Destroy
|
||||
| -- | Permit a Vote to be added onto a 'Proposal'.
|
||||
| -- | Permit a Vote to be added onto a 'Agora.Proposal.Proposal'.
|
||||
-- This also adds a lock to the 'lockedBy' field. See 'ProposalLock'.
|
||||
-- This needs to be done in sync with casting a vote, otherwise
|
||||
-- it's possible for a lock to be permanently placed on the stake,
|
||||
-- and then the funds are lost.
|
||||
PermitVote ProposalLock
|
||||
| -- | Retract a vote, removing it from the 'lockedBy' field. See 'ProposalLock'.
|
||||
-- This action checks for permission of the 'Proposal'. Finished proposals are
|
||||
-- This action checks for permission of the 'Agora.Proposal.Proposal'. Finished proposals are
|
||||
-- always allowed to have votes retracted and won't affect the Proposal datum,
|
||||
-- allowing 'Stake's to be unlocked.
|
||||
RetractVotes [ProposalLock]
|
||||
| -- | The owner can consume stake if nothing is changed about it.
|
||||
-- If the proposal token moves, this is equivalent to the owner consuming it.
|
||||
WitnessStake
|
||||
deriving stock (Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
|
|
@ -154,13 +150,14 @@ PlutusTx.makeIsDataIndexed
|
|||
, ('Destroy, 1)
|
||||
, ('PermitVote, 2)
|
||||
, ('RetractVotes, 3)
|
||||
, ('WitnessStake, 4)
|
||||
]
|
||||
|
||||
-- | Haskell-level datum for Stake scripts.
|
||||
data StakeDatum = StakeDatum
|
||||
{ stakedAmount :: Tagged GTTag Integer
|
||||
-- ^ Tracks the amount of governance token staked in the datum.
|
||||
-- This also acts as the voting weight for 'Proposal's.
|
||||
-- This also acts as the voting weight for 'Agora.Proposal.Proposal's.
|
||||
, owner :: PubKeyHash
|
||||
-- ^ The hash of the public key this stake belongs to.
|
||||
--
|
||||
|
|
@ -195,8 +192,13 @@ newtype PStakeDatum (s :: S) = PStakeDatum
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PStakeDatum)
|
||||
|
||||
instance PTryFrom PData (PAsData PStakeDatum) where
|
||||
type PTryFromExcess PData (PAsData PStakeDatum) = Const ()
|
||||
ptryFrom' d k =
|
||||
k (punsafeCoerce d, ())
|
||||
|
||||
instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
|
||||
deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum)
|
||||
deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstantDecl StakeDatum)
|
||||
|
||||
-- | Plutarch-level redeemer for Stake scripts.
|
||||
data PStakeRedeemer (s :: S)
|
||||
|
|
@ -205,7 +207,8 @@ data PStakeRedeemer (s :: S)
|
|||
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
|
||||
PDestroy (Term s (PDataRecord '[]))
|
||||
| PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock]))
|
||||
| PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList PProposalLock]))
|
||||
| PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)]))
|
||||
| PWitnessStake (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
|
|
@ -213,9 +216,15 @@ data PStakeRedeemer (s :: S)
|
|||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PStakeRedeemer
|
||||
|
||||
instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
|
||||
deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer)
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PStakeRedeemer)
|
||||
instance
|
||||
PTryFrom PData (PAsData PStakeRedeemer)
|
||||
|
||||
instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
|
||||
deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstantDecl StakeRedeemer)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalLock'.
|
||||
newtype PProposalLock (s :: S) = PProposalLock
|
||||
{ getProposalLock ::
|
||||
Term
|
||||
|
|
@ -233,224 +242,13 @@ newtype PProposalLock (s :: S) = PProposalLock
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalLock)
|
||||
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PProposalLock)
|
||||
instance
|
||||
PTryFrom PData (PAsData PProposalLock)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock
|
||||
deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
{- What this Policy does
|
||||
|
||||
For minting:
|
||||
Check that exactly one state thread is minted
|
||||
Check that an output exists with a state thread and a valid datum
|
||||
Check that no state thread is an input
|
||||
assert TokenName == ValidatorHash of the script that we pay to
|
||||
|
||||
For burning:
|
||||
Check that exactly one state thread is burned
|
||||
Check that datum at state thread is valid and not locked
|
||||
-}
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Policy for Stake state threads.
|
||||
stakePolicy :: Stake -> ClosedTerm PMintingPolicy
|
||||
stakePolicy stake =
|
||||
plam $ \_redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'
|
||||
|
||||
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
|
||||
ownSymbol <- plet $ pfield @"_0" # ownSymbol'
|
||||
spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # pfromData txInfo'
|
||||
mintedST <- plet $ psymbolValueOf # ownSymbol # txInfo.mint
|
||||
|
||||
let burning = P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
passert "ST burned" $
|
||||
mintedST #== -1
|
||||
|
||||
passert "An unlocked input existed containing an ST" $
|
||||
anyInput @PStakeDatum # pfromData txInfo'
|
||||
#$ plam
|
||||
$ \value _ stakeDatum' -> P.do
|
||||
let hasST = psymbolValueOf # ownSymbol # value #== 1
|
||||
let unlocked = pnot # (stakeLocked # stakeDatum')
|
||||
hasST #&& unlocked
|
||||
|
||||
popaque (pconstant ())
|
||||
|
||||
let minting = P.do
|
||||
passert "ST at inputs must be 0" $
|
||||
spentST #== 0
|
||||
|
||||
passert "Minted ST must be exactly 1" $
|
||||
mintedST #== 1
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # pfromData txInfo'
|
||||
#$ plam
|
||||
$ \value address stakeDatum' -> P.do
|
||||
let cred = pfield @"credential" # address
|
||||
pmatch cred $ \case
|
||||
-- Should pay to a script address
|
||||
PPubKeyCredential _ -> pcon PFalse
|
||||
PScriptCredential validatorHash' -> P.do
|
||||
validatorHash <- pletFields @'["_0"] validatorHash'
|
||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
|
||||
-- TODO: figure out why this is required :/ (specifically, why `validatorHash._0` is `PData`)
|
||||
tn <- plet (pfromData (punsafeCoerce validatorHash._0 :: Term _ (PAsData PTokenName)))
|
||||
|
||||
let stValue =
|
||||
psingletonValue
|
||||
# ownSymbol
|
||||
-- This coerce is safe because the structure
|
||||
-- of PValidatorHash is the same as PTokenName.
|
||||
# tn
|
||||
# 1
|
||||
let expectedValue =
|
||||
paddValue
|
||||
# (pdiscreteValue stake.gtClassRef # stakeDatum.stakedAmount)
|
||||
# stValue
|
||||
let ownerSignsTransaction =
|
||||
ptxSignedBy
|
||||
# ctx.txInfo
|
||||
# stakeDatum.owner
|
||||
|
||||
-- TODO: This is quite inefficient now, as it does two lookups
|
||||
-- instead of a more efficient single pass,
|
||||
-- but it doesn't really matter for this. At least it's correct.
|
||||
let valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqByClass
|
||||
# ownSymbol
|
||||
# tn
|
||||
# value
|
||||
# expectedValue
|
||||
]
|
||||
|
||||
ownerSignsTransaction
|
||||
#&& valueCorrect
|
||||
popaque (pconstant ())
|
||||
|
||||
pif (0 #< mintedST) minting burning
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Validator intended for Stake UTXOs to live in.
|
||||
stakeValidator :: Stake -> ClosedTerm PValidator
|
||||
stakeValidator stake =
|
||||
plam $ \datum redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'
|
||||
|
||||
-- TODO: Use PTryFrom
|
||||
let stakeRedeemer :: Term _ PStakeRedeemer
|
||||
stakeRedeemer = pfromData $ punsafeCoerce redeemer
|
||||
stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
|
||||
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
|
||||
|
||||
PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfo'
|
||||
ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo
|
||||
let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
|
||||
|
||||
-- Whether the owner signs this transaction or not.
|
||||
ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner
|
||||
|
||||
stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake)
|
||||
mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfo.mint
|
||||
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfo'
|
||||
|
||||
-- Is the stake currently locked?
|
||||
stakeIsLocked <- plet $ stakeLocked # stakeDatum'
|
||||
|
||||
pmatch stakeRedeemer $ \case
|
||||
PDestroy _ -> P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
passert "Should burn ST" $
|
||||
mintedST #== -1
|
||||
passert "Stake unlocked" $ pnot # stakeIsLocked
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PRetractVotes _ -> P.do
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
-- TODO: check proposal constraints
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PPermitVote _ -> P.do
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
-- TODO: check proposal constraints
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PDepositWithdraw r -> P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
passert "Stake unlocked" $
|
||||
pnot #$ stakeIsLocked
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo'
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum'
|
||||
delta <- plet $ pfield @"delta" # r
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let correctOutputDatum =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ stakeDatum.owner #== newStakeDatum.owner
|
||||
, (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount
|
||||
, -- We can't magically conjure GT anyway (no input to spend!)
|
||||
-- do we need to check this, really?
|
||||
zero #<= pfromData newStakeDatum.stakedAmount
|
||||
]
|
||||
let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta)
|
||||
|
||||
-- TODO: Same as above. This is quite inefficient now, as it does two lookups
|
||||
-- instead of a more efficient single pass,
|
||||
-- but it doesn't really matter for this. At least it's correct.
|
||||
let valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqBySymbol
|
||||
# stCurrencySymbol
|
||||
# value
|
||||
# expectedValue
|
||||
]
|
||||
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "isScriptAddress" isScriptAddress
|
||||
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
|
||||
, ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
|
||||
popaque (pconstant ())
|
||||
deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstantDecl ProposalLock)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -461,3 +259,58 @@ stakeLocked = phoistAcyclic $
|
|||
let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
|
||||
locks = pfield @"lockedBy" # stakeDatum
|
||||
in pnotNull # locks
|
||||
|
||||
-- | Find a stake owned by a particular PK.
|
||||
findStakeOwnedBy ::
|
||||
Term
|
||||
s
|
||||
( PAssetClass
|
||||
:--> PPubKeyHash
|
||||
:--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
|
||||
:--> PBuiltinList (PAsData PTxInInfo)
|
||||
:--> PMaybe (PAsData PStakeDatum)
|
||||
)
|
||||
findStakeOwnedBy = phoistAcyclic $
|
||||
plam $ \ac pk datums inputs ->
|
||||
pmatch (pfind # (isInputStakeOwnedBy # ac # pk # datums) # inputs) $ \case
|
||||
PNothing -> pcon PNothing
|
||||
PJust (pfromData -> v) -> P.do
|
||||
let txOut = pfield @"resolved" # pto v
|
||||
txOutF <- pletFields @'["datumHash"] $ txOut
|
||||
pmatch txOutF.datumHash $ \case
|
||||
PDNothing _ -> pcon PNothing
|
||||
PDJust ((pfield @"_0" #) -> dh) -> P.do
|
||||
ptryFindDatum @(PAsData PStakeDatum) # dh # datums
|
||||
|
||||
stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
|
||||
stakeDatumOwnedBy =
|
||||
phoistAcyclic $
|
||||
plam $ \pk stakeDatum -> P.do
|
||||
stakeDatumF <- pletFields @'["owner"] $ pto stakeDatum
|
||||
stakeDatumF.owner #== pdata pk
|
||||
|
||||
-- Does the input have a `Stake` owned by a particular PK?
|
||||
isInputStakeOwnedBy ::
|
||||
Term
|
||||
_
|
||||
( PAssetClass :--> PPubKeyHash
|
||||
:--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
|
||||
:--> PAsData PTxInInfo
|
||||
:--> PBool
|
||||
)
|
||||
isInputStakeOwnedBy =
|
||||
plam $ \ac ss datums txInInfo' -> P.do
|
||||
PTxInInfo ((pfield @"resolved" #) -> txOut) <- pmatch $ pfromData txInInfo'
|
||||
PTxOut txOut' <- pmatch txOut
|
||||
txOutF <- pletFields @'["value", "datumHash"] txOut'
|
||||
outStakeST <- plet $ passetClassValueOf # txOutF.value # ac
|
||||
pmatch txOutF.datumHash $ \case
|
||||
PDNothing _ -> pcon PFalse
|
||||
PDJust ((pfield @"_0" #) -> datumHash) ->
|
||||
pif
|
||||
(outStakeST #== 1)
|
||||
( pmatch (ptryFindDatum @(PAsData PStakeDatum) # datumHash # datums) $ \case
|
||||
PNothing -> pcon PFalse
|
||||
PJust v -> stakeDatumOwnedBy # ss # pfromData (punsafeCoerce v)
|
||||
)
|
||||
(pcon PFalse)
|
||||
|
|
|
|||
405
agora/Agora/Stake/Scripts.hs
Normal file
405
agora/Agora/Stake/Scripts.hs
Normal file
|
|
@ -0,0 +1,405 @@
|
|||
{- |
|
||||
Module : Agora.Stake.Scripts
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Plutus Scripts for Stakes.
|
||||
|
||||
Plutus Scripts for Stakes.
|
||||
-}
|
||||
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
|
||||
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake
|
||||
import Agora.Utils (
|
||||
anyInput,
|
||||
anyOutput,
|
||||
paddValue,
|
||||
passert,
|
||||
pfindTxInByTxOutRef,
|
||||
pgeqByClass,
|
||||
pgeqByClass',
|
||||
pgeqBySymbol,
|
||||
psingletonValue,
|
||||
psymbolValueOf,
|
||||
ptokenSpent,
|
||||
ptxSignedBy,
|
||||
pvalueSpent,
|
||||
validatorHashToTokenName,
|
||||
)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PMintingPolicy,
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
PTokenName,
|
||||
PTxInfo,
|
||||
PValidator,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
)
|
||||
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.Numeric
|
||||
import Plutarch.SafeMoney (
|
||||
Tagged (..),
|
||||
pdiscreteValue',
|
||||
untag,
|
||||
)
|
||||
import Plutarch.TryFrom (ptryFrom)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
import Prelude hiding (Num (..))
|
||||
|
||||
{- | Policy for Stake state threads.
|
||||
|
||||
== What this Policy does
|
||||
|
||||
=== For minting:
|
||||
|
||||
- Check that exactly one state thread is minted.
|
||||
- Check that an output exists with a state thread and a valid datum.
|
||||
- Check that no state thread is an input.
|
||||
- assert @'Plutus.V1.Ledger.Api.TokenName' == 'Plutus.V1.Ledger.Api.ValidatorHash'@
|
||||
of the script that we pay to.
|
||||
|
||||
=== For burning:
|
||||
|
||||
- Check that exactly one state thread is burned.
|
||||
- Check that datum at state thread is valid and not locked.
|
||||
-}
|
||||
stakePolicy ::
|
||||
-- | The (governance) token that a Stake can store.
|
||||
Tagged GTTag AssetClass ->
|
||||
ClosedTerm PMintingPolicy
|
||||
stakePolicy gtClassRef =
|
||||
plam $ \_redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- plet $ ctx.txInfo
|
||||
let _a :: Term _ PTxInfo
|
||||
_a = txInfo
|
||||
txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
|
||||
|
||||
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
|
||||
ownSymbol <- plet $ pfield @"_0" # ownSymbol'
|
||||
spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs
|
||||
mintedST <- plet $ psymbolValueOf # ownSymbol # txInfoF.mint
|
||||
|
||||
let burning = P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
passert "ST burned" $
|
||||
mintedST #== -1
|
||||
|
||||
passert "An unlocked input existed containing an ST" $
|
||||
anyInput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value _ stakeDatum' -> P.do
|
||||
let hasST = psymbolValueOf # ownSymbol # value #== 1
|
||||
let unlocked = pnot # (stakeLocked # stakeDatum')
|
||||
hasST #&& unlocked
|
||||
|
||||
popaque (pconstant ())
|
||||
|
||||
let minting = P.do
|
||||
passert "ST at inputs must be 0" $
|
||||
spentST #== 0
|
||||
|
||||
passert "Minted ST must be exactly 1" $
|
||||
mintedST #== 1
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address stakeDatum' -> P.do
|
||||
let cred = pfield @"credential" # address
|
||||
pmatch cred $ \case
|
||||
-- Should pay to a script address
|
||||
PPubKeyCredential _ -> pcon PFalse
|
||||
PScriptCredential validatorHash -> P.do
|
||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
|
||||
tn :: Term _ PTokenName <- plet (validatorHashToTokenName $ pfromData $ pfield @"_0" # validatorHash)
|
||||
|
||||
let stValue =
|
||||
psingletonValue
|
||||
# ownSymbol
|
||||
-- This coerce is safe because the structure
|
||||
-- of PValidatorHash is the same as PTokenName.
|
||||
# tn
|
||||
# 1
|
||||
let expectedValue =
|
||||
paddValue
|
||||
# (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount)
|
||||
# stValue
|
||||
let ownerSignsTransaction =
|
||||
ptxSignedBy
|
||||
# txInfoF.signatories
|
||||
# stakeDatum.owner
|
||||
|
||||
-- TODO: This is quite inefficient now, as it does two lookups
|
||||
-- instead of a more efficient single pass,
|
||||
-- but it doesn't really matter for this. At least it's correct.
|
||||
let valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass' (untag gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqByClass
|
||||
# ownSymbol
|
||||
# tn
|
||||
# value
|
||||
# expectedValue
|
||||
]
|
||||
|
||||
ownerSignsTransaction
|
||||
#&& valueCorrect
|
||||
popaque (pconstant ())
|
||||
|
||||
pif (0 #< mintedST) minting burning
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Validator intended for Stake UTXOs to be locked by.
|
||||
|
||||
== What this Validator does:
|
||||
|
||||
=== 'DepositWithdraw'
|
||||
|
||||
Deposit or withdraw some GT to the stake.
|
||||
|
||||
- Tx must be signed by the owner.
|
||||
- The 'stakedAmount' field must be updated.
|
||||
- The stake must not be locked.
|
||||
- The new UTXO must have the previous value plus the difference
|
||||
as stated by the redeemer.
|
||||
|
||||
=== 'PermitVote'
|
||||
|
||||
Allow a 'ProposalLock' to be put on the stake in order to vote
|
||||
on a proposal.
|
||||
|
||||
- A proposal token must be spent alongside the stake.
|
||||
|
||||
* Its total votes must be correctly updated to include this stake's
|
||||
contribution.
|
||||
|
||||
- Tx must be signed by the owner.
|
||||
|
||||
=== 'RetractVotes'
|
||||
|
||||
Remove a 'ProposalLock' set when voting on a proposal.
|
||||
|
||||
- A proposal token must be spent alongside the stake.
|
||||
- Tx must be signed by the owner.
|
||||
|
||||
=== 'Destroy'
|
||||
|
||||
Destroy the stake in order to reclaim the min ADA.
|
||||
|
||||
- The stake must not be locked.
|
||||
- Tx must be signed by the owner.
|
||||
|
||||
=== 'WitnessStake'
|
||||
|
||||
Allow this Stake to be included in a transaction without making
|
||||
any changes to it. In the future,
|
||||
this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
|
||||
|
||||
- Tx must be signed by the owner __or__ a proposal ST token must be spent
|
||||
alongside the stake.
|
||||
- The datum and value must remain unchanged.
|
||||
-}
|
||||
stakeValidator :: Stake -> ClosedTerm PValidator
|
||||
stakeValidator stake =
|
||||
plam $ \datum redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- plet $ pfromData ctx.txInfo
|
||||
txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
|
||||
|
||||
(pfromData -> stakeRedeemer, _) <- ptryFrom redeemer
|
||||
|
||||
-- TODO: Use PTryFrom
|
||||
let stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
|
||||
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
|
||||
|
||||
PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
|
||||
ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo
|
||||
let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
|
||||
|
||||
-- Whether the owner signs this transaction or not.
|
||||
ownerSignsTransaction <- plet $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner
|
||||
|
||||
stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
|
||||
mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
|
||||
valueSpent <- plet $ pvalueSpent # txInfoF.inputs
|
||||
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
|
||||
|
||||
let AssetClass (propCs, propTn) = stake.proposalSTClass
|
||||
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
|
||||
spentProposalST <- plet $ passetClassValueOf # valueSpent # proposalSTClass
|
||||
|
||||
-- Is the stake currently locked?
|
||||
stakeIsLocked <- plet $ stakeLocked # stakeDatum'
|
||||
|
||||
pmatch stakeRedeemer $ \case
|
||||
PDestroy _ -> P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
passert "Should burn ST" $
|
||||
mintedST #== -1
|
||||
|
||||
passert "Stake unlocked" $ pnot # stakeIsLocked
|
||||
|
||||
passert "Owner signs this transaction" ownerSignsTransaction
|
||||
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PRetractVotes _ -> P.do
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
passert "Proposal ST spent" $
|
||||
spentProposalST #== 1
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
|
||||
let valueCorrect = pdata continuingValue #== pdata value
|
||||
pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PPermitVote _ -> P.do
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
passert "Proposal ST spent" $
|
||||
spentProposalST #== 1
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
|
||||
let valueCorrect = pdata continuingValue #== pdata value
|
||||
pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PWitnessStake _ -> P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
let AssetClass (propCs, propTn) = stake.proposalSTClass
|
||||
propAssetClass = passetClass # pconstant propCs # pconstant propTn
|
||||
proposalTokenMoved =
|
||||
ptokenSpent
|
||||
# propAssetClass
|
||||
# txInfoF.inputs
|
||||
|
||||
-- In order for cosignature to be witnessed, it must be possible for a
|
||||
-- proposal to allow this transaction to happen. This puts trust into the Proposal.
|
||||
-- The Proposal must necessarily check that this is not abused.
|
||||
passert
|
||||
"Owner signs this transaction OR proposal token is spent"
|
||||
(ownerSignsTransaction #|| proposalTokenMoved)
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
|
||||
let valueCorrect = pdata continuingValue #== pdata value
|
||||
pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
popaque (pconstant ())
|
||||
PDepositWithdraw r -> P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
passert "Stake unlocked" $
|
||||
pnot #$ stakeIsLocked
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum'
|
||||
delta <- plet $ pfield @"delta" # r
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let correctOutputDatum =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ stakeDatum.owner #== newStakeDatum.owner
|
||||
, (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount
|
||||
, -- We can't magically conjure GT anyway (no input to spend!)
|
||||
-- do we need to check this, really?
|
||||
zero #<= pfromData newStakeDatum.stakedAmount
|
||||
]
|
||||
let expectedValue = paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta)
|
||||
|
||||
-- TODO: Same as above. This is quite inefficient now, as it does two lookups
|
||||
-- instead of a more efficient single pass,
|
||||
-- but it doesn't really matter for this. At least it's correct.
|
||||
let valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqBySymbol
|
||||
# stCurrencySymbol
|
||||
# value
|
||||
# expectedValue
|
||||
]
|
||||
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "isScriptAddress" isScriptAddress
|
||||
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
|
||||
, ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
|
||||
popaque (pconstant ())
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module: Agora.Treasury
|
||||
Maintainer: jack@mlabs.city
|
||||
|
|
@ -8,24 +10,60 @@ treasury.
|
|||
-}
|
||||
module Agora.Treasury (module Agora.Treasury) where
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.Utils (passert)
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP
|
||||
import Plutarch.Api.V1 (PValidator)
|
||||
import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
|
||||
import Plutarch.Api.V1.Value (PCurrencySymbol, PValue)
|
||||
import Plutarch.Api.V1.Value (PValue)
|
||||
import Plutarch.DataRepr (
|
||||
PDataFields,
|
||||
DerivePConstantViaData (..),
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.TryFrom (PTryFrom, ptryFrom)
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
import PlutusTx qualified
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.Utils (passert)
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Api.V1 (PValidator)
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
-- | Redeemer for Treasury actions.
|
||||
data TreasuryRedeemer
|
||||
= -- | Allow transaction to pass by delegating to GAT burn.
|
||||
SpendTreasuryGAT
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
''TreasuryRedeemer
|
||||
[ ('SpendTreasuryGAT, 0)
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Plutarch level type representing valid redeemers of the
|
||||
treasury.
|
||||
-}
|
||||
newtype PTreasuryRedeemer (s :: S)
|
||||
= -- | Alters treasury parameters, subject to the burning of a
|
||||
-- governance authority token.
|
||||
PSpendTreasuryGAT (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic, PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PTreasuryRedeemer
|
||||
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PTreasuryRedeemer)
|
||||
instance
|
||||
PTryFrom PData (PAsData PTreasuryRedeemer)
|
||||
|
||||
instance PUnsafeLiftDecl PTreasuryRedeemer where type PLifted PTreasuryRedeemer = TreasuryRedeemer
|
||||
deriving via (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer) instance (PConstantDecl TreasuryRedeemer)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Validator ensuring that transactions consuming the treasury
|
||||
do so in a valid manner.
|
||||
|
|
@ -33,12 +71,8 @@ import Plutarch.Unsafe (punsafeCoerce)
|
|||
treasuryValidator ::
|
||||
CurrencySymbol ->
|
||||
ClosedTerm PValidator
|
||||
treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
|
||||
-- TODO: Use PTryFrom
|
||||
let treasuryRedeemer :: Term _ (PAsData PTreasuryRedeemer)
|
||||
treasuryRedeemer = punsafeCoerce redeemer
|
||||
_treasuryDatum' :: Term _ (PAsData PTreasuryDatum)
|
||||
_treasuryDatum' = punsafeCoerce datum
|
||||
treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> P.do
|
||||
(treasuryRedeemer, _) <- ptryFrom redeemer
|
||||
|
||||
-- plet required fields from script context.
|
||||
ctx <- pletFields @["txInfo", "purpose"] ctx'
|
||||
|
|
@ -47,7 +81,7 @@ treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
|
|||
PMinting _ <- pmatch ctx.purpose
|
||||
|
||||
-- Ensure redeemer type is valid.
|
||||
PAlterTreasuryParams _ <- pmatch $ pfromData treasuryRedeemer
|
||||
PSpendTreasuryGAT _ <- pmatch $ pfromData treasuryRedeemer
|
||||
|
||||
-- Get the minted value from txInfo.
|
||||
txInfo' <- plet ctx.txInfo
|
||||
|
|
@ -61,37 +95,3 @@ treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
|
|||
singleAuthorityTokenBurned gatCs txInfo' mint
|
||||
|
||||
popaque $ pconstant ()
|
||||
|
||||
{- | Plutarch level type representing datum of the treasury.
|
||||
Contains:
|
||||
|
||||
- @stateThread@ representing the asset class of the
|
||||
treasury's state thread token.
|
||||
-}
|
||||
newtype PTreasuryDatum (s :: S)
|
||||
= PTreasuryDatum
|
||||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "stateThread" ':= PCurrencySymbol
|
||||
]
|
||||
)
|
||||
)
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic, PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via PIsDataReprInstances PTreasuryDatum
|
||||
|
||||
{- | Plutarch level type representing valid redeemers of the
|
||||
treasury.
|
||||
-}
|
||||
newtype PTreasuryRedeemer (s :: S)
|
||||
= -- | Alters treasury parameters, subject to the burning of a
|
||||
-- governance authority token.
|
||||
PAlterTreasuryParams (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic, PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PTreasuryRedeemer
|
||||
|
|
|
|||
|
|
@ -10,15 +10,13 @@ module Agora.Utils (
|
|||
passert,
|
||||
pfind',
|
||||
pfindDatum,
|
||||
pfindDatum',
|
||||
ptryFindDatum,
|
||||
pvalueSpent,
|
||||
ptxSignedBy,
|
||||
paddValue,
|
||||
plookup,
|
||||
pfromMaybe,
|
||||
psymbolValueOf,
|
||||
passetClassValueOf,
|
||||
passetClassValueOf',
|
||||
pgeqByClass,
|
||||
pgeqBySymbol,
|
||||
pgeqByClass',
|
||||
|
|
@ -26,12 +24,22 @@ module Agora.Utils (
|
|||
psingletonValue,
|
||||
pfindMap,
|
||||
pnotNull,
|
||||
pisJust,
|
||||
ptokenSpent,
|
||||
pkeysEqual,
|
||||
pnub,
|
||||
pisUniq,
|
||||
|
||||
-- * Functions which should (probably) not be upstreamed
|
||||
anyOutput,
|
||||
allOutputs,
|
||||
anyInput,
|
||||
allInputs,
|
||||
findTxOutByTxOutRef,
|
||||
scriptHashFromAddress,
|
||||
findOutputsToAddress,
|
||||
findTxOutDatum,
|
||||
validatorHashToTokenName,
|
||||
getMintingPolicySymbol,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -42,23 +50,33 @@ import Plutus.V1.Ledger.Value (AssetClass (..))
|
|||
|
||||
import Plutarch.Api.V1 (
|
||||
PAddress,
|
||||
PCredential (PScriptCredential),
|
||||
PCurrencySymbol,
|
||||
PDatum,
|
||||
PDatumHash,
|
||||
PMap,
|
||||
PMaybeData (PDJust),
|
||||
PMintingPolicy,
|
||||
PPubKeyHash,
|
||||
PTokenName,
|
||||
PTokenName (PTokenName),
|
||||
PTuple,
|
||||
PTxInInfo (PTxInInfo),
|
||||
PTxInfo (PTxInfo),
|
||||
PTxInfo,
|
||||
PTxOut (PTxOut),
|
||||
PTxOutRef,
|
||||
PValidatorHash,
|
||||
PValue,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
)
|
||||
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)
|
||||
import Plutarch.Map.Extra (pkeys)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.TryFrom (PTryFrom, ptryFrom)
|
||||
import Plutus.V1.Ledger.Api (CurrencySymbol)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Validator-level utility functions
|
||||
|
|
@ -68,24 +86,24 @@ passert :: Term s PString -> Term s PBool -> Term s k -> Term s k
|
|||
passert errorMessage check k = pif check k (ptraceError errorMessage)
|
||||
|
||||
-- | Find a datum with the given hash.
|
||||
pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum)
|
||||
pfindDatum :: Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe PDatum)
|
||||
pfindDatum = phoistAcyclic $
|
||||
plam $ \datumHash txInfo'' -> P.do
|
||||
PTxInfo txInfo' <- pmatch txInfo''
|
||||
plookupTuple # datumHash #$ pfield @"data" # txInfo'
|
||||
plam $ \datumHash datums -> plookupTuple # datumHash # datums
|
||||
|
||||
{- | Find a datum with the given hash.
|
||||
NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB.
|
||||
-}
|
||||
pfindDatum' :: PIsData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe (PAsData a))
|
||||
pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x
|
||||
-- | Find a datum with the given hash, and `ptryFrom` it.
|
||||
ptryFindDatum :: forall (a :: PType) (s :: S). PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a)
|
||||
ptryFindDatum = phoistAcyclic $
|
||||
plam $ \datumHash inputs ->
|
||||
pmatch (pfindDatum # datumHash # inputs) $ \case
|
||||
PNothing -> pcon PNothing
|
||||
PJust datum -> P.do
|
||||
(datum', _) <- ptryFrom (pto datum)
|
||||
pcon (PJust datum')
|
||||
|
||||
-- | Check if a PubKeyHash signs this transaction.
|
||||
ptxSignedBy :: Term s (PTxInfo :--> PAsData PPubKeyHash :--> PBool)
|
||||
ptxSignedBy :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PAsData PPubKeyHash :--> PBool)
|
||||
ptxSignedBy = phoistAcyclic $
|
||||
plam $ \txInfo' pkh -> P.do
|
||||
txInfo <- pletFields @'["signatories"] txInfo'
|
||||
pelem @PBuiltinList # pkh # txInfo.signatories
|
||||
plam $ \sigs sig -> pelem # sig # sigs
|
||||
|
||||
-- | Get the first element that matches a predicate or return Nothing.
|
||||
pfind' ::
|
||||
|
|
@ -143,6 +161,15 @@ pfromMaybe = phoistAcyclic $
|
|||
PJust a' -> a'
|
||||
PNothing -> e
|
||||
|
||||
-- | Yield True if a given PMaybe is of form PJust _.
|
||||
pisJust :: forall a s. Term s (PMaybe a :--> PBool)
|
||||
pisJust = phoistAcyclic $
|
||||
plam $ \v' -> P.do
|
||||
v <- pmatch v'
|
||||
case v of
|
||||
PJust _ -> pconstant True
|
||||
PNothing -> pconstant False
|
||||
|
||||
-- | Escape with a particular value on expecting 'Just'. For use in monadic context.
|
||||
pexpectJust ::
|
||||
forall r a s.
|
||||
|
|
@ -166,30 +193,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)
|
||||
|
|
@ -217,11 +231,10 @@ pmapUnionWith = phoistAcyclic $
|
|||
# plam
|
||||
( \p -> P.do
|
||||
pf <- plet $ pfstBuiltin # p
|
||||
ps <- plet $ psndBuiltin # p
|
||||
pmatch (plookup # pf # ys) $ \case
|
||||
PJust v ->
|
||||
-- Data conversions here are silly, aren't they?
|
||||
ppairDataBuiltin # pf # pdata (f # pfromData ps # pfromData v)
|
||||
ppairDataBuiltin # pf # pdata (f # pfromData (psndBuiltin # p) # pfromData v)
|
||||
PNothing -> p
|
||||
)
|
||||
# xs
|
||||
|
|
@ -246,46 +259,100 @@ paddValue = phoistAcyclic $
|
|||
)
|
||||
|
||||
-- | Sum of all value at input.
|
||||
pvalueSpent :: Term s (PTxInfo :--> PValue)
|
||||
pvalueSpent :: Term s (PBuiltinList (PAsData PTxInInfo) :--> PValue)
|
||||
pvalueSpent = phoistAcyclic $
|
||||
plam $ \txInfo' ->
|
||||
pmatch txInfo' $ \(PTxInfo txInfo) ->
|
||||
pfoldr
|
||||
# plam
|
||||
( \txInInfo' v ->
|
||||
pmatch
|
||||
(pfromData txInInfo')
|
||||
$ \(PTxInInfo txInInfo) ->
|
||||
paddValue
|
||||
# pmatch
|
||||
(pfield @"resolved" # txInInfo)
|
||||
(\(PTxOut o) -> pfromData $ pfield @"value" # o)
|
||||
# v
|
||||
)
|
||||
# pconstant mempty
|
||||
# (pfield @"inputs" # txInfo)
|
||||
plam $ \inputs ->
|
||||
pfoldr
|
||||
# plam
|
||||
( \txInInfo' v ->
|
||||
pmatch
|
||||
(pfromData txInInfo')
|
||||
$ \(PTxInInfo txInInfo) ->
|
||||
paddValue
|
||||
# pmatch
|
||||
(pfield @"resolved" # txInInfo)
|
||||
(\(PTxOut o) -> pfromData $ pfield @"value" # o)
|
||||
# v
|
||||
)
|
||||
# pconstant mempty
|
||||
# inputs
|
||||
|
||||
-- | Find the TxInInfo by a TxOutRef.
|
||||
pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PTxInfo :--> PMaybe PTxInInfo)
|
||||
pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PBuiltinList (PAsData PTxInInfo) :--> PMaybe PTxInInfo)
|
||||
pfindTxInByTxOutRef = phoistAcyclic $
|
||||
plam $ \txOutRef txInfo' ->
|
||||
pmatch txInfo' $ \(PTxInfo txInfo) ->
|
||||
pfindMap
|
||||
# plam
|
||||
( \txInInfo' ->
|
||||
plet (pfromData txInInfo') $ \r ->
|
||||
pmatch r $ \(PTxInInfo txInInfo) ->
|
||||
pif
|
||||
(pdata txOutRef #== pfield @"outRef" # txInInfo)
|
||||
(pcon (PJust r))
|
||||
(pcon PNothing)
|
||||
)
|
||||
#$ (pfield @"inputs" # txInfo)
|
||||
plam $ \txOutRef inputs ->
|
||||
pfindMap
|
||||
# plam
|
||||
( \txInInfo' ->
|
||||
plet (pfromData txInInfo') $ \r ->
|
||||
pmatch r $ \(PTxInInfo txInInfo) ->
|
||||
pif
|
||||
(pdata txOutRef #== pfield @"outRef" # txInInfo)
|
||||
(pcon (PJust r))
|
||||
(pcon PNothing)
|
||||
)
|
||||
#$ inputs
|
||||
|
||||
-- | True if a list is not empty.
|
||||
pnotNull :: forall list a. PIsListLike list a => Term _ (list a :--> PBool)
|
||||
pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse)
|
||||
|
||||
{- | Check if a particular asset class has been spent in the input list.
|
||||
|
||||
When using this as an authority check, you __MUST__ ensure the authority
|
||||
knows how to ensure its end of the contract.
|
||||
-}
|
||||
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
|
||||
|
||||
{- | True if both maps have exactly the same keys.
|
||||
Using @'#=='@ is not sufficient, because keys returned are not ordered.
|
||||
-}
|
||||
pkeysEqual :: forall (s :: S) k a b. Term s (PMap k a :--> PMap k b :--> PBool)
|
||||
pkeysEqual = phoistAcyclic $
|
||||
plam $ \p q -> P.do
|
||||
pks <- plet $ pkeys # p
|
||||
qks <- plet $ pkeys # q
|
||||
pall # plam (\pk -> pelem # pk # qks) # pks
|
||||
#&& pall # plam (\qk -> pelem # qk # pks) # qks
|
||||
|
||||
-- | / O(n^2) /. Clear out duplicates in a list. The order is not preserved.
|
||||
pnub :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> list a)
|
||||
pnub =
|
||||
phoistAcyclic $
|
||||
precList
|
||||
( \self x xs ->
|
||||
pif
|
||||
(pnot #$ pelem # x # xs)
|
||||
(pcons # x # (self # xs))
|
||||
(self # xs)
|
||||
)
|
||||
(const pnil)
|
||||
|
||||
-- | / O(n^2) /. Check if a list contains no duplicates.
|
||||
pisUniq :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> PBool)
|
||||
pisUniq =
|
||||
phoistAcyclic $
|
||||
precList
|
||||
( \self x xs ->
|
||||
(pnot #$ pelem # x # xs)
|
||||
#&& (self # xs)
|
||||
)
|
||||
(const $ pcon PTrue)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
{- Functions which should (probably) not be upstreamed
|
||||
All of these functions are quite inefficient.
|
||||
|
|
@ -295,18 +362,19 @@ pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse)
|
|||
anyOutput ::
|
||||
forall (datum :: PType) s.
|
||||
( PIsData datum
|
||||
, PTryFrom PData (PAsData datum)
|
||||
) =>
|
||||
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
|
||||
anyOutput = phoistAcyclic $
|
||||
plam $ \txInfo' predicate -> P.do
|
||||
txInfo <- pletFields @'["outputs"] txInfo'
|
||||
txInfo <- pletFields @'["outputs", "datums"] txInfo'
|
||||
pany
|
||||
# plam
|
||||
( \txOut'' -> P.do
|
||||
PTxOut txOut' <- pmatch (pfromData txOut'')
|
||||
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
|
||||
PDJust dh <- pmatch txOut.datumHash
|
||||
pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
|
||||
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
|
||||
PJust datum -> P.do
|
||||
predicate # txOut.value # txOut.address # pfromData datum
|
||||
PNothing -> pcon PFalse
|
||||
|
|
@ -317,18 +385,19 @@ anyOutput = phoistAcyclic $
|
|||
allOutputs ::
|
||||
forall (datum :: PType) s.
|
||||
( PIsData datum
|
||||
, PTryFrom PData (PAsData datum)
|
||||
) =>
|
||||
Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
|
||||
allOutputs = phoistAcyclic $
|
||||
plam $ \txInfo' predicate -> P.do
|
||||
txInfo <- pletFields @'["outputs"] txInfo'
|
||||
txInfo <- pletFields @'["outputs", "datums"] txInfo'
|
||||
pall
|
||||
# plam
|
||||
( \txOut'' -> P.do
|
||||
PTxOut txOut' <- pmatch (pfromData txOut'')
|
||||
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
|
||||
PDJust dh <- pmatch txOut.datumHash
|
||||
pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
|
||||
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
|
||||
PJust datum -> P.do
|
||||
predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
|
||||
PNothing -> pcon PFalse
|
||||
|
|
@ -339,11 +408,12 @@ allOutputs = phoistAcyclic $
|
|||
anyInput ::
|
||||
forall (datum :: PType) s.
|
||||
( PIsData datum
|
||||
, PTryFrom PData (PAsData datum)
|
||||
) =>
|
||||
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
|
||||
anyInput = phoistAcyclic $
|
||||
plam $ \txInfo' predicate -> P.do
|
||||
txInfo <- pletFields @'["inputs"] txInfo'
|
||||
txInfo <- pletFields @'["inputs", "datums"] txInfo'
|
||||
pany
|
||||
# plam
|
||||
( \txInInfo'' -> P.do
|
||||
|
|
@ -352,37 +422,13 @@ anyInput = phoistAcyclic $
|
|||
PTxOut txOut' <- pmatch (pfromData txOut'')
|
||||
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
|
||||
PDJust dh <- pmatch txOut.datumHash
|
||||
pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
|
||||
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
|
||||
PJust datum -> P.do
|
||||
predicate # txOut.value # txOut.address # pfromData datum
|
||||
PNothing -> pcon PFalse
|
||||
)
|
||||
# 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 $
|
||||
|
|
@ -391,3 +437,46 @@ psingletonValue = phoistAcyclic $
|
|||
outerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata sym # pdata innerTup
|
||||
res = pcon $ PValue outerTup
|
||||
in res
|
||||
|
||||
-- | Finds the TxOut of an effect from TxInfo and TxOutRef
|
||||
findTxOutByTxOutRef :: Term s (PTxOutRef :--> PBuiltinList (PAsData PTxInInfo) :--> PMaybe PTxOut)
|
||||
findTxOutByTxOutRef = phoistAcyclic $
|
||||
plam $ \txOutRef inputs ->
|
||||
pmatch (pfindTxInByTxOutRef # txOutRef # inputs) $ \case
|
||||
PJust ((pfield @"resolved" #) -> txOut) -> pcon $ PJust txOut
|
||||
PNothing -> pcon PNothing
|
||||
|
||||
-- | Get script hash from an Address.
|
||||
scriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash)
|
||||
scriptHashFromAddress = phoistAcyclic $
|
||||
plam $ \addr ->
|
||||
pmatch (pfromData $ pfield @"credential" # addr) $ \case
|
||||
PScriptCredential ((pfield @"_0" #) -> h) -> pcon $ PJust h
|
||||
_ -> pcon PNothing
|
||||
|
||||
-- | Find all TxOuts sent to an Address
|
||||
findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut))
|
||||
findOutputsToAddress = phoistAcyclic $
|
||||
plam $ \outputs address' -> P.do
|
||||
address <- plet $ pdata address'
|
||||
pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address)
|
||||
# outputs
|
||||
|
||||
-- | Find the data corresponding to a TxOut, if there is one
|
||||
findTxOutDatum :: Term s (PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PTxOut :--> PMaybe PDatum)
|
||||
findTxOutDatum = phoistAcyclic $
|
||||
plam $ \datums out -> P.do
|
||||
datumHash' <- pmatch $ pfromData $ pfield @"datumHash" # out
|
||||
case datumHash' of
|
||||
PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums
|
||||
_ -> pcon PNothing
|
||||
|
||||
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
-}
|
||||
validatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName
|
||||
validatorHashToTokenName vh = pcon (PTokenName (pto vh))
|
||||
|
||||
-- | Get the CurrencySymbol of a PMintingPolicy.
|
||||
getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
|
||||
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v
|
||||
|
|
|
|||
|
|
@ -11,8 +11,7 @@ module PPrelude (
|
|||
module Plutarch,
|
||||
) where
|
||||
|
||||
-- NOTE: These are not exported by Plutarch.Prelude, for some reason.
|
||||
-- Maybe we can 'fix' this upstream?
|
||||
import Plutarch (ClosedTerm, POpaque, compile)
|
||||
-- 'compile' is not exported by Plutarch.Prelude.
|
||||
import Plutarch (compile)
|
||||
import Plutarch.Prelude
|
||||
import Prelude
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue