Sulkta-Coop/agora
2
0
Fork 0
Code Issues 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 bb45319fd6
No known key found for this signature in database
GPG key ID: 35CD9A71CD5D5870
15 changed files with 1077 additions and 1019 deletions
Download patch file Download diff file Expand all files Collapse all files

120
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.Extra (passetClass, passetClassValueOf)
import Plutarch.Api.V1.Value (PValue (PValue)) import Plutarch.Api.V1.Value (PValue (PValue))
import Plutarch.Builtin (pforgetData) import Plutarch.Builtin (pforgetData)
import Plutarch.Monadic qualified as P
import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
import Prelude import Prelude
@ -35,10 +34,11 @@ import Prelude
import Agora.Utils ( import Agora.Utils (
allOutputs, allOutputs,
passert,
plookup, plookup,
psymbolValueOf, psymbolValueOf,
ptokenSpent, ptokenSpent,
tcassert,
tcmatch,
) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -67,30 +67,32 @@ newtype AuthorityToken = AuthorityToken
-} -}
authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool) authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool)
authorityTokensValidIn = phoistAcyclic $ authorityTokensValidIn = phoistAcyclic $
plam $ \authorityTokenSym txOut'' -> P.do plam $ \authorityTokenSym txOut'' -> unTermCont $ do
PTxOut txOut' <- pmatch txOut'' PTxOut txOut' <- tcmatch txOut''
txOut <- pletFields @'["address", "value"] $ txOut' txOut <- tcont $ pletFields @'["address", "value"] $ txOut'
PAddress address <- pmatch txOut.address PAddress address <- tcmatch txOut.address
PValue value' <- pmatch txOut.value PValue value' <- tcmatch txOut.value
PMap value <- pmatch value' PMap value <- tcmatch value'
pmatch (plookup # pdata authorityTokenSym # value) $ \case pure $
PJust (pfromData -> tokenMap') -> pmatch (plookup # pdata authorityTokenSym # value) $ \case
pmatch (pfield @"credential" # address) $ \case PJust (pfromData -> tokenMap') ->
PPubKeyCredential _ -> pmatch (pfield @"credential" # address) $ \case
-- GATs should only be sent to Effect validators PPubKeyCredential _ ->
ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False -- GATs should only be sent to Effect validators
PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> P.do ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False
PMap tokenMap <- pmatch tokenMap' PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> unTermCont $ do
ptraceIfFalse "authorityTokensValidIn: GAT TokenName doesn't match ScriptHash" $ PMap tokenMap <- tcmatch tokenMap'
pall pure $
# plam ptraceIfFalse "authorityTokensValidIn: GAT TokenName doesn't match ScriptHash" $
( \pair -> pall
pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred) # plam
) ( \pair ->
# tokenMap pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred)
PNothing -> )
-- No GATs exist at this output! # tokenMap
pconstant True PNothing ->
-- No GATs exist at this output!
pconstant True
-- | Assert that a single authority token has been burned. -- | Assert that a single authority token has been burned.
singleAuthorityTokenBurned :: singleAuthorityTokenBurned ::
@ -99,53 +101,55 @@ singleAuthorityTokenBurned ::
Term s (PAsData PTxInfo) -> Term s (PAsData PTxInfo) ->
Term s PValue -> Term s PValue ->
Term s PBool Term s PBool
singleAuthorityTokenBurned gatCs txInfo mint = P.do singleAuthorityTokenBurned gatCs txInfo mint = unTermCont $ do
let gatAmountMinted :: Term _ PInteger let gatAmountMinted :: Term _ PInteger
gatAmountMinted = psymbolValueOf # gatCs # mint gatAmountMinted = psymbolValueOf # gatCs # mint
txInfoF <- pletFields @'["inputs"] $ txInfo txInfoF <- tcont $ pletFields @'["inputs"] $ txInfo
foldr1 pure $
(#&&) foldr1
[ ptraceIfFalse "singleAuthorityTokenBurned: Must burn exactly 1 GAT" $ gatAmountMinted #== -1 (#&&)
, ptraceIfFalse "singleAuthorityTokenBurned: All GAT tokens must be valid at the inputs" $ [ ptraceIfFalse "singleAuthorityTokenBurned: Must burn exactly 1 GAT" $ gatAmountMinted #== -1
pall , ptraceIfFalse "singleAuthorityTokenBurned: All GAT tokens must be valid at the inputs" $
# plam pall
( \txInInfo' -> P.do # plam
PTxInInfo txInInfo <- pmatch (pfromData txInInfo') ( \txInInfo' -> unTermCont $ do
let txOut' = pfield @"resolved" # txInInfo PTxInInfo txInInfo <- tcmatch (pfromData txInInfo')
authorityTokensValidIn # gatCs # pfromData txOut' let txOut' = pfield @"resolved" # txInInfo
) pure $ authorityTokensValidIn # gatCs # pfromData txOut'
# txInfoF.inputs )
] # txInfoF.inputs
]
-- | Policy given 'AuthorityToken' params. -- | Policy given 'AuthorityToken' params.
authorityTokenPolicy :: AuthorityToken -> ClosedTerm PMintingPolicy authorityTokenPolicy :: AuthorityToken -> ClosedTerm PMintingPolicy
authorityTokenPolicy params = authorityTokenPolicy params =
plam $ \_redeemer ctx' -> plam $ \_redeemer ctx' ->
pmatch ctx' $ \(PScriptContext ctx') -> P.do pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do
ctx <- pletFields @'["txInfo", "purpose"] ctx' ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo PTxInfo txInfo' <- tcmatch $ pfromData ctx.txInfo
txInfo <- pletFields @'["inputs", "mint"] txInfo' txInfo <- tcont $ pletFields @'["inputs", "mint"] txInfo'
let inputs = txInfo.inputs let inputs = txInfo.inputs
mintedValue = pfromData txInfo.mint mintedValue = pfromData txInfo.mint
AssetClass (govCs, govTn) = params.authority AssetClass (govCs, govTn) = params.authority
govAc = passetClass # pconstant govCs # pconstant govTn govAc = passetClass # pconstant govCs # pconstant govTn
govTokenSpent = ptokenSpent # govAc # inputs govTokenSpent = ptokenSpent # govAc # inputs
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose PMinting ownSymbol' <- tcmatch $ pfromData ctx.purpose
let ownSymbol = pfromData $ pfield @"_0" # ownSymbol' let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
mintedATs = passetClassValueOf # mintedValue # (passetClass # ownSymbol # pconstant "") mintedATs = passetClassValueOf # mintedValue # (passetClass # ownSymbol # pconstant "")
pif pure $
(0 #< mintedATs) pif
( P.do (0 #< mintedATs)
passert "Parent token did not move in minting GATs" govTokenSpent ( unTermCont $ do
passert "All outputs only emit valid GATs" $ tcassert "Parent token did not move in minting GATs" govTokenSpent
allOutputs @PData # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum -> tcassert "All outputs only emit valid GATs" $
authorityTokensValidIn allOutputs @PData # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
# ownSymbol authorityTokensValidIn
# txOut # ownSymbol
popaque $ pconstant () # txOut
) pure $ popaque $ pconstant ()
(popaque $ pconstant ()) )
(popaque $ pconstant ())

25
agora/Agora/Effect.hs
View file

@ -8,10 +8,9 @@ Helpers for constructing effects.
module Agora.Effect (makeEffect) where module Agora.Effect (makeEffect) where
import Agora.AuthorityToken (singleAuthorityTokenBurned) 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.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
import Plutarch.Monadic qualified as P import Plutarch.TryFrom (PTryFrom)
import Plutarch.TryFrom (PTryFrom, ptryFrom)
import Plutus.V1.Ledger.Value (CurrencySymbol) 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) -> (forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
ClosedTerm PValidator ClosedTerm PValidator
makeEffect gatCs' f = makeEffect gatCs' f =
plam $ \datum _redeemer ctx' -> P.do plam $ \datum _redeemer ctx' -> unTermCont $ do
ctx <- pletFields @'["txInfo", "purpose"] ctx' ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
txInfo' <- plet ctx.txInfo txInfo' <- tclet ctx.txInfo
-- convert input datum, PData, into desierable type -- convert input datum, PData, into desierable type
-- the way this conversion is performed should be defined -- the way this conversion is performed should be defined
-- by PTryFrom for each datum in effect script. -- by PTryFrom for each datum in effect script.
(datum', _) <- ptryFrom @datum datum (datum', _) <- tctryFrom @datum datum
-- ensure purpose is Spending. -- ensure purpose is Spending.
PSpending txOutRef <- pmatch $ pfromData ctx.purpose PSpending txOutRef <- tcmatch $ pfromData ctx.purpose
txOutRef' <- plet (pfield @"_0" # txOutRef) txOutRef' <- tclet (pfield @"_0" # txOutRef)
-- fetch minted values to ensure single GAT is burned -- fetch minted values to ensure single GAT is burned
txInfo <- pletFields @'["mint"] txInfo' txInfo <- tcont $ pletFields @'["mint"] txInfo'
let mint :: Term _ PValue let mint :: Term _ PValue
mint = txInfo.mint mint = txInfo.mint
-- fetch script context -- 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 -- 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. -- | Dummy effect which can only burn its GAT.
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
noOpValidator curr = makeEffect curr $ noOpValidator curr = makeEffect curr $
\_ (_datum :: Term s PNoOp) _ _ -> P.do \_ (_datum :: Term s PNoOp) _ _ -> popaque (pconstant ())
popaque (pconstant ())

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

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

32
agora/Agora/Governor.hs
View file

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

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

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

22
agora/Agora/MultiSig.hs
View file

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

20
agora/Agora/Proposal.hs
View file

@ -54,7 +54,6 @@ import Plutarch.Lift (
PConstantDecl, PConstantDecl,
PUnsafeLiftDecl (..), PUnsafeLiftDecl (..),
) )
import Plutarch.Monadic qualified as P
import Plutarch.SafeMoney (PDiscrete, Tagged) import Plutarch.SafeMoney (PDiscrete, Tagged)
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom')) import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Unsafe (punsafeCoerce)
@ -411,8 +410,8 @@ deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instanc
proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool) proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool)
proposalDatumValid proposal = proposalDatumValid proposal =
phoistAcyclic $ phoistAcyclic $
plam $ \datum' -> P.do plam $ \datum' -> unTermCont $ do
datum <- pletFields @'["effects", "cosigners", "votes"] $ datum' datum <- tcont $ pletFields @'["effects", "cosigners", "votes"] $ datum'
let atLeastOneNegativeResult = let atLeastOneNegativeResult =
pany pany
@ -425,10 +424,11 @@ proposalDatumValid proposal =
#$ pto #$ pto
$ pfromData datum.effects $ pfromData datum.effects
foldr1 pure $
(#&&) 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 at least one ResultTag has no effects" atLeastOneNegativeResult
, ptraceIfFalse "Proposal has fewer cosigners than the limit" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
, ptraceIfFalse "Proposal votes and effects are compatible with each other" $ pkeysEqual # datum.effects # pto (pfromData datum.votes) , 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)
]

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

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

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

@ -28,6 +28,7 @@ module Agora.Proposal.Time (
) where ) where
import Agora.Record (mkRecordConstr, (.&), (.=)) import Agora.Record (mkRecordConstr, (.&), (.=))
import Agora.Utils (tcmatch)
import GHC.Generics qualified as GHC import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I)) import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
@ -39,7 +40,6 @@ import Plutarch.Api.V1 (
PUpperBound (PUpperBound), PUpperBound (PUpperBound),
) )
import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..)) import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
import Plutarch.Monadic qualified as P
import Plutarch.Numeric (AdditiveSemigroup ((+))) import Plutarch.Numeric (AdditiveSemigroup ((+)))
import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Unsafe (punsafeCoerce)
import Plutus.V1.Ledger.Time (POSIXTime) import Plutus.V1.Ledger.Time (POSIXTime)
@ -159,28 +159,29 @@ instance AdditiveSemigroup (Term s PPOSIXTime) where
-} -}
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime) currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
currentProposalTime = phoistAcyclic $ currentProposalTime = phoistAcyclic $
plam $ \iv -> P.do plam $ \iv -> unTermCont $ do
PInterval iv' <- pmatch iv PInterval iv' <- tcmatch iv
ivf <- pletFields @'["from", "to"] iv' ivf <- tcont $ pletFields @'["from", "to"] iv'
PLowerBound lb <- pmatch ivf.from PLowerBound lb <- tcmatch ivf.from
PUpperBound ub <- pmatch ivf.to PUpperBound ub <- tcmatch ivf.to
lbf <- pletFields @'["_0", "_1"] lb lbf <- tcont $ pletFields @'["_0", "_1"] lb
ubf <- pletFields @'["_0", "_1"] ub ubf <- tcont $ pletFields @'["_0", "_1"] ub
mkRecordConstr PProposalTime $ pure $
#lowerBound mkRecordConstr PProposalTime $
.= pmatch #lowerBound
lbf._0 .= pmatch
( \case lbf._0
PFinite ((pfield @"_0" #) -> d) -> d ( \case
_ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time." PFinite ((pfield @"_0" #) -> d) -> d
) _ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
.& #upperBound )
.= pmatch .& #upperBound
ubf._0 .= pmatch
( \case ubf._0
PFinite ((pfield @"_0" #) -> d) -> d ( \case
_ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time." PFinite ((pfield @"_0" #) -> d) -> d
) _ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
)
-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive. -- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
proposalTimeWithin :: proposalTimeWithin ::
@ -192,14 +193,15 @@ proposalTimeWithin ::
:--> PBool :--> PBool
) )
proposalTimeWithin = phoistAcyclic $ proposalTimeWithin = phoistAcyclic $
plam $ \l h proposalTime' -> P.do plam $ \l h proposalTime' -> unTermCont $ do
PProposalTime proposalTime <- pmatch proposalTime' PProposalTime proposalTime <- tcmatch proposalTime'
ptf <- pletFields @'["lowerBound", "upperBound"] proposalTime ptf <- tcont $ pletFields @'["lowerBound", "upperBound"] proposalTime
foldr1 pure $
(#&&) foldr1
[ l #<= pfromData ptf.lowerBound (#&&)
, pfromData ptf.upperBound #<= h [ l #<= pfromData ptf.lowerBound
] , pfromData ptf.upperBound #<= h
]
-- | True if the 'PProposalTime' is in the draft period. -- | True if the 'PProposalTime' is in the draft period.
isDraftPeriod :: isDraftPeriod ::

53
agora/Agora/Stake.hs
View file

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

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

@ -13,7 +13,6 @@ import Agora.Utils (
anyInput, anyInput,
anyOutput, anyOutput,
paddValue, paddValue,
passert,
pfindTxInByTxOutRef, pfindTxInByTxOutRef,
pgeqByClass, pgeqByClass,
pgeqByClass', pgeqByClass',
@ -24,6 +23,10 @@ import Agora.Utils (
ptxSignedBy, ptxSignedBy,
pvalidatorHashToTokenName, pvalidatorHashToTokenName,
pvalueSpent, pvalueSpent,
tcassert,
tclet,
tcmatch,
tctryFrom,
) )
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PCredential (PPubKeyCredential, PScriptCredential), PCredential (PPubKeyCredential, PScriptCredential),
@ -37,14 +40,12 @@ import Plutarch.Api.V1 (
) )
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
import Plutarch.Internal (punsafeCoerce) import Plutarch.Internal (punsafeCoerce)
import Plutarch.Monadic qualified as P
import Plutarch.Numeric import Plutarch.Numeric
import Plutarch.SafeMoney ( import Plutarch.SafeMoney (
Tagged (..), Tagged (..),
pdiscreteValue', pdiscreteValue',
untag, untag,
) )
import Plutarch.TryFrom (ptryFrom)
import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
import Prelude hiding (Num (..)) import Prelude hiding (Num (..))
@ -70,93 +71,92 @@ stakePolicy ::
Tagged GTTag AssetClass -> Tagged GTTag AssetClass ->
ClosedTerm PMintingPolicy ClosedTerm PMintingPolicy
stakePolicy gtClassRef = stakePolicy gtClassRef =
plam $ \_redeemer ctx' -> P.do plam $ \_redeemer ctx' -> unTermCont $ do
ctx <- pletFields @'["txInfo", "purpose"] ctx' ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
txInfo <- plet $ ctx.txInfo txInfo <- tclet $ ctx.txInfo
let _a :: Term _ PTxInfo let _a :: Term _ PTxInfo
_a = txInfo _a = txInfo
txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose PMinting ownSymbol' <- tcmatch $ pfromData ctx.purpose
ownSymbol <- plet $ pfield @"_0" # ownSymbol' ownSymbol <- tclet $ pfield @"_0" # ownSymbol'
spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs spentST <- tclet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs
mintedST <- plet $ psymbolValueOf # ownSymbol # txInfoF.mint mintedST <- tclet $ psymbolValueOf # ownSymbol # txInfoF.mint
let burning = P.do let burning = unTermCont $ do
passert "ST at inputs must be 1" $ tcassert "ST at inputs must be 1" $
spentST #== 1 spentST #== 1
passert "ST burned" $ tcassert "ST burned" $
mintedST #== -1 mintedST #== -1
passert "An unlocked input existed containing an ST" $ tcassert "An unlocked input existed containing an ST" $
anyInput @PStakeDatum # txInfo anyInput @PStakeDatum # txInfo
#$ plam #$ plam
$ \value _ stakeDatum' -> P.do $ \value _ stakeDatum' ->
let hasST = psymbolValueOf # ownSymbol # value #== 1 let hasST = psymbolValueOf # ownSymbol # value #== 1
let unlocked = pnot # (stakeLocked # stakeDatum') unlocked = pnot # (stakeLocked # stakeDatum')
hasST #&& unlocked in hasST #&& unlocked
popaque (pconstant ()) pure $ popaque (pconstant ())
let minting = P.do let minting = unTermCont $ do
passert "ST at inputs must be 0" $ tcassert "ST at inputs must be 0" $
spentST #== 0 spentST #== 0
passert "Minted ST must be exactly 1" $ tcassert "Minted ST must be exactly 1" $
mintedST #== 1 mintedST #== 1
passert "A UTXO must exist with the correct output" $ tcassert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo anyOutput @PStakeDatum # txInfo
#$ plam #$ plam
$ \value address stakeDatum' -> P.do $ \value address stakeDatum' ->
let cred = pfield @"credential" # address let cred = pfield @"credential" # address
pmatch cred $ \case in pmatch cred $ \case
-- Should pay to a script address -- Should pay to a script address
PPubKeyCredential _ -> pcon PFalse PPubKeyCredential _ -> pcon PFalse
PScriptCredential validatorHash -> P.do PScriptCredential validatorHash -> unTermCont $ do
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' 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 = let stValue =
psingletonValue 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 # ownSymbol
-- This coerce is safe because the structure
-- of PValidatorHash is the same as PTokenName.
# tn # tn
# value # 1
# expectedValue let expectedValue =
] paddValue
# (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount)
# stValue
let ownerSignsTransaction =
ptxSignedBy
# txInfoF.signatories
# stakeDatum.owner
ownerSignsTransaction -- TODO: This is quite inefficient now, as it does two lookups
#&& valueCorrect -- instead of a more efficient single pass,
popaque (pconstant ()) -- 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
]
pif (0 #< mintedST) minting burning pure $ ownerSignsTransaction #&& valueCorrect
pure $ popaque (pconstant ())
pure $ pif (0 #< mintedST) minting burning
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -212,194 +212,196 @@ this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
-} -}
stakeValidator :: Stake -> ClosedTerm PValidator stakeValidator :: Stake -> ClosedTerm PValidator
stakeValidator stake = stakeValidator stake =
plam $ \datum redeemer ctx' -> P.do plam $ \datum redeemer ctx' -> unTermCont $ do
ctx <- pletFields @'["txInfo", "purpose"] ctx' ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
txInfo <- plet $ pfromData ctx.txInfo txInfo <- tclet $ pfromData ctx.txInfo
txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
(pfromData -> stakeRedeemer, _) <- ptryFrom redeemer (pfromData -> stakeRedeemer, _) <- tctryFrom redeemer
-- TODO: Use PTryFrom -- TODO: Use PTryFrom
let stakeDatum' :: Term _ PStakeDatum let stakeDatum' :: Term _ PStakeDatum
stakeDatum' = pfromData $ punsafeCoerce datum 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 PJust txInInfo <- tcmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo ownAddress <- tclet $ pfield @"address" #$ pfield @"resolved" # txInInfo
let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
-- Whether the owner signs this transaction or not. -- 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) stCurrencySymbol <- tclet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint mintedST <- tclet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
valueSpent <- plet $ pvalueSpent # txInfoF.inputs valueSpent <- tclet $ pvalueSpent # txInfoF.inputs
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent spentST <- tclet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
let AssetClass (propCs, propTn) = stake.proposalSTClass let AssetClass (propCs, propTn) = stake.proposalSTClass
proposalSTClass = passetClass # pconstant propCs # pconstant propTn proposalSTClass = passetClass # pconstant propCs # pconstant propTn
spentProposalST <- plet $ passetClassValueOf # valueSpent # proposalSTClass spentProposalST <- tclet $ passetClassValueOf # valueSpent # proposalSTClass
-- Is the stake currently locked? -- Is the stake currently locked?
stakeIsLocked <- plet $ stakeLocked # stakeDatum' stakeIsLocked <- tclet $ stakeLocked # stakeDatum'
pmatch stakeRedeemer $ \case pure $
PDestroy _ -> P.do pmatch stakeRedeemer $ \case
passert "ST at inputs must be 1" $ PDestroy _ -> unTermCont $ do
spentST #== 1 tcassert "ST at inputs must be 1" $
spentST #== 1
passert "Should burn ST" $ tcassert "Should burn ST" $
mintedST #== -1 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 PRetractVotes _ -> unTermCont $ do
passert tcassert
"Owner signs this transaction" "Owner signs this transaction"
ownerSignsTransaction ownerSignsTransaction
passert "ST at inputs must be 1" $ tcassert "ST at inputs must be 1" $
spentST #== 1 spentST #== 1
-- This puts trust into the Proposal. The Proposal must necessarily check -- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused. -- that this is not abused.
passert "Proposal ST spent" $ tcassert "Proposal ST spent" $
spentProposalST #== 1 spentProposalST #== 1
passert "A UTXO must exist with the correct output" $ tcassert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo anyOutput @PStakeDatum # txInfo
#$ plam #$ plam
$ \value address newStakeDatum' -> P.do $ \value address newStakeDatum' ->
let isScriptAddress = pdata address #== ownAddress let isScriptAddress = pdata address #== ownAddress
let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
let valueCorrect = pdata continuingValue #== pdata value valueCorrect = pdata continuingValue #== pdata value
pif in pif
isScriptAddress isScriptAddress
( foldl1 ( foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
]
)
(pcon PFalse)
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
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.
tcassert "Proposal ST spent" $
spentProposalST #== 1
tcassert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo
#$ plam
$ \value address newStakeDatum' ->
let isScriptAddress = pdata address #== ownAddress
_correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
valueCorrect = pdata continuingValue #== pdata value
in pif
isScriptAddress
( foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
]
)
(pcon PFalse)
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PWitnessStake _ -> unTermCont $ do
tcassert "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.
tcassert
"Owner signs this transaction OR proposal token is spent"
(ownerSignsTransaction #|| proposalTokenMoved)
tcassert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo
#$ plam
$ \value address newStakeDatum' ->
let isScriptAddress = pdata address #== ownAddress
correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
valueCorrect = pdata continuingValue #== pdata value
in pif
isScriptAddress
( foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
]
)
(pcon PFalse)
pure $ popaque (pconstant ())
PDepositWithdraw r -> unTermCont $ do
tcassert "ST at inputs must be 1" $
spentST #== 1
tcassert "Stake unlocked" $
pnot #$ stakeIsLocked
tcassert
"Owner signs this transaction"
ownerSignsTransaction
tcassert "A UTXO must exist with the correct output" $
anyOutput @PStakeDatum # txInfo
#$ plam
$ \value address newStakeDatum' -> unTermCont $ do
newStakeDatum <- tcont $ pletFields @'["owner", "stakedAmount"] newStakeDatum'
delta <- tclet $ 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
]
pure $
foldr1
(#&&) (#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect [ ptraceIfFalse "isScriptAddress" isScriptAddress
]
)
(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 , ptraceIfFalse "correctOutputDatum" correctOutputDatum
, ptraceIfFalse "valueCorrect" valueCorrect
] ]
)
(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 pure $ popaque (pconstant ())
-- 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 ())

