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

merge master; use TermCont every where

Browse source 
fixes #73 partially
This commit is contained in:
fanghr 2022-05-12 21:16:25 +08:00
commit 59fee6f75a
15 changed files with 1077 additions and 1019 deletions
Download patch file Download diff file Expand all files Collapse all files

52
agora/Agora/AuthorityToken.hs
View file

@ -26,7 +26,6 @@ import Plutarch.Api.V1.AssocMap (PMap (PMap))
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
import Plutarch.Api.V1.Value (PValue (PValue))
import Plutarch.Builtin (pforgetData)
import Plutarch.Monadic qualified as P
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
import Prelude
@ -35,10 +34,11 @@ import Prelude
import Agora.Utils (
allOutputs,
passert,
plookup,
psymbolValueOf,
ptokenSpent,
tcassert,
tcmatch,
)
--------------------------------------------------------------------------------
@ -67,20 +67,22 @@ newtype AuthorityToken = AuthorityToken
-}
authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool)
authorityTokensValidIn = phoistAcyclic $
plam $ \authorityTokenSym txOut'' -> P.do
PTxOut txOut' <- pmatch txOut''
txOut <- pletFields @'["address", "value"] $ txOut'
PAddress address <- pmatch txOut.address
PValue value' <- pmatch txOut.value
PMap value <- pmatch value'
plam $ \authorityTokenSym txOut'' -> unTermCont $ do
PTxOut txOut' <- tcmatch txOut''
txOut <- tcont $ pletFields @'["address", "value"] $ txOut'
PAddress address <- tcmatch txOut.address
PValue value' <- tcmatch txOut.value
PMap value <- tcmatch value'
pure $
pmatch (plookup # pdata authorityTokenSym # value) $ \case
PJust (pfromData -> tokenMap') ->
pmatch (pfield @"credential" # address) $ \case
PPubKeyCredential _ ->
-- GATs should only be sent to Effect validators
ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False
PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> P.do
PMap tokenMap <- pmatch tokenMap'
PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> unTermCont $ do
PMap tokenMap <- tcmatch tokenMap'
pure $
ptraceIfFalse "authorityTokensValidIn: GAT TokenName doesn't match ScriptHash" $
pall
# plam
@ -99,22 +101,23 @@ singleAuthorityTokenBurned ::
Term s (PAsData PTxInfo) ->
Term s PValue ->
Term s PBool
singleAuthorityTokenBurned gatCs txInfo mint = P.do
singleAuthorityTokenBurned gatCs txInfo mint = unTermCont $ do
let gatAmountMinted :: Term _ PInteger
gatAmountMinted = psymbolValueOf # gatCs # mint
txInfoF <- pletFields @'["inputs"] $ txInfo
txInfoF <- tcont $ pletFields @'["inputs"] $ txInfo
pure $
foldr1
(#&&)
[ 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')
( \txInInfo' -> unTermCont $ do
PTxInInfo txInInfo <- tcmatch (pfromData txInInfo')
let txOut' = pfield @"resolved" # txInInfo
authorityTokensValidIn # gatCs # pfromData txOut'
pure $ authorityTokensValidIn # gatCs # pfromData txOut'
)
# txInfoF.inputs
]
@ -123,29 +126,30 @@ singleAuthorityTokenBurned gatCs txInfo mint = P.do
authorityTokenPolicy :: AuthorityToken -> ClosedTerm PMintingPolicy
authorityTokenPolicy params =
plam $ \_redeemer ctx' ->
pmatch ctx' $ \(PScriptContext ctx') -> P.do
ctx <- pletFields @'["txInfo", "purpose"] ctx'
PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
txInfo <- pletFields @'["inputs", "mint"] txInfo'
pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
PTxInfo txInfo' <- tcmatch $ pfromData ctx.txInfo
txInfo <- tcont $ pletFields @'["inputs", "mint"] txInfo'
let inputs = txInfo.inputs
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
PMinting ownSymbol' <- tcmatch $ pfromData ctx.purpose
let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
mintedATs = passetClassValueOf # mintedValue # (passetClass # ownSymbol # pconstant "")
pure $
pif
(0 #< mintedATs)
( P.do
passert "Parent token did not move in minting GATs" govTokenSpent
passert "All outputs only emit valid GATs" $
( unTermCont $ do
tcassert "Parent token did not move in minting GATs" govTokenSpent
tcassert "All outputs only emit valid GATs" $
allOutputs @PData # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
authorityTokensValidIn
# ownSymbol
# txOut
popaque $ pconstant ()
pure $ popaque $ pconstant ()
)
(popaque $ pconstant ())

25
agora/Agora/Effect.hs
View file

@ -8,10 +8,9 @@ Helpers for constructing effects.
module Agora.Effect (makeEffect) where
import Agora.AuthorityToken (singleAuthorityTokenBurned)
import Agora.Utils (passert)
import Agora.Utils (tcassert, tclet, tcmatch, tctryFrom)
import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
import Plutarch.Monadic qualified as P
import Plutarch.TryFrom (PTryFrom, ptryFrom)
import Plutarch.TryFrom (PTryFrom)
import Plutus.V1.Ledger.Value (CurrencySymbol)
--------------------------------------------------------------------------------
@ -29,28 +28,28 @@ makeEffect ::
(forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
ClosedTerm PValidator
makeEffect gatCs' f =
plam $ \datum _redeemer ctx' -> P.do
ctx <- pletFields @'["txInfo", "purpose"] ctx'
txInfo' <- plet ctx.txInfo
plam $ \datum _redeemer ctx' -> unTermCont $ do
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
txInfo' <- tclet ctx.txInfo
-- 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
(datum', _) <- tctryFrom @datum datum
-- ensure purpose is Spending.
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
txOutRef' <- plet (pfield @"_0" # txOutRef)
PSpending txOutRef <- tcmatch $ pfromData ctx.purpose
txOutRef' <- tclet (pfield @"_0" # txOutRef)
-- fetch minted values to ensure single GAT is burned
txInfo <- pletFields @'["mint"] txInfo'
txInfo <- tcont $ pletFields @'["mint"] txInfo'
let mint :: Term _ PValue
mint = txInfo.mint
-- fetch script context
gatCs <- plet $ pconstant gatCs'
gatCs <- tclet $ pconstant gatCs'
passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
tcassert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
-- run effect function
f gatCs datum' txOutRef' txInfo'
pure $ f gatCs datum' txOutRef' txInfo'

3
agora/Agora/Effect/NoOp.hs
View file

@ -29,5 +29,4 @@ instance PTryFrom PData PNoOp where
-- | Dummy effect which can only burn its GAT.
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
noOpValidator curr = makeEffect curr $
\_ (_datum :: Term s PNoOp) _ _ -> P.do
popaque (pconstant ())
\_ (_datum :: Term s PNoOp) _ _ -> popaque (pconstant ())

44
agora/Agora/Effect/TreasuryWithdrawal.hs
View file

@ -18,7 +18,7 @@ import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Agora.Effect (makeEffect)
import Agora.Utils (findTxOutByTxOutRef, paddValue, passert)
import Agora.Utils (findTxOutByTxOutRef, paddValue, tcassert, tclet, tcmatch)
import Plutarch.Api.V1 (
PCredential (..),
PTuple,
@ -34,7 +34,6 @@ import Plutarch.DataRepr (
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)
@ -106,29 +105,29 @@ instance PTryFrom PData PTreasuryWithdrawalDatum where
-}
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
\_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> unTermCont $ do
datum <- tcont $ pletFields @'["receivers", "treasuries"] datum'
txInfo <- tcont $ pletFields @'["outputs", "inputs"] txInfo'
PJust txOut <- tcmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo.inputs
effInput <- tcont $ pletFields @'["address", "value"] $ txOut
outputValues <-
plet $
tclet $
pmap
# plam
( \(pfromData -> txOut') -> P.do
txOut <- pletFields @'["address", "value"] $ txOut'
( \(pfromData -> txOut') -> unTermCont $ do
txOut <- tcont $ pletFields @'["address", "value"] $ txOut'
let cred = pfield @"credential" # pfromData txOut.address
pdata $ ptuple # cred # txOut.value
pure . pdata $ ptuple # cred # txOut.value
)
# txInfo.outputs
inputValues <-
plet $
tclet $
pmap
# plam
( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do
txOut <- pletFields @'["address", "value"] $ txOut'
( \((pfield @"resolved" #) . pfromData -> txOut') -> unTermCont $ do
txOut <- tcont $ pletFields @'["address", "value"] $ txOut'
let cred = pfield @"credential" # pfromData txOut.address
pdata $ ptuple # cred # txOut.value
pure . pdata $ ptuple # cred # txOut.value
)
# txInfo.inputs
let ofTreasury =
@ -141,8 +140,9 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
receiverValuesSum = sumValues # datum.receivers
isPubkey = plam $ \cred -> P.do
pmatch cred $ \case
isPubkey = plam $ \cred ->
pmatch cred $
\case
PPubKeyCredential _ -> pcon PTrue
PScriptCredential _ -> pcon PFalse
@ -169,8 +169,8 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
)
# 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 ()
tcassert "Transaction should not pay to effects" shouldNotPayToEffect
tcassert "Transaction output does not match receivers" outputContentMatchesRecivers
tcassert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
tcassert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuriesOrCollateral
pure . popaque $ pconstant ()

12
agora/Agora/Governor.hs
View file

@ -38,6 +38,7 @@ import Agora.Proposal (
ProposalThresholds,
)
import Agora.SafeMoney (GTTag)
import Agora.Utils (tclet)
--------------------------------------------------------------------------------
@ -47,7 +48,6 @@ import Plutarch.DataRepr (
PIsDataReprInstances (PIsDataReprInstances),
)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import Plutarch.Monadic qualified as P
import Plutarch.SafeMoney (Tagged (..), puntag)
import Plutarch.TryFrom (PTryFrom (..))
import Plutarch.Unsafe (punsafeCoerce)
@ -168,15 +168,17 @@ getNextProposalId (ProposalId pid) = ProposalId $ pid + 1
governorDatumValid :: Term s (PGovernorDatum :--> PBool)
governorDatumValid = phoistAcyclic $
plam $ \datum -> P.do
plam $ \datum -> unTermCont $ do
thresholds <-
tcont $
pletFields @'["execute", "draft", "vote"] $
pfield @"proposalThresholds" # datum
execute <- plet $ puntag thresholds.execute
draft <- plet $ puntag thresholds.draft
vote <- plet $ puntag thresholds.vote
execute <- tclet $ puntag thresholds.execute
draft <- tclet $ puntag thresholds.draft
vote <- tclet $ puntag thresholds.vote
pure $
foldr1
(#&&)
[ ptraceIfFalse "Execute threshold is less than or equal to" $ 0 #<= execute

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

@ -74,7 +74,6 @@ import Agora.Utils (
mustBePDJust,
mustBePJust,
mustFindDatum',
passert,
pfindTxInByTxOutRef,
pisDJust,
pisJust,
@ -84,6 +83,9 @@ import Agora.Utils (
ptxSignedBy,
pvalueSpent,
scriptHashFromAddress,
tcassert,
tclet,
tcmatch,
validatorHashToAddress,
validatorHashToTokenName,
)
@ -115,7 +117,6 @@ import Plutarch.Map.Extra (
plookup,
plookup',
)
import Plutarch.Monadic qualified as P
import Plutarch.SafeMoney (
PDiscrete,
puntag,
@ -163,24 +164,24 @@ import Plutus.V1.Ledger.Value (
-}
governorPolicy :: Governor -> ClosedTerm PMintingPolicy
governorPolicy gov =
plam $ \_ ctx' -> P.do
plam $ \_ ctx' -> unTermCont $ do
let oref = pconstant gov.gstOutRef
PMinting ((pfield @"_0" #) -> ownSymbol) <- pmatch (pfromData $ pfield @"purpose" # ctx')
PMinting ((pfield @"_0" #) -> ownSymbol) <- tcmatch (pfromData $ pfield @"purpose" # ctx')
let ownAssetClass = passetClass # ownSymbol # pconstant ""
txInfo = pfromData $ pfield @"txInfo" # ctx'
txInfoF <- pletFields @'["mint", "inputs", "outputs", "datums"] txInfo
txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "datums"] txInfo
passert "Referenced utxo should be spent" $
tcassert "Referenced utxo should be spent" $
pisUTXOSpent # oref # txInfoF.inputs
passert "Exactly one token should be minted" $
tcassert "Exactly one token should be minted" $
psymbolValueOf # ownSymbol # txInfoF.mint #== 1
#&& passetClassValueOf # txInfoF.mint # ownAssetClass #== 1
govOutput <-
plet $
tclet $
mustBePJust
# "Governor output not found"
#$ pfind
@ -193,7 +194,7 @@ governorPolicy gov =
let datumHash = pfield @"datumHash" # pfromData govOutput
datum = mustFindDatum' @PGovernorDatum # datumHash # txInfoF.datums
popaque $ governorDatumValid # datum
pure $ popaque $ governorDatumValid # datum
{- | Validator for Governors.
@ -281,51 +282,52 @@ governorPolicy gov =
-}
governorValidator :: Governor -> ClosedTerm PValidator
governorValidator gov =
plam $ \datum' redeemer' ctx' -> P.do
(pfromData -> redeemer, _) <- ptryFrom redeemer'
ctxF <- pletFields @'["txInfo", "purpose"] ctx'
plam $ \datum' redeemer' ctx' -> unTermCont $ do
(pfromData -> redeemer, _) <- tcont $ ptryFrom redeemer'
ctxF <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
txInfo' <- plet $ pfromData $ ctxF.txInfo
txInfoF <- pletFields @'["mint", "inputs", "outputs", "datums", "signatories"] txInfo'
txInfo' <- tclet $ pfromData $ ctxF.txInfo
txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "datums", "signatories"] txInfo'
PSpending (pfromData . (pfield @"_0" #) -> ownInputRef) <- pmatch $ pfromData ctxF.purpose
PSpending (pfromData . (pfield @"_0" #) -> ownInputRef) <- tcmatch $ pfromData ctxF.purpose
((pfield @"resolved" #) -> ownInput) <-
plet $
tclet $
mustBePJust # "Own input not found"
#$ pfindTxInByTxOutRef # ownInputRef # txInfoF.inputs
ownInputF <- pletFields @'["address", "value"] ownInput
ownInputF <- tcont $ pletFields @'["address", "value"] ownInput
let ownAddress = pfromData $ ownInputF.address
(pfromData -> (oldGovernorDatum :: Term _ PGovernorDatum), _) <- ptryFrom datum'
oldGovernorDatumF <- pletFields @'["proposalThresholds", "nextProposalId"] oldGovernorDatum
(pfromData -> (oldGovernorDatum :: Term _ PGovernorDatum), _) <- tcont $ ptryFrom datum'
oldGovernorDatumF <- tcont $ pletFields @'["proposalThresholds", "nextProposalId"] oldGovernorDatum
-- Check that GST will be returned to the governor.
let ownInputGSTAmount = psymbolValueOf # pgstSymbol # ownInputF.value
passert "Own input should have exactly one state token" $
tcassert "Own input should have exactly one state token" $
ownInputGSTAmount #== 1
ownOutputs <- plet $ findOutputsToAddress # txInfoF.outputs # ownAddress
passert "Exactly one utxo should be sent to the governor" $
ownOutputs <- tclet $ findOutputsToAddress # txInfoF.outputs # ownAddress
tcassert "Exactly one utxo should be sent to the governor" $
plength # ownOutputs #== 1
ownOutput <- pletFields @'["value", "datumHash"] $ phead # ownOutputs
ownOutput <- tcont $ pletFields @'["value", "datumHash"] $ phead # ownOutputs
let ownOuputGSTAmount = psymbolValueOf # pgstSymbol # ownOutput.value
passert "State token should stay at governor's address" $
tcassert "State token should stay at governor's address" $
ownOuputGSTAmount #== 1
-- Check that own output have datum of type 'GovernorDatum'.
let outputGovernorStateDatumHash =
mustBePDJust # "Governor output doesn't have datum" # ownOutput.datumHash
newGovernorDatum <-
plet $
tclet $
pfromData $
mustBePJust # "Ouput governor state datum not found"
#$ ptryFindDatum # outputGovernorStateDatumHash # txInfoF.datums
passert "New datum is not valid" $ governorDatumValid # newGovernorDatum
tcassert "New datum is not valid" $ governorDatumValid # newGovernorDatum
pure $
pmatch redeemer $ \case
PCreateProposal _ -> P.do
PCreateProposal _ -> unTermCont $ do
-- Check that the transaction advances proposal id.
let expectedNextProposalId = pgetNextProposalId # oldGovernorDatumF.nextProposalId
@ -335,124 +337,128 @@ governorValidator gov =
( #proposalThresholds .= oldGovernorDatumF.proposalThresholds
.& #nextProposalId .= pdata expectedNextProposalId
)
passert "Unexpected governor state datum" $
tcassert "Unexpected governor state datum" $
newGovernorDatum #== expectedNewDatum
-- Check that exactly one proposal token is being minted.
passert "Exactly one proposal token must be minted" $
tcassert "Exactly one proposal token must be minted" $
hasOnlyOneTokenOfCurrencySymbol # ppstSymbol # txInfoF.mint
-- Check that a stake is spent to create the propsal,
-- and the value it contains meets the requirement.
stakeInput <-
plet $
tclet $
mustBePJust # "Stake input not found" #$ pfind
# phoistAcyclic
( plam $
\((pfield @"resolved" #) -> txOut') -> P.do
txOut <- pletFields @'["address", "value"] txOut'
\((pfield @"resolved" #) -> txOut') -> unTermCont $ do
txOut <- tcont $ pletFields @'["address", "value"] txOut'
pure $
txOut.address #== pdata pstakeValidatorAddress
#&& psymbolValueOf # psstSymbol # txOut.value #== 1
)
# pfromData txInfoF.inputs
stakeInputF <- pletFields @'["datumHash", "value"] $ pfield @"resolved" # stakeInput
stakeInputF <- tcont $ pletFields @'["datumHash", "value"] $ pfield @"resolved" # stakeInput
passert "Stake input doesn't have datum" $
tcassert "Stake input doesn't have datum" $
pisDJust # stakeInputF.datumHash
let stakeInputDatum = mustFindDatum' @PStakeDatum # stakeInputF.datumHash # txInfoF.datums
stakeInputDatumF <-
pletFields @["stakedAmount", "owner", "lockedBy"] stakeInputDatum
tcont $ pletFields @["stakedAmount", "owner", "lockedBy"] stakeInputDatum
passert "Required amount of stake GTs should be presented" $
tcassert "Required amount of stake GTs should be presented" $
stakeInputDatumF.stakedAmount #== (pgtValueOf # stakeInputF.value)
-- TODO: Is this required?
passert "Tx should be signed by the stake owner" $
tcassert "Tx should be signed by the stake owner" $
ptxSignedBy # txInfoF.signatories # stakeInputDatumF.owner
-- Check that the newly minted PST is sent to the proposal validator,
-- and the datum it carries is legal.
outputsToProposalValidatorWithStateToken <-
plet $
tclet $
pfilter
# phoistAcyclic
( plam $
\txOut' -> P.do
txOut <- pletFields @'["address", "value"] txOut'
\txOut' -> unTermCont $ do
txOut <- tcont $ pletFields @'["address", "value"] txOut'
pure $
txOut.address #== pdata pproposalValidatorAddress
#&& psymbolValueOf # ppstSymbol # txOut.value #== 1
)
# pfromData txInfoF.outputs
passert "Exactly one UTXO with proposal state token should be sent to the proposal validator" $
tcassert "Exactly one UTXO with proposal state token should be sent to the proposal validator" $
plength # outputsToProposalValidatorWithStateToken #== 1
outputDatumHash <- plet $ pfield @"datumHash" #$ phead # outputsToProposalValidatorWithStateToken
outputDatumHash <- tclet $ pfield @"datumHash" #$ phead # outputsToProposalValidatorWithStateToken
passert "The utxo paid to the proposal validator must have datum" $
tcassert "The utxo paid to the proposal validator must have datum" $
pisDJust # outputDatumHash
proposalOutputDatum' <-
plet $
tclet $
mustFindDatum' @PProposalDatum
# outputDatumHash
# txInfoF.datums
passert "Proposal datum must be valid" $
tcassert "Proposal datum must be valid" $
proposalDatumValid' # proposalOutputDatum'
proposalOutputDatum <-
tcont $
pletFields
@'["proposalId", "status", "cosigners", "thresholds", "votes"]
proposalOutputDatum'
-- Id and thresholds should be copied from the old governor state datum.
passert "Invalid proposal id in proposal datum" $
tcassert "Invalid proposal id in proposal datum" $
proposalOutputDatum.proposalId #== oldGovernorDatumF.nextProposalId
passert "Invalid thresholds in proposal datum" $
tcassert "Invalid thresholds in proposal datum" $
proposalOutputDatum.thresholds #== oldGovernorDatumF.proposalThresholds
-- The proposal at this point should be in draft state.
passert "Proposal state should be draft" $
tcassert "Proposal state should be draft" $
proposalOutputDatum.status #== pconstantData Draft
passert "Proposal should have only one cosigner" $
tcassert "Proposal should have only one cosigner" $
plength # pfromData proposalOutputDatum.cosigners #== 1
let cosigner = phead # pfromData proposalOutputDatum.cosigners
passert "Cosigner should be the stake owner" $
tcassert "Cosigner should be the stake owner" $
pdata stakeInputDatumF.owner #== cosigner
-- Check the output stake has been proposly updated.
stakeOutput <-
plet $
tclet $
mustBePJust
# "Stake output not found"
#$ pfind
# phoistAcyclic
( plam $
\txOut' -> P.do
txOut <- pletFields @'["address", "value"] txOut'
\txOut' -> unTermCont $ do
txOut <- tcont $ pletFields @'["address", "value"] txOut'
pure $
txOut.address #== pdata pstakeValidatorAddress
#&& psymbolValueOf # psstSymbol # txOut.value #== 1
)
# pfromData txInfoF.outputs
stakeOutputF <- pletFields @'["datumHash", "value"] $ stakeOutput
stakeOutputF <- tcont $ pletFields @'["datumHash", "value"] $ stakeOutput
passert "Staked GTs should be sent back to stake validator" $
tcassert "Staked GTs should be sent back to stake validator" $
stakeInputDatumF.stakedAmount #== (pgtValueOf # stakeOutputF.value)
let stakeOutputDatumHash = mustBePDJust # "Stake output should have datum" # stakeOutputF.datumHash
@ -490,21 +496,22 @@ governorValidator gov =
.& #lockedBy .= pdata expectedProposalLocks
)
passert "Unexpected stake output datum" $ expectedStakeOutputDatum #== stakeOutputDatum
tcassert "Unexpected stake output datum" $ expectedStakeOutputDatum #== stakeOutputDatum
popaque $ pconstant ()
pure $ popaque $ pconstant ()
--------------------------------------------------------------------------
PMintGATs _ -> P.do
passert "Governor state should not be changed" $ newGovernorDatum #== oldGovernorDatum
PMintGATs _ -> unTermCont $ do
tcassert "Governor state should not be changed" $ newGovernorDatum #== oldGovernorDatum
-- Filter out proposal inputs and ouputs using PST and the address of proposal validator.
passert "The governor can only process one proposal at a time" $
tcassert "The governor can only process one proposal at a time" $
(psymbolValueOf # ppstSymbol #$ pvalueSpent # txInfoF.inputs) #== 1
proposalInputF <-
tcont $
pletFields @'["datumHash"] $
pfield @"resolved"
#$ pfromData
@ -512,48 +519,52 @@ governorValidator gov =
# "Proposal input not found"
#$ pfind
# plam
( \((pfield @"resolved" #) -> txOut) -> P.do
txOutF <- pletFields @'["address", "value"] txOut
( \((pfield @"resolved" #) -> txOut) -> unTermCont $ do
txOutF <- tcont $ pletFields @'["address", "value"] txOut
pure $
psymbolValueOf # ppstSymbol # txOutF.value #== 1
#&& txOutF.address #== pdata pproposalValidatorAddress
)
# pfromData txInfoF.inputs
proposalOutputF <-
tcont $
pletFields @'["datumHash"] $
mustBePJust # "Proposal output not found"
#$ pfind
# plam
( \txOut -> P.do
txOutF <- pletFields @'["address", "value"] txOut
( \txOut -> unTermCont $ do
txOutF <- tcont $ pletFields @'["address", "value"] txOut
pure $
psymbolValueOf # ppstSymbol # txOutF.value #== 1
#&& txOutF.address #== pdata pproposalValidatorAddress
)
# pfromData txInfoF.outputs
proposalInputDatum <-
plet $
tclet $
mustFindDatum' @PProposalDatum
# proposalInputF.datumHash
# txInfoF.datums
proposalOutputDatum <-
plet $
tclet $
mustFindDatum' @PProposalDatum
# proposalOutputF.datumHash
# txInfoF.datums
passert "Proposal datum must be valid" $
tcassert "Proposal datum must be valid" $
proposalDatumValid' # proposalInputDatum
#&& proposalDatumValid' # proposalOutputDatum
proposalInputDatumF <-
tcont $
pletFields @'["proposalId", "effects", "status", "cosigners", "thresholds", "votes"]
proposalInputDatum
-- Check that the proposal state is advanced so that a proposal cannot be executed twice.
passert "Proposal must be in locked(executable) state in order to execute effects" $
tcassert "Proposal must be in locked(executable) state in order to execute effects" $
proposalInputDatumF.status #== pconstantData Locked
let expectedOutputProposalDatum =
@ -567,7 +578,7 @@ governorValidator gov =
.& #votes .= proposalInputDatumF.votes
)
passert "Unexpected output proposal datum" $
tcassert "Unexpected output proposal datum" $
pdata proposalOutputDatum #== pdata expectedOutputProposalDatum
-- TODO: anything else to check here?
@ -579,11 +590,11 @@ governorValidator gov =
( \pair last' ->
pif
(pisJust # last')
( P.do
PJust last <- pmatch last'
( unTermCont $ do
PJust last <- tcmatch last'
let lastHighestVote = pfromData $ psndBuiltin # last
thisVote = pfromData $ psndBuiltin # pair
pif (lastHighestVote #< thisVote) (pcon $ PJust pair) last'
pure $ pif (lastHighestVote #< thisVote) (pcon $ PJust pair) last'
)
(pcon $ PJust pair)
)
@ -593,26 +604,26 @@ governorValidator gov =
maybeWinner =
pfoldr # highestVoteFolder # pcon PNothing # votesList
winner <- plet $ mustBePJust # "No winning outcome" # maybeWinner
winner <- tclet $ mustBePJust # "No winning outcome" # maybeWinner
let highestVote = pfromData $ psndBuiltin # winner
minimumVotes = puntag $ pfromData $ pfield @"execute" # proposalInputDatumF.thresholds
passert "Higgest vote doesn't meet the minimum requirement" $ minimumVotes #<= highestVote
tcassert "Higgest vote doesn't meet the minimum requirement" $ minimumVotes #<= highestVote
let finalResultTag = pfromData $ pfstBuiltin # winner
-- The effects of the winner outcome.
effectGroup <- plet $ plookup' # finalResultTag #$ proposalInputDatumF.effects
effectGroup <- tclet $ plookup' # finalResultTag #$ proposalInputDatumF.effects
gatCount <- plet $ plength #$ pto $ pto effectGroup
gatCount <- tclet $ plength #$ pto $ pto effectGroup
passert "Required amount of GATs should be minted" $
tcassert "Required amount of GATs should be minted" $
psymbolValueOf # patSymbol # txInfoF.mint #== gatCount
-- Ensure that every GAT goes to one of the effects in the winner effect group.
outputsWithGAT <-
plet $
tclet $
pfilter
# phoistAcyclic
( plam
@ -622,15 +633,15 @@ governorValidator gov =
)
# pfromData txInfoF.outputs
passert "Output GATs is more than minted GATs" $
tcassert "Output GATs is more than minted GATs" $
plength # outputsWithGAT #== gatCount
let gatOutputValidator' :: Term s (PMap PValidatorHash PDatumHash :--> PAsData PTxOut :--> PBool)
gatOutputValidator' =
phoistAcyclic $
plam
( \effects (pfromData -> output') -> P.do
output <- pletFields @'["address", "datumHash"] $ output'
( \effects (pfromData -> output') -> unTermCont $ do
output <- tcont $ pletFields @'["address", "datumHash"] $ output'
let scriptHash =
mustBePJust # "GAT receiver is not a script"
@ -643,6 +654,7 @@ governorValidator gov =
mustBePJust # "Receiver is not in the effect list"
#$ plookup # scriptHash # effects
pure $
foldr1
(#&&)
[ ptraceIfFalse "GAT must be tagged by the effect hash" $ authorityTokensValidIn # patSymbol # output'
@ -652,6 +664,7 @@ governorValidator gov =
gatOutputValidator = gatOutputValidator' # effectGroup
pure $
popaque $
pfoldr
# plam
@ -666,9 +679,9 @@ governorValidator gov =
--------------------------------------------------------------------------
PMutateGovernor _ -> P.do
PMutateGovernor _ -> unTermCont $ do
-- Check that a GAT is burnt.
popaque $ singleAuthorityTokenBurned patSymbol ctxF.txInfo txInfoF.mint
pure $ popaque $ singleAuthorityTokenBurned patSymbol ctxF.txInfo txInfoF.mint
where
-- Get th amount of governance tokens in a value.
pgtValueOf :: Term s (PValue :--> PDiscrete GTTag)

6
agora/Agora/MultiSig.hs
View file

@ -28,7 +28,6 @@ import Plutarch.Lift (
PLifted,
PUnsafeLiftDecl,
)
import Plutarch.Monadic qualified as P
import Plutus.V1.Ledger.Crypto (PubKeyHash)
import PlutusTx qualified
@ -88,9 +87,10 @@ validatedByMultisig params =
pvalidatedByMultisig :: Term s (PMultiSig :--> PTxInfo :--> PBool)
pvalidatedByMultisig =
phoistAcyclic $
plam $ \multi' txInfo -> P.do
multi <- pletFields @'["keys", "minSigs"] multi'
plam $ \multi' txInfo -> unTermCont $ do
multi <- tcont $ pletFields @'["keys", "minSigs"] multi'
let signatories = pfield @"signatories" # txInfo
pure $
pfromData multi.minSigs
#<= ( plength #$ pfilter
# plam

6
agora/Agora/Proposal.hs
View file

@ -54,7 +54,6 @@ import Plutarch.Lift (
PConstantDecl,
PUnsafeLiftDecl (..),
)
import Plutarch.Monadic qualified as P
import Plutarch.SafeMoney (PDiscrete, Tagged)
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
import Plutarch.Unsafe (punsafeCoerce)
@ -411,8 +410,8 @@ deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instanc
proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool)
proposalDatumValid proposal =
phoistAcyclic $
plam $ \datum' -> P.do
datum <- pletFields @'["effects", "cosigners", "votes"] $ datum'
plam $ \datum' -> unTermCont $ do
datum <- tcont $ pletFields @'["effects", "cosigners", "votes"] $ datum'
let atLeastOneNegativeResult =
pany
@ -425,6 +424,7 @@ proposalDatumValid proposal =
#$ pto
$ pfromData datum.effects
pure $
foldr1
(#&&)
[ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult

97
agora/Agora/Proposal/Scripts.hs
View file

@ -21,12 +21,15 @@ import Agora.Utils (
anyOutput,
findTxOutByTxOutRef,
getMintingPolicySymbol,
passert,
pisUniq,
psymbolValueOf,
ptokenSpent,
ptxSignedBy,
pvalueSpent,
tcassert,
tclet,
tcmatch,
tctryFrom,
)
import Plutarch.Api.V1 (
PMintingPolicy,
@ -36,8 +39,6 @@ import Plutarch.Api.V1 (
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.
@ -63,31 +64,31 @@ proposalPolicy ::
AssetClass ->
ClosedTerm PMintingPolicy
proposalPolicy (AssetClass (govCs, govTn)) =
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
plam $ \_redeemer ctx' -> unTermCont $ do
PScriptContext ctx' <- tcmatch ctx'
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
PTxInfo txInfo' <- tcmatch $ pfromData ctx.txInfo
txInfo <- tcont $ pletFields @'["inputs", "mint"] txInfo'
PMinting _ownSymbol <- tcmatch $ pfromData ctx.purpose
let inputs = txInfo.inputs
mintedValue = pfromData txInfo.mint
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
PMinting ownSymbol' <- tcmatch $ pfromData ctx.purpose
let mintedProposalST =
passetClassValueOf
# mintedValue
# (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
passert "Governance state-thread token must move" $
tcassert "Governance state-thread token must move" $
ptokenSpent
# (passetClass # pconstant govCs # pconstant govTn)
# inputs
passert "Minted exactly one proposal ST" $
tcassert "Minted exactly one proposal ST" $
mintedProposalST #== 1
popaque (pconstant ())
pure $ popaque (pconstant ())
{- | The validator for Proposals.
@ -117,23 +118,24 @@ A list of all time-sensitive redeemers and their requirements:
-}
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
plam $ \datum redeemer ctx' -> unTermCont $ do
PScriptContext ctx' <- tcmatch ctx'
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
txInfo <- tclet $ pfromData ctx.txInfo
PTxInfo txInfo' <- tcmatch txInfo
txInfoF <- tcont $ pletFields @'["inputs", "mint", "datums", "signatories"] txInfo'
PSpending ((pfield @"_0" #) -> txOutRef) <- tcmatch $ pfromData ctx.purpose
PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
txOutF <- pletFields @'["address", "value"] $ txOut
PJust txOut <- tcmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
txOutF <- tcont $ pletFields @'["address", "value"] $ txOut
(pfromData -> proposalDatum, _) <-
ptryFrom @(PAsData PProposalDatum) datum
tctryFrom @(PAsData PProposalDatum) datum
(pfromData -> proposalRedeemer, _) <-
ptryFrom @(PAsData PProposalRedeemer) redeemer
tctryFrom @(PAsData PProposalRedeemer) redeemer
proposalF <-
tcont $
pletFields
@'[ "proposalId"
, "effects"
@ -144,40 +146,40 @@ proposalValidator proposal =
]
proposalDatum
ownAddress <- plet $ txOutF.address
ownAddress <- tclet $ txOutF.address
let stCurrencySymbol =
pconstant $ getMintingPolicySymbol (proposalPolicy proposal.governorSTAssetClass)
valueSpent <- plet $ pvalueSpent # txInfoF.inputs
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
valueSpent <- tclet $ pvalueSpent # txInfoF.inputs
spentST <- tclet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
stakeSTAssetClass <-
plet $ passetClass # pconstant stakeSym # pconstant stakeTn
tclet $ passetClass # pconstant stakeSym # pconstant stakeTn
spentStakeST <-
plet $ passetClassValueOf # valueSpent # stakeSTAssetClass
tclet $ passetClassValueOf # valueSpent # stakeSTAssetClass
signedBy <- plet $ ptxSignedBy # txInfoF.signatories
signedBy <- tclet $ ptxSignedBy # txInfoF.signatories
passert "ST at inputs must be 1" $
spentST #== 1
tcassert "ST at inputs must be 1" (spentST #== 1)
pure $
pmatch proposalRedeemer $ \case
PVote _r -> P.do
popaque (pconstant ())
PVote _r -> popaque (pconstant ())
--------------------------------------------------------------------------
PCosign r -> P.do
newSigs <- plet $ pfield @"newCosigners" # r
PCosign r -> unTermCont $ do
newSigs <- tclet $ pfield @"newCosigners" # r
passert "Cosigners are unique" $
tcassert "Cosigners are unique" $
pisUniq # phoistAcyclic (plam $ \(pfromData -> x) (pfromData -> y) -> x #< y) # newSigs
passert "Signed by all new cosigners" $
tcassert "Signed by all new cosigners" $
pall # signedBy # newSigs
passert "As many new cosigners as Stake datums" $
tcassert "As many new cosigners as Stake datums" $
spentStakeST #== plength # newSigs
passert "All new cosigners are witnessed by their Stake datums" $
tcassert "All new cosigners are witnessed by their Stake datums" $
pall
# plam
( \sig ->
@ -193,10 +195,10 @@ proposalValidator proposal =
)
# newSigs
passert "Signatures are correctly added to cosignature list" $
tcassert "Signatures are correctly added to cosignature list" $
anyOutput @PProposalDatum # ctx.txInfo
#$ plam
$ \newValue address newProposalDatum -> P.do
$ \newValue address newProposalDatum ->
let updatedSigs = pconcat # newSigs # proposalF.cosigners
correctDatum =
pdata newProposalDatum
@ -211,8 +213,7 @@ proposalValidator proposal =
.& #votes .= proposalF.votes
)
)
foldr1
in foldr1
(#&&)
[ ptraceIfFalse "Datum must be correct" correctDatum
, ptraceIfFalse "Value should be correct" $
@ -221,10 +222,10 @@ proposalValidator proposal =
ownAddress #== pdata address
]
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PUnlock _r ->
popaque (pconstant ())
--------------------------------------------------------------------------
PUnlock _r -> P.do
popaque (pconstant ())
--------------------------------------------------------------------------
PAdvanceProposal _r -> P.do
PAdvanceProposal _r ->
popaque (pconstant ())

24
agora/Agora/Proposal/Time.hs
View file

@ -28,6 +28,7 @@ module Agora.Proposal.Time (
) where
import Agora.Record (mkRecordConstr, (.&), (.=))
import Agora.Utils (tcmatch)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (
@ -39,7 +40,6 @@ import Plutarch.Api.V1 (
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)
@ -159,13 +159,14 @@ instance AdditiveSemigroup (Term s PPOSIXTime) where
-}
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
plam $ \iv -> unTermCont $ do
PInterval iv' <- tcmatch iv
ivf <- tcont $ pletFields @'["from", "to"] iv'
PLowerBound lb <- tcmatch ivf.from
PUpperBound ub <- tcmatch ivf.to
lbf <- tcont $ pletFields @'["_0", "_1"] lb
ubf <- tcont $ pletFields @'["_0", "_1"] ub
pure $
mkRecordConstr PProposalTime $
#lowerBound
.= pmatch
@ -192,9 +193,10 @@ proposalTimeWithin ::
:--> PBool
)
proposalTimeWithin = phoistAcyclic $
plam $ \l h proposalTime' -> P.do
PProposalTime proposalTime <- pmatch proposalTime'
ptf <- pletFields @'["lowerBound", "upperBound"] proposalTime
plam $ \l h proposalTime' -> unTermCont $ do
PProposalTime proposalTime <- tcmatch proposalTime'
ptf <- tcont $ pletFields @'["lowerBound", "upperBound"] proposalTime
pure $
foldr1
(#&&)
[ l #<= pfromData ptf.lowerBound

25
agora/Agora/Stake.hs
View file

@ -53,7 +53,6 @@ import Plutarch.DataRepr (
)
import Plutarch.Internal (punsafeCoerce)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import Plutarch.Monadic qualified as P
import Plutus.V1.Ledger.Value (AssetClass)
--------------------------------------------------------------------------------
@ -63,6 +62,8 @@ import Agora.SafeMoney (GTTag)
import Agora.Utils (
pnotNull,
ptryFindDatum,
tclet,
tcmatch,
)
import Control.Applicative (Const)
import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf)
@ -274,19 +275,20 @@ findStakeOwnedBy = phoistAcyclic $
plam $ \ac pk datums inputs ->
pmatch (pfind # (isInputStakeOwnedBy # ac # pk # datums) # inputs) $ \case
PNothing -> pcon PNothing
PJust (pfromData -> v) -> P.do
PJust (pfromData -> v) -> unTermCont $ do
let txOut = pfield @"resolved" # pto v
txOutF <- pletFields @'["datumHash"] $ txOut
txOutF <- tcont $ pletFields @'["datumHash"] $ txOut
pure $
pmatch txOutF.datumHash $ \case
PDNothing _ -> pcon PNothing
PDJust ((pfield @"_0" #) -> dh) -> P.do
PDJust ((pfield @"_0" #) -> dh) ->
ptryFindDatum @(PAsData PStakeDatum) # dh # datums
stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
stakeDatumOwnedBy =
phoistAcyclic $
plam $ \pk stakeDatum -> P.do
stakeDatumF <- pletFields @'["owner"] $ pto stakeDatum
plam $ \pk stakeDatum ->
pletFields @'["owner"] (pto stakeDatum) $ \stakeDatumF ->
stakeDatumF.owner #== pdata pk
-- Does the input have a `Stake` owned by a particular PK?
@ -299,11 +301,12 @@ isInputStakeOwnedBy ::
:--> 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
plam $ \ac ss datums txInInfo' -> unTermCont $ do
PTxInInfo ((pfield @"resolved" #) -> txOut) <- tcmatch $ pfromData txInInfo'
PTxOut txOut' <- tcmatch txOut
txOutF <- tcont $ pletFields @'["value", "datumHash"] txOut'
outStakeST <- tclet $ passetClassValueOf # txOutF.value # ac
pure $
pmatch txOutF.datumHash $ \case
PDNothing _ -> pcon PFalse
PDJust ((pfield @"_0" #) -> datumHash) ->

184
agora/Agora/Stake/Scripts.hs
View file

@ -13,7 +13,6 @@ import Agora.Utils (
anyInput,
anyOutput,
paddValue,
passert,
pfindTxInByTxOutRef,
pgeqByClass,
pgeqByClass',
@ -24,6 +23,10 @@ import Agora.Utils (
ptxSignedBy,
pvalidatorHashToTokenName,
pvalueSpent,
tcassert,
tclet,
tcmatch,
tctryFrom,
)
import Plutarch.Api.V1 (
PCredential (PPubKeyCredential, PScriptCredential),
@ -37,14 +40,12 @@ import Plutarch.Api.V1 (
)
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 (..))
@ -70,54 +71,54 @@ stakePolicy ::
Tagged GTTag AssetClass ->
ClosedTerm PMintingPolicy
stakePolicy gtClassRef =
plam $ \_redeemer ctx' -> P.do
ctx <- pletFields @'["txInfo", "purpose"] ctx'
txInfo <- plet $ ctx.txInfo
plam $ \_redeemer ctx' -> unTermCont $ do
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
txInfo <- tclet $ ctx.txInfo
let _a :: Term _ PTxInfo
_a = txInfo
txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
txInfoF <- tcont $ 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
PMinting ownSymbol' <- tcmatch $ pfromData ctx.purpose
ownSymbol <- tclet $ pfield @"_0" # ownSymbol'
spentST <- tclet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs
mintedST <- tclet $ psymbolValueOf # ownSymbol # txInfoF.mint
let burning = P.do
passert "ST at inputs must be 1" $
let burning = unTermCont $ do
tcassert "ST at inputs must be 1" $
spentST #== 1
passert "ST burned" $
tcassert "ST burned" $
mintedST #== -1
passert "An unlocked input existed containing an ST" $
tcassert "An unlocked input existed containing an ST" $
anyInput @PStakeDatum # txInfo
#$ plam
$ \value _ stakeDatum' -> P.do
$ \value _ stakeDatum' ->
let hasST = psymbolValueOf # ownSymbol # value #== 1
let unlocked = pnot # (stakeLocked # stakeDatum')
hasST #&& unlocked
unlocked = pnot # (stakeLocked # stakeDatum')
in hasST #&& unlocked
popaque (pconstant ())
pure $ popaque (pconstant ())
let minting = P.do
passert "ST at inputs must be 0" $
let minting = unTermCont $ do
tcassert "ST at inputs must be 0" $
spentST #== 0
passert "Minted ST must be exactly 1" $
tcassert "Minted ST must be exactly 1" $
mintedST #== 1
passert "A UTXO must exist with the correct output" $
tcassert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo
#$ plam
$ \value address stakeDatum' -> P.do
$ \value address stakeDatum' ->
let cred = pfield @"credential" # address
pmatch cred $ \case
in pmatch cred $ \case
-- Should pay to a script address
PPubKeyCredential _ -> pcon PFalse
PScriptCredential validatorHash -> P.do
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
PScriptCredential validatorHash -> unTermCont $ do
stakeDatum <- tcont $ pletFields @'["owner", "stakedAmount"] stakeDatum'
tn :: Term _ PTokenName <- plet (pvalidatorHashToTokenName $ pfromData $ pfield @"_0" # validatorHash)
tn :: Term _ PTokenName <- tclet (pvalidatorHashToTokenName $ pfromData $ pfield @"_0" # validatorHash)
let stValue =
psingletonValue
@ -152,11 +153,10 @@ stakePolicy gtClassRef =
# expectedValue
]
ownerSignsTransaction
#&& valueCorrect
popaque (pconstant ())
pure $ ownerSignsTransaction #&& valueCorrect
pure $ popaque (pconstant ())
pif (0 #< mintedST) minting burning
pure $ pif (0 #< mintedST) minting burning
--------------------------------------------------------------------------------
@ -212,74 +212,75 @@ this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
-}
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
plam $ \datum redeemer ctx' -> unTermCont $ do
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
txInfo <- tclet $ pfromData ctx.txInfo
txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
(pfromData -> stakeRedeemer, _) <- ptryFrom redeemer
(pfromData -> stakeRedeemer, _) <- tctryFrom redeemer
-- TODO: Use PTryFrom
let stakeDatum' :: Term _ PStakeDatum
stakeDatum' = pfromData $ punsafeCoerce datum
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
stakeDatum <- tcont $ pletFields @'["owner", "stakedAmount"] stakeDatum'
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
PSpending txOutRef <- tcmatch $ pfromData ctx.purpose
PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo
PJust txInInfo <- tcmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
ownAddress <- tclet $ 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
ownerSignsTransaction <- tclet $ 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
stCurrencySymbol <- tclet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
mintedST <- tclet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
valueSpent <- tclet $ pvalueSpent # txInfoF.inputs
spentST <- tclet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
let AssetClass (propCs, propTn) = stake.proposalSTClass
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
spentProposalST <- plet $ passetClassValueOf # valueSpent # proposalSTClass
spentProposalST <- tclet $ passetClassValueOf # valueSpent # proposalSTClass
-- Is the stake currently locked?
stakeIsLocked <- plet $ stakeLocked # stakeDatum'
stakeIsLocked <- tclet $ stakeLocked # stakeDatum'
pure $
pmatch stakeRedeemer $ \case
PDestroy _ -> P.do
passert "ST at inputs must be 1" $
PDestroy _ -> unTermCont $ do
tcassert "ST at inputs must be 1" $
spentST #== 1
passert "Should burn ST" $
tcassert "Should burn ST" $
mintedST #== -1
passert "Stake unlocked" $ pnot # stakeIsLocked
tcassert "Stake unlocked" $ pnot # stakeIsLocked
passert "Owner signs this transaction" ownerSignsTransaction
tcassert "Owner signs this transaction" ownerSignsTransaction
popaque (pconstant ())
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PRetractVotes _ -> P.do
passert
PRetractVotes _ -> unTermCont $ do
tcassert
"Owner signs this transaction"
ownerSignsTransaction
passert "ST at inputs must be 1" $
tcassert "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" $
tcassert "Proposal ST spent" $
spentProposalST #== 1
passert "A UTXO must exist with the correct output" $
tcassert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo
#$ plam
$ \value address newStakeDatum' -> P.do
$ \value address newStakeDatum' ->
let isScriptAddress = pdata address #== ownAddress
let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
let valueCorrect = pdata continuingValue #== pdata value
pif
_correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
valueCorrect = pdata continuingValue #== pdata value
in pif
isScriptAddress
( foldl1
(#&&)
@ -288,26 +289,26 @@ stakeValidator stake =
)
(pcon PFalse)
popaque (pconstant ())
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PPermitVote _ -> P.do
passert
PPermitVote _ -> unTermCont $ do
tcassert
"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" $
tcassert "Proposal ST spent" $
spentProposalST #== 1
passert "A UTXO must exist with the correct output" $
tcassert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo
#$ plam
$ \value address newStakeDatum' -> P.do
$ \value address newStakeDatum' ->
let isScriptAddress = pdata address #== ownAddress
let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
let valueCorrect = pdata continuingValue #== pdata value
pif
_correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
valueCorrect = pdata continuingValue #== pdata value
in pif
isScriptAddress
( foldl1
(#&&)
@ -316,10 +317,10 @@ stakeValidator stake =
)
(pcon PFalse)
popaque (pconstant ())
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PWitnessStake _ -> P.do
passert "ST at inputs must be 1" $
PWitnessStake _ -> unTermCont $ do
tcassert "ST at inputs must be 1" $
spentST #== 1
let AssetClass (propCs, propTn) = stake.proposalSTClass
@ -332,18 +333,18 @@ stakeValidator stake =
-- 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
tcassert
"Owner signs this transaction OR proposal token is spent"
(ownerSignsTransaction #|| proposalTokenMoved)
passert "A UTXO must exist with the correct output" $
tcassert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo
#$ plam
$ \value address newStakeDatum' -> P.do
$ \value address newStakeDatum' ->
let isScriptAddress = pdata address #== ownAddress
let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
let valueCorrect = pdata continuingValue #== pdata value
pif
correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
valueCorrect = pdata continuingValue #== pdata value
in pif
isScriptAddress
( foldl1
(#&&)
@ -352,21 +353,21 @@ stakeValidator stake =
]
)
(pcon PFalse)
popaque (pconstant ())
PDepositWithdraw r -> P.do
passert "ST at inputs must be 1" $
pure $ popaque (pconstant ())
PDepositWithdraw r -> unTermCont $ do
tcassert "ST at inputs must be 1" $
spentST #== 1
passert "Stake unlocked" $
tcassert "Stake unlocked" $
pnot #$ stakeIsLocked
passert
tcassert
"Owner signs this transaction"
ownerSignsTransaction
passert "A UTXO must exist with the correct output" $
tcassert "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
$ \value address newStakeDatum' -> unTermCont $ do
newStakeDatum <- tcont $ pletFields @'["owner", "stakedAmount"] newStakeDatum'
delta <- tclet $ pfield @"delta" # r
let isScriptAddress = pdata address #== ownAddress
let correctOutputDatum =
foldr1
@ -395,6 +396,7 @@ stakeValidator stake =
# expectedValue
]
pure $
foldr1
(#&&)
[ ptraceIfFalse "isScriptAddress" isScriptAddress
@ -402,4 +404,4 @@ stakeValidator stake =
, ptraceIfFalse "valueCorrect" valueCorrect
]
popaque (pconstant ())
pure $ popaque (pconstant ())

25
agora/Agora/Treasury.hs
View file

@ -11,7 +11,7 @@ treasury.
module Agora.Treasury (module Agora.Treasury) where
import Agora.AuthorityToken (singleAuthorityTokenBurned)
import Agora.Utils (passert)
import Agora.Utils (tcassert, tclet, tcmatch, tctryFrom)
import GHC.Generics qualified as GHC
import Generics.SOP
import Plutarch.Api.V1 (PValidator)
@ -22,8 +22,7 @@ import Plutarch.DataRepr (
PIsDataReprInstances (PIsDataReprInstances),
)
import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
import Plutarch.Monadic qualified as P
import Plutarch.TryFrom (PTryFrom, ptryFrom)
import Plutarch.TryFrom (PTryFrom)
import Plutus.V1.Ledger.Value (CurrencySymbol)
import PlutusTx qualified
@ -75,27 +74,27 @@ deriving via
treasuryValidator ::
CurrencySymbol ->
ClosedTerm PValidator
treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> P.do
(treasuryRedeemer, _) <- ptryFrom redeemer
treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> unTermCont $ do
(treasuryRedeemer, _) <- tctryFrom redeemer
-- plet required fields from script context.
ctx <- pletFields @["txInfo", "purpose"] ctx'
ctx <- tcont $ pletFields @["txInfo", "purpose"] ctx'
-- Ensure that script is for burning i.e. minting a negative amount.
PMinting _ <- pmatch ctx.purpose
PMinting _ <- tcmatch ctx.purpose
-- Ensure redeemer type is valid.
PSpendTreasuryGAT _ <- pmatch $ pfromData treasuryRedeemer
PSpendTreasuryGAT _ <- tcmatch $ pfromData treasuryRedeemer
-- Get the minted value from txInfo.
txInfo' <- plet ctx.txInfo
txInfo <- pletFields @'["mint"] txInfo'
txInfo' <- tclet ctx.txInfo
txInfo <- tcont $ pletFields @'["mint"] txInfo'
let mint :: Term _ PValue
mint = txInfo.mint
gatCs <- plet $ pconstant gatCs'
gatCs <- tclet $ pconstant gatCs'
passert "A single authority token has been burned" $
tcassert "A single authority token has been burned" $
singleAuthorityTokenBurned gatCs txInfo' mint
popaque $ pconstant ()
pure . popaque $ pconstant ()

238
agora/Agora/Utils.hs
View file

@ -6,8 +6,13 @@ Description: Plutarch utility functions that should be upstreamed or don't belon
Plutarch utility functions that should be upstreamed or don't belong anywhere else.
-}
module Agora.Utils (
-- * TermCont-based combinators. Some of these will live in plutarch eventually.
tcassert,
tclet,
tcmatch,
tctryFrom,
-- * Validator-level utility functions
passert,
pfind',
pfindDatum,
ptryFindDatum,
@ -92,16 +97,42 @@ import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf)
import Plutarch.Api.V1.Value (PValue (PValue))
import Plutarch.Builtin (pforgetData, ppairDataBuiltin)
import Plutarch.Map.Extra (pkeys)
import Plutarch.Monadic qualified as P
import Plutarch.TryFrom (PTryFrom, ptryFrom)
import Plutarch.Reducible (Reducible (Reduce))
import Plutarch.TryFrom (PTryFrom (PTryFromExcess), ptryFrom)
--------------------------------------------------------------------------------
-- TermCont-based combinators. Some of these will live in plutarch eventually.
-- | Assert a particular 'PBool', trace if false.
tcassert :: forall r (s :: S). Term s PString -> Term s PBool -> TermCont @r s ()
tcassert errorMessage check = tcont $ \k -> pif check (k ()) (ptraceError errorMessage)
-- | 'plet' but for use in 'TermCont'.
tclet :: forall r (s :: S) (a :: PType). Term s a -> TermCont @r s (Term s a)
tclet = tcont . plet
-- | 'pmatch' but for use in 'TermCont'.
tcmatch :: forall (a :: PType) (s :: S). PlutusType a => Term s a -> TermCont s (a s)
tcmatch = tcont . pmatch
-- | 'ptryFrom' but for use in 'TermCont'.
tctryFrom :: forall b a s r. PTryFrom a b => Term s a -> TermCont @r s (Term s b, Reduce (PTryFromExcess a b s))
tctryFrom = tcont . ptryFrom
-- | Escape with a particular value on expecting 'Just'. For use in monadic context.
tcexpectJust ::
forall r (a :: PType) (s :: S).
Term s r ->
Term s (PMaybe a) ->
TermCont @r s (Term s a)
tcexpectJust escape ma = tcont $ \f ->
pmatch ma $ \case
PJust v -> f v
PNothing -> escape
--------------------------------------------------------------------------------
-- Validator-level utility functions
-- | Assert a particular 'PBool', trace if false. Use in monadic context.
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 :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe PDatum)
pfindDatum = phoistAcyclic $
@ -113,9 +144,9 @@ ptryFindDatum = phoistAcyclic $
plam $ \datumHash inputs ->
pmatch (pfindDatum # datumHash # inputs) $ \case
PNothing -> pcon PNothing
PJust datum -> P.do
(datum', _) <- ptryFrom (pto datum)
pcon (PJust datum')
PJust datum -> unTermCont $ do
(datum', _) <- tctryFrom (pto datum)
pure $ pcon (PJust datum')
-- | Check if a PubKeyHash signs this transaction.
ptxSignedBy :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PAsData PPubKeyHash :--> PBool)
@ -181,34 +212,21 @@ pfromMaybe = phoistAcyclic $
-- | 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
plam $ \v' ->
pmatch v' $ \case
PJust _ -> pconstant True
PNothing -> pconstant False
-- | Escape with a particular value on expecting 'Just'. For use in monadic context.
pexpectJust ::
forall r a s.
Term s r ->
Term s (PMaybe a) ->
(Term s a -> Term s r) ->
Term s r
pexpectJust escape ma f =
pmatch ma $ \case
PJust v -> f v
PNothing -> escape
-- | Get the sum of all values belonging to a particular CurrencySymbol.
psymbolValueOf :: Term s (PCurrencySymbol :--> PValue :--> PInteger)
psymbolValueOf =
phoistAcyclic $
plam $ \sym value'' -> P.do
PValue value' <- pmatch value''
PMap value <- pmatch value'
m' <- pexpectJust 0 (plookup # pdata sym # value)
PMap m <- pmatch (pfromData m')
pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m
plam $ \sym value'' -> unTermCont $ do
PValue value' <- tcmatch value''
PMap value <- tcmatch value'
m' <- tcexpectJust 0 (plookup # pdata sym # value)
PMap m <- tcmatch (pfromData m')
pure $ pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m
-- | Extract amount from PValue belonging to a Haskell-level AssetClass.
passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger)
@ -240,14 +258,15 @@ pgeqByClass' ac =
pmapUnionWith :: forall k v s. PIsData v => Term s ((v :--> v :--> v) :--> PMap k v :--> PMap k v :--> PMap k v)
pmapUnionWith = phoistAcyclic $
-- TODO: this function is kinda suspect. I feel like a lot of optimizations could be done here
plam $ \f xs' ys' -> P.do
PMap xs <- pmatch xs'
PMap ys <- pmatch ys'
plam $ \f xs' ys' -> unTermCont $ do
PMap xs <- tcmatch xs'
PMap ys <- tcmatch ys'
let ls =
pmap
# plam
( \p -> P.do
pf <- plet $ pfstBuiltin # p
( \p -> unTermCont $ do
pf <- tclet $ pfstBuiltin # p
pure $
pmatch (plookup # pf # ys) $ \case
PJust v ->
-- Data conversions here are silly, aren't they?
@ -262,14 +281,15 @@ pmapUnionWith = phoistAcyclic $
pnot #$ pany # plam (\p' -> pfstBuiltin # p' #== pfstBuiltin # p) # xs
)
# ys
pcon (PMap $ pconcat # ls # rs)
pure $ pcon (PMap $ pconcat # ls # rs)
-- | Add two 'PValue's together.
paddValue :: forall s. Term s (PValue :--> PValue :--> PValue)
paddValue = phoistAcyclic $
plam $ \a' b' -> P.do
PValue a <- pmatch a'
PValue b <- pmatch b'
plam $ \a' b' -> unTermCont $ do
PValue a <- tcmatch a'
PValue b <- tcmatch b'
pure $
pcon
( PValue $
pmapUnionWith # plam (\a' b' -> pmapUnionWith # plam (+) # a' # b') # a # b
@ -325,12 +345,12 @@ ptokenSpent =
0
#< pfoldr @PBuiltinList
# plam
( \txInInfo' acc -> P.do
PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
txOut <- pletFields @'["value"] txOut'
( \txInInfo' acc -> unTermCont $ do
PTxInInfo txInInfo <- tcmatch (pfromData txInInfo')
PTxOut txOut' <- tcmatch $ pfromData $ pfield @"resolved" # txInInfo
txOut <- tcont $ pletFields @'["value"] txOut'
let txOutValue = pfromData txOut.value
acc + passetClassValueOf # txOutValue # tokenClass
pure $ acc + passetClassValueOf # txOutValue # tokenClass
)
# 0
# inputs
@ -340,36 +360,41 @@ ptokenSpent =
-}
pkeysEqual :: (POrd k, PIsData k) => forall (s :: S) 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
plam $ \p q -> unTermCont $ do
pks <- tclet $ pkeys # p
qks <- tclet $ pkeys # q
pure $
pif
(plength # pks #== plength # qks)
( P.do
( unTermCont $ do
let comp = phoistAcyclic $ plam $ \(pfromData -> x) (pfromData -> y) -> x #< y
spks = pmsort # comp # pks
sqks = pmsort # comp # qks
plistEquals # spks # sqks
pure $ plistEquals # spks # sqks
)
(pcon PFalse)
-- | / O(nlogn) /. Clear out duplicates in a list. The order is not preserved.
pnub :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s ((a :--> a :--> PBool) :--> list a :--> list a)
pnub = phoistAcyclic $
plam $ \comp xs -> P.do
sorted <- plet $ pmsort # comp # xs
pnubOrd # comp # sorted
plam $ \comp xs -> unTermCont $ do
sorted <- tclet $ pmsort # comp # xs
pure $ pnubOrd # comp # sorted
where
pnubOrd = phoistAcyclic $ pfix #$ plam pnubOrd'
pnubOrd' self comp xs =
pif (pnull # xs) pnil $ P.do
xh <- plet $ phead # xs
xt <- plet $ ptail # xs
pif (pnull # xs) pnil $
unTermCont $ do
xh <- tclet $ phead # xs
xt <- tclet $ ptail # xs
pif (pnull # xt) xs $ P.do
xh' <- plet $ phead # xt
pure $
pif (pnull # xt) xs $
unTermCont $ do
xh' <- tclet $ phead # xt
pure $
pif
(xh #== xh')
(self # comp # xt)
@ -410,12 +435,14 @@ pmerge = phoistAcyclic $ pfix #$ plam pmerge'
where
pmerge' self comp a b =
pif (pnull # a) b $
pif (pnull # b) a $ P.do
ah <- plet $ phead # a
at <- plet $ ptail # a
bh <- plet $ phead # b
bt <- plet $ ptail # b
pif (pnull # b) a $
unTermCont $ do
ah <- tclet $ phead # a
at <- tclet $ ptail # a
bh <- tclet $ phead # b
bt <- tclet $ ptail # b
pure $
pif
(comp # ah # bh)
(pcons # ah #$ self # comp # at # b)
@ -447,14 +474,17 @@ phalve = phoistAcyclic $ plam $ \l -> go # l # l
pif
(pnull # ys)
(pcon $ PPair pnil xs)
( P.do
yt <- plet $ ptail # ys
( unTermCont $ do
yt <- tclet $ ptail # ys
xh <- plet $ phead # xs
xt <- plet $ ptail # xs
xh <- tclet $ phead # xs
xt <- tclet $ ptail # xs
pif (pnull # yt) (pcon $ PPair (psingleton # xh) xt) $ P.do
yt' <- plet $ ptail # yt
pure $
pif (pnull # yt) (pcon $ PPair (psingleton # xh) xt) $
unTermCont $ do
yt' <- tclet $ ptail # yt
pure $
pmatch (self # xt # yt') $ \(PPair first last) ->
pcon $ PPair (pcons # xh # first) last
)
@ -472,17 +502,18 @@ anyOutput ::
) =>
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
anyOutput = phoistAcyclic $
plam $ \txInfo' predicate -> P.do
txInfo <- pletFields @'["outputs", "datums"] txInfo'
plam $ \txInfo' predicate -> unTermCont $ do
txInfo <- tcont $ pletFields @'["outputs", "datums"] txInfo'
pure $
pany
# plam
( \txOut'' -> P.do
PTxOut txOut' <- pmatch (pfromData txOut'')
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
PDJust dh <- pmatch txOut.datumHash
( \txOut'' -> unTermCont $ do
PTxOut txOut' <- tcmatch (pfromData txOut'')
txOut <- tcont $ pletFields @'["value", "datumHash", "address"] txOut'
PDJust dh <- tcmatch txOut.datumHash
pure $
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
PJust datum -> P.do
predicate # txOut.value # txOut.address # pfromData datum
PJust datum -> predicate # txOut.value # txOut.address # pfromData datum
PNothing -> pcon PFalse
)
# pfromData txInfo.outputs
@ -495,17 +526,18 @@ allOutputs ::
) =>
Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
allOutputs = phoistAcyclic $
plam $ \txInfo' predicate -> P.do
txInfo <- pletFields @'["outputs", "datums"] txInfo'
plam $ \txInfo' predicate -> unTermCont $ do
txInfo <- tcont $ pletFields @'["outputs", "datums"] txInfo'
pure $
pall
# plam
( \txOut'' -> P.do
PTxOut txOut' <- pmatch (pfromData txOut'')
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
PDJust dh <- pmatch txOut.datumHash
( \txOut'' -> unTermCont $ do
PTxOut txOut' <- tcmatch (pfromData txOut'')
txOut <- tcont $ pletFields @'["value", "datumHash", "address"] txOut'
PDJust dh <- tcmatch txOut.datumHash
pure $
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
PJust datum -> P.do
predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
PJust datum -> predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
PNothing -> pcon PFalse
)
# pfromData txInfo.outputs
@ -518,19 +550,20 @@ anyInput ::
) =>
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
anyInput = phoistAcyclic $
plam $ \txInfo' predicate -> P.do
txInfo <- pletFields @'["inputs", "datums"] txInfo'
plam $ \txInfo' predicate -> unTermCont $ do
txInfo <- tcont $ pletFields @'["inputs", "datums"] txInfo'
pure $
pany
# plam
( \txInInfo'' -> P.do
PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'')
( \txInInfo'' -> unTermCont $ do
PTxInInfo txInInfo' <- tcmatch (pfromData txInInfo'')
let txOut'' = pfield @"resolved" # txInInfo'
PTxOut txOut' <- pmatch (pfromData txOut'')
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
PDJust dh <- pmatch txOut.datumHash
PTxOut txOut' <- tcmatch (pfromData txOut'')
txOut <- tcont $ pletFields @'["value", "datumHash", "address"] txOut'
PDJust dh <- tcmatch txOut.datumHash
pure $
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
PJust datum -> P.do
predicate # txOut.value # txOut.address # pfromData datum
PJust datum -> predicate # txOut.value # txOut.address # pfromData datum
PNothing -> pcon PFalse
)
# pfromData txInfo.inputs
@ -563,17 +596,18 @@ scriptHashFromAddress = phoistAcyclic $
-- | 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'
plam $ \outputs address' -> unTermCont $ do
address <- tclet $ pdata address'
pure $
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
plam $ \datums out -> unTermCont $ do
datumHash' <- tcmatch $ pfromData $ pfield @"datumHash" # out
pure $ case datumHash' of
PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums
_ -> pcon PNothing
@ -610,11 +644,11 @@ mustFindDatum' ::
:--> datum
)
mustFindDatum' = phoistAcyclic $
plam $ \mdh datums -> P.do
plam $ \mdh datums -> unTermCont $ do
let dh = mustBePDJust # "Given TxOut dones't have a datum" # mdh
dt = mustBePJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums
(d, _) <- ptryFrom $ pforgetData $ pdata dt
pfromData d
(d, _) <- tcont $ ptryFrom $ pforgetData $ pdata dt
pure $ pfromData d
{- | Extract the value stored in a PMaybe container.
If there's no value, throw an error with the given message.

18
agora/Agora/Utils/Value.hs
View file

@ -3,6 +3,7 @@
module Agora.Utils.Value (pgeq, pleq, pgt, plt) where
import Agora.Utils (tcmatch)
import Plutarch.Api.V1.AssocMap (PMap (PMap))
import Plutarch.Api.V1.These (PTheseData (..))
import Plutarch.Api.V1.Tuple (ptupleFromBuiltin)
@ -26,15 +27,15 @@ punionVal = undefined
pmapAll ::
(PUnsafeLiftDecl v, PIsData v) =>
Term s ((v :--> PBool) :--> PMap k v :--> PBool)
pmapAll = plam $ \f m -> P.do
PMap builtinMap <- pmatch m
pmapAll = plam $ \f m -> unTermCont $ do
PMap builtinMap <- tcmatch m
let getV = plam $ \bip -> P.do
let getV = plam $ \bip ->
let tuple = pfromData $ ptupleFromBuiltin (pdata bip)
pfromData $ pfield @"_1" # tuple
in pfromData $ pfield @"_1" # tuple
let vs = pmap # getV # builtinMap
pall # f # vs
pure $ pall # f # vs
pcheckPred ::
forall {s :: S}.
@ -45,8 +46,7 @@ pcheckPred ::
:--> PValue
:--> PBool
)
pcheckPred = plam $ \_f _l _r -> P.do
undefined
pcheckPred = plam $ \_f _l _r -> undefined
-- let inner :: Term s (PMap PTokenName (PTheseData PInteger PInteger) :--> PBool)
-- inner = pmapAll # f
@ -61,14 +61,14 @@ pcheckBinRel ::
:--> PValue
:--> PBool
)
pcheckBinRel = plam $ \f l r -> P.do
pcheckBinRel = plam $ \f l r ->
let unThese :: Term s (PTheseData PInteger PInteger :--> PBool)
unThese = plam $ \k' ->
pmatch k' $ \case
PDThis r -> f # (pfield @"_0" # r) # 0
PDThat r -> f # 0 # (pfield @"_0" # r)
PDThese r -> f # (pfield @"_0" # r) # (pfield @"_1" # r)
pcheckPred # unThese # l # r
in pcheckPred # unThese # l # r
-- | Establishes if a value is less than or equal to another.
pleq :: Term s (PValue :--> PValue :--> PBool)