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

Merge pull request #75 from Liqwid-Labs/emiflake/drop-pdo

Browse source 
remove all instances of `P.do` in favour of `TermCont`.
This commit is contained in:
Emily 2022-05-12 14:12:02 +02:00 • committed by GitHub
commit cdd3f07442
14 changed files with 671 additions and 639 deletions
Download patch file Download diff file Expand all files Collapse all files

121
agora/Agora/AuthorityToken.hs
View file

@ -24,7 +24,6 @@ import Plutarch.Api.V1 (
import Plutarch.Api.V1.AssocMap (PMap (PMap)) import Plutarch.Api.V1.AssocMap (PMap (PMap))
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
@ -33,10 +32,11 @@ import Prelude
import Agora.Utils ( import Agora.Utils (
allOutputs, allOutputs,
passert,
plookup, plookup,
psymbolValueOf, psymbolValueOf,
ptokenSpent, ptokenSpent,
tcassert,
tcmatch,
) )
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
@ -66,30 +66,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 ::
@ -98,25 +100,26 @@ 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 :: authorityTokenPolicy ::
@ -124,29 +127,31 @@ authorityTokenPolicy ::
Term s (PData :--> PScriptContext :--> PUnit) Term s (PData :--> PScriptContext :--> PUnit)
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
pconstant () # txOut
)
(pconstant ()) pure $ pconstant ()
)
(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 ()

6
agora/Agora/Governor.hs
View file

@ -58,11 +58,9 @@ data Governor
-- | Policy for Governors. -- | Policy for Governors.
governorPolicy :: Governor -> ClosedTerm PMintingPolicy governorPolicy :: Governor -> ClosedTerm PMintingPolicy
governorPolicy _ = governorPolicy _ =
plam $ \_redeemer _ctx' -> P.do plam $ \_redeemer _ctx' -> popaque (pconstant ())
popaque (pconstant ())
-- | Validator for Governors. -- | Validator for Governors.
governorValidator :: Governor -> ClosedTerm PValidator governorValidator :: Governor -> ClosedTerm PValidator
governorValidator _ = governorValidator _ =
plam $ \_datum _redeemer _ctx' -> P.do plam $ \_datum _redeemer _ctx' -> popaque (pconstant ())
popaque (pconstant ())

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

@ -55,7 +55,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)
@ -412,8 +411,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 effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)) let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash))
effects = effects =
@ -427,10 +426,11 @@ proposalDatumValid proposal =
atLeastOneNegativeResult = atLeastOneNegativeResult =
pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # 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)
]

204
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.
@ -60,32 +61,32 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
-} -}
proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
proposalPolicy proposal = proposalPolicy proposal =
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
AssetClass (govCs, govTn) = proposal.governorSTAssetClass AssetClass (govCs, govTn) = proposal.governorSTAssetClass
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.
@ -115,114 +116,113 @@ 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) pconstant $ getMintingPolicySymbol (proposalPolicy proposal)
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 # newSigs pisUniq # 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 ()

245
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,
@ -80,16 +85,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 (ppairDataBuiltin) import Plutarch.Builtin (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 $
@ -101,9 +132,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)
@ -169,34 +200,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)
@ -228,19 +246,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 =
@ -250,18 +269,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)
@ -313,12 +333,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
@ -328,11 +348,12 @@ ptokenSpent =
-} -}
pkeysEqual :: forall (s :: S) k a b. Term s (PMap k a :--> PMap k b :--> PBool) pkeysEqual :: forall (s :: S) k 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
pall # plam (\pk -> pelem # pk # qks) # pks pure $
#&& pall # plam (\qk -> pelem # qk # pks) # qks pall # plam (\pk -> pelem # pk # qks) # pks
#&& pall # plam (\qk -> pelem # qk # pks) # qks
-- | / O(n^2) /. Clear out duplicates in a list. The order is not preserved. -- | / O(n^2) /. Clear out duplicates in a list. The order is not preserved.
pnub :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> list a) pnub :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> list a)
@ -371,20 +392,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 ::
@ -394,20 +416,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 ::
@ -417,22 +440,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)
@ -462,17 +486,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

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)