25
agora/Agora/Treasury.hs
View file

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

332
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. Plutarch utility functions that should be upstreamed or don't belong anywhere else.
-} -}
module Agora.Utils ( module Agora.Utils (
-- * TermCont-based combinators. Some of these will live in plutarch eventually.
tcassert,
tclet,
tcmatch,
tctryFrom,
-- * Validator-level utility functions -- * Validator-level utility functions
passert,
pfind', pfind',
pfindDatum, pfindDatum,
ptryFindDatum, ptryFindDatum,
@ -92,16 +97,42 @@ import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf)
import Plutarch.Api.V1.Value (PValue (PValue)) import Plutarch.Api.V1.Value (PValue (PValue))
import Plutarch.Builtin (pforgetData, ppairDataBuiltin) import Plutarch.Builtin (pforgetData, ppairDataBuiltin)
import Plutarch.Map.Extra (pkeys) import Plutarch.Map.Extra (pkeys)
import Plutarch.Monadic qualified as P import Plutarch.Reducible (Reducible (Reduce))
import Plutarch.TryFrom (PTryFrom, ptryFrom) 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 -- 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. -- | Find a datum with the given hash.
pfindDatum :: Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe PDatum) pfindDatum :: Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe PDatum)
pfindDatum = phoistAcyclic $ pfindDatum = phoistAcyclic $
@ -113,9 +144,9 @@ ptryFindDatum = phoistAcyclic $
plam $ \datumHash inputs -> plam $ \datumHash inputs ->
pmatch (pfindDatum # datumHash # inputs) $ \case pmatch (pfindDatum # datumHash # inputs) $ \case
PNothing -> pcon PNothing PNothing -> pcon PNothing
PJust datum -> P.do PJust datum -> unTermCont $ do
(datum', _) <- ptryFrom (pto datum) (datum', _) <- tctryFrom (pto datum)
pcon (PJust datum') pure $ pcon (PJust datum')
-- | Check if a PubKeyHash signs this transaction. -- | Check if a PubKeyHash signs this transaction.
ptxSignedBy :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PAsData PPubKeyHash :--> PBool) 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 _. -- | Yield True if a given PMaybe is of form PJust _.
pisJust :: forall a s. Term s (PMaybe a :--> PBool) pisJust :: forall a s. Term s (PMaybe a :--> PBool)
pisJust = phoistAcyclic $ pisJust = phoistAcyclic $
plam $ \v' -> P.do plam $ \v' ->
v <- pmatch v' pmatch v' $ \case
case v of
PJust _ -> pconstant True PJust _ -> pconstant True
PNothing -> pconstant False 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. -- | Get the sum of all values belonging to a particular CurrencySymbol.
psymbolValueOf :: Term s (PCurrencySymbol :--> PValue :--> PInteger) psymbolValueOf :: Term s (PCurrencySymbol :--> PValue :--> PInteger)
psymbolValueOf = psymbolValueOf =
phoistAcyclic $ phoistAcyclic $
plam $ \sym value'' -> P.do plam $ \sym value'' -> unTermCont $ do
PValue value' <- pmatch value'' PValue value' <- tcmatch value''
PMap value <- pmatch value' PMap value <- tcmatch value'
m' <- pexpectJust 0 (plookup # pdata sym # value) m' <- tcexpectJust 0 (plookup # pdata sym # value)
PMap m <- pmatch (pfromData m') PMap m <- tcmatch (pfromData m')
pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m pure $ pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m
-- | Extract amount from PValue belonging to a Haskell-level AssetClass. -- | Extract amount from PValue belonging to a Haskell-level AssetClass.
passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger)
@ -240,19 +258,20 @@ pgeqByClass' ac =
pmapUnionWith :: forall k v s. PIsData v => Term s ((v :--> v :--> v) :--> PMap k v :--> PMap k v :--> PMap k v) pmapUnionWith :: forall k v s. PIsData v => Term s ((v :--> v :--> v) :--> PMap k v :--> PMap k v :--> PMap k v)
pmapUnionWith = phoistAcyclic $ pmapUnionWith = phoistAcyclic $
-- TODO: this function is kinda suspect. I feel like a lot of optimizations could be done here -- TODO: this function is kinda suspect. I feel like a lot of optimizations could be done here
plam $ \f xs' ys' -> P.do plam $ \f xs' ys' -> unTermCont $ do
PMap xs <- pmatch xs' PMap xs <- tcmatch xs'
PMap ys <- pmatch ys' PMap ys <- tcmatch ys'
let ls = let ls =
pmap pmap
# plam # plam
( \p -> P.do ( \p -> unTermCont $ do
pf <- plet $ pfstBuiltin # p pf <- tclet $ pfstBuiltin # p
pmatch (plookup # pf # ys) $ \case pure $
PJust v -> pmatch (plookup # pf # ys) $ \case
-- Data conversions here are silly, aren't they? PJust v ->
ppairDataBuiltin # pf # pdata (f # pfromData (psndBuiltin # p) # pfromData v) -- Data conversions here are silly, aren't they?
PNothing -> p ppairDataBuiltin # pf # pdata (f # pfromData (psndBuiltin # p) # pfromData v)
PNothing -> p
) )
# xs # xs
rs = rs =
@ -262,18 +281,19 @@ pmapUnionWith = phoistAcyclic $
pnot #$ pany # plam (\p' -> pfstBuiltin # p' #== pfstBuiltin # p) # xs pnot #$ pany # plam (\p' -> pfstBuiltin # p' #== pfstBuiltin # p) # xs
) )
# ys # ys
pcon (PMap $ pconcat # ls # rs) pure $ pcon (PMap $ pconcat # ls # rs)
-- | Add two 'PValue's together. -- | Add two 'PValue's together.
paddValue :: forall s. Term s (PValue :--> PValue :--> PValue) paddValue :: forall s. Term s (PValue :--> PValue :--> PValue)
paddValue = phoistAcyclic $ paddValue = phoistAcyclic $
plam $ \a' b' -> P.do plam $ \a' b' -> unTermCont $ do
PValue a <- pmatch a' PValue a <- tcmatch a'
PValue b <- pmatch b' PValue b <- tcmatch b'
pcon pure $
( PValue $ pcon
pmapUnionWith # plam (\a' b' -> pmapUnionWith # plam (+) # a' # b') # a # b ( PValue $
) pmapUnionWith # plam (\a' b' -> pmapUnionWith # plam (+) # a' # b') # a # b
)
-- | Sum of all value at input. -- | Sum of all value at input.
pvalueSpent :: Term s (PBuiltinList (PAsData PTxInInfo) :--> PValue) pvalueSpent :: Term s (PBuiltinList (PAsData PTxInInfo) :--> PValue)
@ -325,12 +345,12 @@ ptokenSpent =
0 0
#< pfoldr @PBuiltinList #< pfoldr @PBuiltinList
# plam # plam
( \txInInfo' acc -> P.do ( \txInInfo' acc -> unTermCont $ do
PTxInInfo txInInfo <- pmatch (pfromData txInInfo') PTxInInfo txInInfo <- tcmatch (pfromData txInInfo')
PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo PTxOut txOut' <- tcmatch $ pfromData $ pfield @"resolved" # txInInfo
txOut <- pletFields @'["value"] txOut' txOut <- tcont $ pletFields @'["value"] txOut'
let txOutValue = pfromData txOut.value let txOutValue = pfromData txOut.value
acc + passetClassValueOf # txOutValue # tokenClass pure $ acc + passetClassValueOf # txOutValue # tokenClass
) )
# 0 # 0
# inputs # inputs
@ -340,40 +360,45 @@ ptokenSpent =
-} -}
pkeysEqual :: (POrd k, PIsData k) => forall (s :: S) a b. Term s (PMap k a :--> PMap k b :--> PBool) pkeysEqual :: (POrd k, PIsData k) => forall (s :: S) a b. Term s (PMap k a :--> PMap k b :--> PBool)
pkeysEqual = phoistAcyclic $ pkeysEqual = phoistAcyclic $
plam $ \p q -> P.do plam $ \p q -> unTermCont $ do
pks <- plet $ pkeys # p pks <- tclet $ pkeys # p
qks <- plet $ pkeys # q qks <- tclet $ pkeys # q
pif pure $
(plength # pks #== plength # qks) pif
( P.do (plength # pks #== plength # qks)
let comp = phoistAcyclic $ plam $ \(pfromData -> x) (pfromData -> y) -> x #< y ( unTermCont $ do
spks = pmsort # comp # pks let comp = phoistAcyclic $ plam $ \(pfromData -> x) (pfromData -> y) -> x #< y
sqks = pmsort # comp # qks spks = pmsort # comp # pks
sqks = pmsort # comp # qks
plistEquals # spks # sqks pure $ plistEquals # spks # sqks
) )
(pcon PFalse) (pcon PFalse)
-- | / O(nlogn) /. Clear out duplicates in a list. The order is not preserved. -- | / 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 :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s ((a :--> a :--> PBool) :--> list a :--> list a)
pnub = phoistAcyclic $ pnub = phoistAcyclic $
plam $ \comp xs -> P.do plam $ \comp xs -> unTermCont $ do
sorted <- plet $ pmsort # comp # xs sorted <- tclet $ pmsort # comp # xs
pnubOrd # comp # sorted pure $ pnubOrd # comp # sorted
where where
pnubOrd = phoistAcyclic $ pfix #$ plam pnubOrd' pnubOrd = phoistAcyclic $ pfix #$ plam pnubOrd'
pnubOrd' self comp xs = pnubOrd' self comp xs =
pif (pnull # xs) pnil $ P.do pif (pnull # xs) pnil $
xh <- plet $ phead # xs unTermCont $ do
xt <- plet $ ptail # xs xh <- tclet $ phead # xs
xt <- tclet $ ptail # xs
pif (pnull # xt) xs $ P.do pure $
xh' <- plet $ phead # xt pif (pnull # xt) xs $
pif unTermCont $ do
(xh #== xh') xh' <- tclet $ phead # xt
(self # comp # xt) pure $
(pcons # xh #$ self # comp # xt) pif
(xh #== xh')
(self # comp # xt)
(pcons # xh #$ self # comp # xt)
-- | / O(nlogn) /. Check if a list contains no duplicates. -- | / O(nlogn) /. Check if a list contains no duplicates.
pisUniq :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s ((a :--> a :--> PBool) :--> list a :--> PBool) pisUniq :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s ((a :--> a :--> PBool) :--> list a :--> PBool)
@ -410,16 +435,18 @@ pmerge = phoistAcyclic $ pfix #$ plam pmerge'
where where
pmerge' self comp a b = pmerge' self comp a b =
pif (pnull # a) b $ pif (pnull # a) b $
pif (pnull # b) a $ P.do pif (pnull # b) a $
ah <- plet $ phead # a unTermCont $ do
at <- plet $ ptail # a ah <- tclet $ phead # a
bh <- plet $ phead # b at <- tclet $ ptail # a
bt <- plet $ ptail # b bh <- tclet $ phead # b
bt <- tclet $ ptail # b
pif pure $
(comp # ah # bh) pif
(pcons # ah #$ self # comp # at # b) (comp # ah # bh)
(pcons # bh #$ self # comp # at # bt) (pcons # ah #$ self # comp # at # b)
(pcons # bh #$ self # comp # at # bt)
-- | / O(nlogn) /. Merge sort, bottom-up version. -- | / O(nlogn) /. Merge sort, bottom-up version.
pmsort :: (PIsListLike l a) => Term s ((a :--> a :--> PBool) :--> l a :--> l a) pmsort :: (PIsListLike l a) => Term s ((a :--> a :--> PBool) :--> l a :--> l a)
@ -447,16 +474,19 @@ phalve = phoistAcyclic $ plam $ \l -> go # l # l
pif pif
(pnull # ys) (pnull # ys)
(pcon $ PPair pnil xs) (pcon $ PPair pnil xs)
( P.do ( unTermCont $ do
yt <- plet $ ptail # ys yt <- tclet $ ptail # ys
xh <- plet $ phead # xs xh <- tclet $ phead # xs
xt <- plet $ ptail # xs xt <- tclet $ ptail # xs
pif (pnull # yt) (pcon $ PPair (psingleton # xh) xt) $ P.do pure $
yt' <- plet $ ptail # yt pif (pnull # yt) (pcon $ PPair (psingleton # xh) xt) $
pmatch (self # xt # yt') $ \(PPair first last) -> unTermCont $ do
pcon $ PPair (pcons # xh # first) last yt' <- tclet $ ptail # yt
pure $
pmatch (self # xt # yt') $ \(PPair first last) ->
pcon $ PPair (pcons # xh # first) last
) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -472,20 +502,21 @@ anyOutput ::
) => ) =>
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
anyOutput = phoistAcyclic $ anyOutput = phoistAcyclic $
plam $ \txInfo' predicate -> P.do plam $ \txInfo' predicate -> unTermCont $ do
txInfo <- pletFields @'["outputs", "datums"] txInfo' txInfo <- tcont $ pletFields @'["outputs", "datums"] txInfo'
pany pure $
# plam pany
( \txOut'' -> P.do # plam
PTxOut txOut' <- pmatch (pfromData txOut'') ( \txOut'' -> unTermCont $ do
txOut <- pletFields @'["value", "datumHash", "address"] txOut' PTxOut txOut' <- tcmatch (pfromData txOut'')
PDJust dh <- pmatch txOut.datumHash txOut <- tcont $ pletFields @'["value", "datumHash", "address"] txOut'
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case PDJust dh <- tcmatch txOut.datumHash
PJust datum -> P.do pure $
predicate # txOut.value # txOut.address # pfromData datum pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
PNothing -> pcon PFalse PJust datum -> predicate # txOut.value # txOut.address # pfromData datum
) PNothing -> pcon PFalse
# pfromData txInfo.outputs )
# pfromData txInfo.outputs
-- | Check if all outputs match the predicate. -- | Check if all outputs match the predicate.
allOutputs :: allOutputs ::
@ -495,20 +526,21 @@ allOutputs ::
) => ) =>
Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool) Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
allOutputs = phoistAcyclic $ allOutputs = phoistAcyclic $
plam $ \txInfo' predicate -> P.do plam $ \txInfo' predicate -> unTermCont $ do
txInfo <- pletFields @'["outputs", "datums"] txInfo' txInfo <- tcont $ pletFields @'["outputs", "datums"] txInfo'
pall pure $
# plam pall
( \txOut'' -> P.do # plam
PTxOut txOut' <- pmatch (pfromData txOut'') ( \txOut'' -> unTermCont $ do
txOut <- pletFields @'["value", "datumHash", "address"] txOut' PTxOut txOut' <- tcmatch (pfromData txOut'')
PDJust dh <- pmatch txOut.datumHash txOut <- tcont $ pletFields @'["value", "datumHash", "address"] txOut'
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case PDJust dh <- tcmatch txOut.datumHash
PJust datum -> P.do pure $
predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
PNothing -> pcon PFalse PJust datum -> predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
) PNothing -> pcon PFalse
# pfromData txInfo.outputs )
# pfromData txInfo.outputs
-- | Check if any (resolved) input matches the predicate. -- | Check if any (resolved) input matches the predicate.
anyInput :: anyInput ::
@ -518,22 +550,23 @@ anyInput ::
) => ) =>
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
anyInput = phoistAcyclic $ anyInput = phoistAcyclic $
plam $ \txInfo' predicate -> P.do plam $ \txInfo' predicate -> unTermCont $ do
txInfo <- pletFields @'["inputs", "datums"] txInfo' txInfo <- tcont $ pletFields @'["inputs", "datums"] txInfo'
pany pure $
# plam pany
( \txInInfo'' -> P.do # plam
PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'') ( \txInInfo'' -> unTermCont $ do
let txOut'' = pfield @"resolved" # txInInfo' PTxInInfo txInInfo' <- tcmatch (pfromData txInInfo'')
PTxOut txOut' <- pmatch (pfromData txOut'') let txOut'' = pfield @"resolved" # txInInfo'
txOut <- pletFields @'["value", "datumHash", "address"] txOut' PTxOut txOut' <- tcmatch (pfromData txOut'')
PDJust dh <- pmatch txOut.datumHash txOut <- tcont $ pletFields @'["value", "datumHash", "address"] txOut'
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case PDJust dh <- tcmatch txOut.datumHash
PJust datum -> P.do pure $
predicate # txOut.value # txOut.address # pfromData datum pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
PNothing -> pcon PFalse PJust datum -> predicate # txOut.value # txOut.address # pfromData datum
) PNothing -> pcon PFalse
# pfromData txInfo.inputs )
# pfromData txInfo.inputs
-- | Create a value with a single asset class. -- | Create a value with a single asset class.
psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue)
@ -563,17 +596,18 @@ scriptHashFromAddress = phoistAcyclic $
-- | Find all TxOuts sent to an Address -- | Find all TxOuts sent to an Address
findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut)) findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut))
findOutputsToAddress = phoistAcyclic $ findOutputsToAddress = phoistAcyclic $
plam $ \outputs address' -> P.do plam $ \outputs address' -> unTermCont $ do
address <- plet $ pdata address' address <- tclet $ pdata address'
pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address) pure $
# outputs pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address)
# outputs
-- | Find the data corresponding to a TxOut, if there is one -- | Find the data corresponding to a TxOut, if there is one
findTxOutDatum :: Term s (PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PTxOut :--> PMaybe PDatum) findTxOutDatum :: Term s (PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PTxOut :--> PMaybe PDatum)
findTxOutDatum = phoistAcyclic $ findTxOutDatum = phoistAcyclic $
plam $ \datums out -> P.do plam $ \datums out -> unTermCont $ do
datumHash' <- pmatch $ pfromData $ pfield @"datumHash" # out datumHash' <- tcmatch $ pfromData $ pfield @"datumHash" # out
case datumHash' of pure $ case datumHash' of
PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums
_ -> pcon PNothing _ -> pcon PNothing
@ -610,11 +644,11 @@ mustFindDatum' ::
:--> datum :--> datum
) )
mustFindDatum' = phoistAcyclic $ mustFindDatum' = phoistAcyclic $
plam $ \mdh datums -> P.do plam $ \mdh datums -> unTermCont $ do
let dh = mustBePDJust # "Given TxOut dones't have a datum" # mdh let dh = mustBePDJust # "Given TxOut dones't have a datum" # mdh
dt = mustBePJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums dt = mustBePJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums
(d, _) <- ptryFrom $ pforgetData $ pdata dt (d, _) <- tcont $ ptryFrom $ pforgetData $ pdata dt
pfromData d pure $ pfromData d
{- | Extract the value stored in a PMaybe container. {- | Extract the value stored in a PMaybe container.
If there's no value, throw an error with the given message. 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 module Agora.Utils.Value (pgeq, pleq, pgt, plt) where
import Agora.Utils (tcmatch)
import Plutarch.Api.V1.AssocMap (PMap (PMap)) import Plutarch.Api.V1.AssocMap (PMap (PMap))
import Plutarch.Api.V1.These (PTheseData (..)) import Plutarch.Api.V1.These (PTheseData (..))
import Plutarch.Api.V1.Tuple (ptupleFromBuiltin) import Plutarch.Api.V1.Tuple (ptupleFromBuiltin)
@ -26,15 +27,15 @@ punionVal = undefined
pmapAll :: pmapAll ::
(PUnsafeLiftDecl v, PIsData v) => (PUnsafeLiftDecl v, PIsData v) =>
Term s ((v :--> PBool) :--> PMap k v :--> PBool) Term s ((v :--> PBool) :--> PMap k v :--> PBool)
pmapAll = plam $ \f m -> P.do pmapAll = plam $ \f m -> unTermCont $ do
PMap builtinMap <- pmatch m PMap builtinMap <- tcmatch m
let getV = plam $ \bip -> P.do let getV = plam $ \bip ->
let tuple = pfromData $ ptupleFromBuiltin (pdata bip) let tuple = pfromData $ ptupleFromBuiltin (pdata bip)
pfromData $ pfield @"_1" # tuple in pfromData $ pfield @"_1" # tuple
let vs = pmap # getV # builtinMap let vs = pmap # getV # builtinMap
pall # f # vs pure $ pall # f # vs
pcheckPred :: pcheckPred ::
forall {s :: S}. forall {s :: S}.
@ -45,8 +46,7 @@ pcheckPred ::
:--> PValue :--> PValue
:--> PBool :--> PBool
) )
pcheckPred = plam $ \_f _l _r -> P.do pcheckPred = plam $ \_f _l _r -> undefined
undefined
-- let inner :: Term s (PMap PTokenName (PTheseData PInteger PInteger) :--> PBool) -- let inner :: Term s (PMap PTokenName (PTheseData PInteger PInteger) :--> PBool)
-- inner = pmapAll # f -- inner = pmapAll # f
@ -61,14 +61,14 @@ pcheckBinRel ::
:--> PValue :--> PValue
:--> PBool :--> PBool
) )
pcheckBinRel = plam $ \f l r -> P.do pcheckBinRel = plam $ \f l r ->
let unThese :: Term s (PTheseData PInteger PInteger :--> PBool) let unThese :: Term s (PTheseData PInteger PInteger :--> PBool)
unThese = plam $ \k' -> unThese = plam $ \k' ->
pmatch k' $ \case pmatch k' $ \case
PDThis r -> f # (pfield @"_0" # r) # 0 PDThis r -> f # (pfield @"_0" # r) # 0
PDThat r -> f # 0 # (pfield @"_0" # r) PDThat r -> f # 0 # (pfield @"_0" # r)
PDThese r -> f # (pfield @"_0" # r) # (pfield @"_1" # 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. -- | Establishes if a value is less than or equal to another.
pleq :: Term s (PValue :--> PValue :--> PBool) pleq :: Term s (PValue :--> PValue :--> PBool)