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

Use liqwid-script-export

Browse source 
commit ec70bfd539fe2e27fd48f5f76395400287ac72d7
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Tue Oct 18 18:58:59 2022 -0500

    use LSE

commit 25fff9b3ad1f2dde4cd7cf36977530b06a87d23c
Merge: 01cd3aa 1821dd6
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Tue Oct 18 18:17:45 2022 -0500

    Merge branch 'staging' into seungheonoh/ply

commit 01cd3aa7a235e6fe6658246ca1026fa26dc71a83
Author: Hongrui Fang <chfanghr@gmail.com>
Date:   Tue Oct 11 12:02:03 2022 +0800

    update benchmark

commit a8513244892ce33cfdc9edf8cd501c4985ae8008
Author: Hongrui Fang <chfanghr@gmail.com>
Date:   Tue Oct 11 11:59:22 2022 +0800

    fix tests

commit 20ca40823485c2e2f78253643cf4453ac7b7ddd5
Author: Hongrui Fang <chfanghr@gmail.com>
Date:   Tue Oct 11 11:57:37 2022 +0800

    better import

commit a19fe49424210891bd03db71e4083fc1e0edfd98
Author: Hongrui Fang <chfanghr@gmail.com>
Date:   Tue Oct 11 11:08:20 2022 +0800

    update flake inputs

commit c93b21f1f9441e5c6f54525bf7c6a54757ec36cc
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Mon Oct 10 12:54:12 2022 -0500

    tried to make tests pass

commit 1046ae1237299a33c58b48661bdb6d325a22147e
Merge: 2bf4e36 363bd83
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Mon Oct 10 12:18:48 2022 -0500

    Merge branch 'staging' into seungheonoh/ply

commit 2bf4e3627c1b229f58078695082da85c80efd560
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Mon Oct 10 10:48:36 2022 -0500

    remove junkpile

commit a1dbc9ad9e531fe0d0a0480c4aef9cf9ffa90f1d
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Mon Oct 10 10:47:25 2022 -0500

    versions

commit 4542a06ac733858297d3a48c53368fad19dedc43
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Thu Oct 6 22:57:48 2022 -0500

    script exporting interface

commit 6bd8c1a1d57e4bf9dc25c3068a9c8eae6bf6a19d
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Thu Oct 6 22:58:41 2022 -0500

    fixed tests

commit d3ce2cf95633d336f3e621833677bd5bf10ee2c8
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Sun Oct 2 00:55:18 2022 -0500

    fixed tests

commit 1ae64c9f692652b77b0506013853b2ba44267c65
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Sat Oct 1 13:28:20 2022 -0500

    linker

commit db88cb75c7b74843141ad8ab4e6522b66d0dcfbc
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Sat Oct 1 01:03:50 2022 -0500

    exporting scripts

commit 6389fce28e885a8a7f8669629c266f59c0edb51f
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Sat Oct 1 00:51:49 2022 -0500

    made scripts parameterized on the script level

commit aea1e518a8890550bdebd0e5251da11d915c53a9
Author: Seungheon Oh <seungheon.ooh@gmail.com>
Date:   Wed Sep 28 19:53:29 2022 -0500

    Use `TypedScriptEnvelope` for `Agora.Bootstrap`
This commit is contained in:
Seungheon Oh 2022-10-18 18:59:38 -05:00
parent 1821dd6a88
commit d2018afd4d
38 changed files with 8614 additions and 2330 deletions
Download patch file Download diff file Expand all files Collapse all files

45
agora/Agora/AuthorityToken.hs
View file

@ -9,7 +9,6 @@ module Agora.AuthorityToken (
authorityTokenPolicy,
authorityTokensValidIn,
singleAuthorityTokenBurned,
AuthorityToken (..),
) where
import Plutarch.Api.V1 (
@ -29,34 +28,13 @@ import Plutarch.Api.V2 (
PTxInfo (PTxInfo),
PTxOut (PTxOut),
)
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
import Plutarch.Extra.AssetClass (PAssetClass, passetClass, passetClassValueOf)
import "liqwid-plutarch-extra" Plutarch.Extra.List (plookupAssoc)
import Plutarch.Extra.ScriptContext (pisTokenSpent)
import Plutarch.Extra.Sum (PSum (PSum))
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Extra.Value (psymbolValueOf)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
--------------------------------------------------------------------------------
{- | An AuthorityToken represents a proof that a particular token
spent in the same transaction the AuthorityToken was minted.
In effect, this means that the validator that locked such a token
must have approved the transaction in which an AuthorityToken is minted.
Said validator should be made aware of an AuthorityToken token's existence
in order to prevent incorrect minting.
@since 0.1.0
-}
newtype AuthorityToken = AuthorityToken
{ authority :: AssetClass
-- ^ Token that must move in order for minting this to be valid.
}
deriving stock
( -- | @since 0.1.0
Generic
)
--------------------------------------------------------------------------------
@ -72,7 +50,7 @@ newtype AuthorityToken = AuthorityToken
As of version 1.0.0, this has been weakened in order to be compatible
with RATs.
@since 0.1.0
@since 1.0.0
-}
authorityTokensValidIn :: forall (s :: S). Term s (PCurrencySymbol :--> PTxOut :--> PBool)
authorityTokensValidIn = phoistAcyclic $
@ -143,20 +121,27 @@ singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
{- | Policy given 'AuthorityToken' params.
== Authority Token
An AuthorityToken represents a proof that a particular token
spent in the same transaction the AuthorityToken was minted.
In effect, this means that the validator that locked such a token
must have approved the transaction in which an AuthorityToken is minted.
Said validator should be made aware of an AuthorityToken token's existence
in order to prevent incorrect minting.
@since 0.1.0
-}
authorityTokenPolicy :: AuthorityToken -> ClosedTerm PMintingPolicy
authorityTokenPolicy params =
plam $ \_redeemer ctx' ->
authorityTokenPolicy :: ClosedTerm (PAssetClass :--> PMintingPolicy)
authorityTokenPolicy =
plam $ \atAssetClass _redeemer ctx' ->
pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
PTxInfo txInfo' <- pmatchC $ pfromData ctx.txInfo
txInfo <- pletFieldsC @'["inputs", "mint", "outputs"] txInfo'
let inputs = txInfo.inputs
mintedValue = pfromData txInfo.mint
AssetClass (govCs, govTn) = params.authority
govAc = passetClass # pconstant govCs # pconstant govTn
govTokenSpent = pisTokenSpent # govAc # inputs
govTokenSpent = pisTokenSpent # atAssetClass # inputs
PMinting ownSymbol' <- pmatchC $ pfromData ctx.purpose

92
agora/Agora/Bootstrap.hs
View file

@ -6,66 +6,52 @@
-}
module Agora.Bootstrap (agoraScripts) where
import Agora.AuthorityToken (AuthorityToken (AuthorityToken), authorityTokenPolicy)
import Agora.AuthorityToken (authorityTokenPolicy)
import Agora.Effect.GovernorMutation (mutateGovernorValidator)
import Agora.Effect.NoOp (noOpValidator)
import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator)
import Agora.Governor (Governor, gstOutRef, gtClassRef, maximumCosigners)
import Agora.Governor.Scripts (governorPolicy, governorValidator)
import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
import Agora.Scripts (AgoraScripts (AgoraScripts))
import Agora.Scripts qualified as Scripts
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
import Agora.Treasury (treasuryValidator)
import Agora.Utils (
CompiledMintingPolicy (CompiledMintingPolicy),
CompiledValidator (CompiledValidator),
)
import Data.Map (fromList)
import Data.Text (Text, unpack)
import Plutarch (Config)
import Plutarch.Api.V2 (
mintingPolicySymbol,
mkMintingPolicy,
mkValidator,
)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
import Plutarch.Extra.AssetClass (PAssetClass)
import PlutusLedgerApi.V1.Value (AssetClass)
import Ply (TypedScriptEnvelope)
import Ply.Plutarch.Class (PlyArgOf)
import Ply.Plutarch.TypedWriter (TypedWriter, mkEnvelope)
import ScriptExport.ScriptInfo (RawScriptExport (..))
{- | Parameterize and precompiled core scripts, given the
'Agora.Governor.Governor' parameters and plutarch configurations.
type instance PlyArgOf PAssetClass = AssetClass
@since 0.2.0
{- | Parameterize core scripts, given the 'Agora.Governor.Governor'
parameters and plutarch configurations.
@since 1.0.0
-}
agoraScripts :: Config -> Governor -> AgoraScripts
agoraScripts conf gov = scripts
agoraScripts :: Config -> RawScriptExport
agoraScripts conf =
RawScriptExport $
fromList
[ envelope "agora:governorPolicy" governorPolicy
, envelope "agora:governorValidator" governorValidator
, envelope "agora:stakePolicy" stakePolicy
, envelope "agora:stakeValidator" stakeValidator
, envelope "agora:proposalPolicy" proposalPolicy
, envelope "agora:proposalValidator" proposalValidator
, envelope "agora:treasuryValidator" treasuryValidator
, envelope "agora:authorityTokenPolicy" authorityTokenPolicy
, envelope "agora:noOpValidator" noOpValidator
, envelope "agora:treasuryWithdrawalValidator" treasuryWithdrawalValidator
, envelope "agora:mutateGovernorValidator" mutateGovernorValidator
]
where
mkMintingPolicy' = mkMintingPolicy conf
mkValidator' = mkValidator conf
compiledGovernorPolicy = mkMintingPolicy' $ governorPolicy gov.gstOutRef
compiledGovernorValidator = mkValidator' $ governorValidator scripts
governorSymbol = mintingPolicySymbol compiledGovernorPolicy
governorAssetClass = AssetClass (governorSymbol, "")
authority = AuthorityToken governorAssetClass
compiledAuthorityPolicy = mkMintingPolicy' $ authorityTokenPolicy authority
authorityTokenSymbol = mintingPolicySymbol compiledAuthorityPolicy
compiledProposalPolicy = mkMintingPolicy' $ proposalPolicy governorAssetClass
compiledProposalValidator = mkValidator' $ proposalValidator scripts gov.maximumCosigners
compiledStakePolicy = mkMintingPolicy' $ stakePolicy gov.gtClassRef
compiledStakeValidator = mkValidator' $ stakeValidator scripts gov.gtClassRef
compiledTreasuryValidator = mkValidator' $ treasuryValidator authorityTokenSymbol
compiledTreasuryWithdrawalEffect = mkValidator' $ treasuryWithdrawalValidator authorityTokenSymbol
scripts =
AgoraScripts
{ Scripts.compiledGovernorPolicy = CompiledMintingPolicy compiledGovernorPolicy
, Scripts.compiledGovernorValidator = CompiledValidator compiledGovernorValidator
, Scripts.compiledStakePolicy = CompiledMintingPolicy compiledStakePolicy
, Scripts.compiledStakeValidator = CompiledValidator compiledStakeValidator
, Scripts.compiledProposalPolicy = CompiledMintingPolicy compiledProposalPolicy
, Scripts.compiledProposalValidator = CompiledValidator compiledProposalValidator
, Scripts.compiledTreasuryValidator = CompiledValidator compiledTreasuryValidator
, Scripts.compiledAuthorityTokenPolicy = CompiledMintingPolicy compiledAuthorityPolicy
, Scripts.compiledTreasuryWithdrawalEffect = CompiledValidator compiledTreasuryWithdrawalEffect
}
envelope ::
forall (pt :: S -> Type).
TypedWriter pt =>
Text ->
ClosedTerm pt ->
(Text, TypedScriptEnvelope)
envelope d t = (d, either (error . unpack) id $ mkEnvelope conf d t)

20
agora/Agora/Effect.hs
View file

@ -18,8 +18,6 @@ import Plutarch.Api.V2 (
PValidator,
)
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
import Plutarch.TryFrom ()
import PlutusLedgerApi.V1.Value (CurrencySymbol)
{- | Helper "template" for creating effect validator.
@ -27,21 +25,20 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol)
an effect is implemented. In such situations, it's okay to not use this
helper.
@since 0.1.0
@since 1.0.0
-}
makeEffect ::
forall (datum :: PType).
forall (datum :: PType) (s :: S).
(PTryFrom PData datum, PIsData datum) =>
CurrencySymbol ->
( forall (s :: S).
Term s PCurrencySymbol ->
( Term s PCurrencySymbol ->
Term s datum ->
Term s PTxOutRef ->
Term s (PAsData PTxInfo) ->
Term s POpaque
) ->
ClosedTerm PValidator
makeEffect gatCs' f =
Term s PCurrencySymbol ->
Term s PValidator
makeEffect f atSymbol =
plam $ \datum _redeemer ctx' -> unTermCont $ do
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
@ -64,10 +61,9 @@ makeEffect gatCs' f =
txOutRef' <- pletC (pfield @"_0" # txOutRef)
txInfo <- pletFieldsC @'["mint", "inputs"] ctx.txInfo
gatCs <- pletC $ pconstant gatCs'
pguardC "A single authority token has been burned" $
singleAuthorityTokenBurned gatCs txInfo.inputs txInfo.mint
singleAuthorityTokenBurned atSymbol txInfo.inputs txInfo.mint
-- run effect function
pure $ f gatCs datum' txOutRef' ctx.txInfo
pure $ f atSymbol datum' txOutRef' ctx.txInfo

143
agora/Agora/Effect/GovernorMutation.hs
View file

@ -26,8 +26,8 @@ import Agora.Governor (
PGovernorRedeemer,
)
import Agora.Plutarch.Orphans ()
import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTSymbol, governorValidatorHash)
import Agora.Utils (pfromSingleton, ptryFromRedeemer)
import Plutarch.Api.V1 (PCurrencySymbol, PValidatorHash)
import Plutarch.Api.V2 (
PScriptPurpose (PSpending),
PTxOutRef,
@ -140,85 +140,88 @@ deriving anyclass instance PTryFrom PData PMutateGovernorDatum
* It has valid governor state datum.
* The datum is exactly the same as the 'newDatum'.
@since 0.1.0
@since 1.0.0
-}
mutateGovernorValidator ::
-- | Lazy precompiled scripts. This is beacuse we need the symbol of GST.
AgoraScripts ->
ClosedTerm PValidator
mutateGovernorValidator as = makeEffect (authorityTokenSymbol as) $
\_gatCs (effectDatum :: Term _ PMutateGovernorDatum) _ txInfo -> unTermCont $ do
effectDatumF <- pletAllC effectDatum
txInfoF <- pletFieldsC @'["inputs", "outputs", "datums", "redeemers"] txInfo
ClosedTerm
( PValidatorHash
:--> PCurrencySymbol
:--> PCurrencySymbol
:--> PValidator
)
mutateGovernorValidator =
plam $ \govValidatorHash gtSymbol -> makeEffect @PMutateGovernorDatum $
\_gatCs (effectDatum :: Term _ PMutateGovernorDatum) _ txInfo -> unTermCont $ do
effectDatumF <- pletAllC effectDatum
txInfoF <- pletFieldsC @'["inputs", "outputs", "datums", "redeemers"] txInfo
----------------------------------------------------------------------------
----------------------------------------------------------------------------
scriptInputs <-
pletC $
pfilter
scriptInputs <-
pletC $
pfilter
# plam
( \inInfo ->
pisScriptAddress
#$ pfield @"address"
#$ pfield @"resolved" # inInfo
)
# pfromData txInfoF.inputs
-- Only two script inputs are alloed: one from the effect script, another from the governor.
pguardC "Only self and governor script inputs are allowed" $
plength # scriptInputs #== 2
pguardC "Governor input should present" $
pany
# plam
( \inInfo ->
pisScriptAddress
#$ pfield @"address"
#$ pfield @"resolved" # inInfo
( flip pletAll $ \inputF ->
let governorAddress =
paddressFromValidatorHash
# govValidatorHash
# pdnothing
isGovernorInput =
foldl1
(#&&)
[ ptraceIfFalse "Can only modify the pinned governor" $
inputF.outRef #== effectDatumF.governorRef
, ptraceIfFalse "Governor UTxO should carry GST" $
psymbolValueOf
# gtSymbol
# (pfield @"value" # inputF.resolved)
#== 1
, ptraceIfFalse "Governor validator run" $
pfield @"address" # inputF.resolved
#== governorAddress
]
in isGovernorInput
)
# pfromData txInfoF.inputs
# scriptInputs
-- Only two script inputs are alloed: one from the effect script, another from the governor.
pguardC "Only self and governor script inputs are allowed" $
plength # scriptInputs #== 2
let governorRedeemer =
pfromData $
passertPJust # "Govenor redeemer should be resolved"
#$ ptryFromRedeemer @(PAsData PGovernorRedeemer)
# mkRecordConstr PSpending (#_0 .= effectDatumF.governorRef)
# txInfoF.redeemers
pguardC "Governor input should present" $
pany
# plam
( flip pletAll $ \inputF ->
let gstSymbol = pconstant $ governorSTSymbol as
governorAddress =
paddressFromValidatorHash
# pconstant (governorValidatorHash as)
# pdnothing
pguardC "Spend governor with redeemer MutateGovernor" $
governorRedeemer #== pconstant MutateGovernor
isGovernorInput =
foldl1
(#&&)
[ ptraceIfFalse "Can only modify the pinned governor" $
inputF.outRef #== effectDatumF.governorRef
, ptraceIfFalse "Governor UTxO should carry GST" $
psymbolValueOf
# gstSymbol
# (pfield @"value" # inputF.resolved)
#== 1
, ptraceIfFalse "Governor validator run" $
pfield @"address" # inputF.resolved
#== governorAddress
]
in isGovernorInput
)
# scriptInputs
----------------------------------------------------------------------------
let governorRedeemer =
pfromData $
passertPJust # "Govenor redeemer should be resolved"
#$ ptryFromRedeemer @(PAsData PGovernorRedeemer)
# mkRecordConstr PSpending (#_0 .= effectDatumF.governorRef)
# txInfoF.redeemers
let governorOutput =
ptrace "Only governor output is allowed" $
pfromSingleton # pfromData txInfoF.outputs
pguardC "Spend governor with redeemer MutateGovernor" $
governorRedeemer #== pconstant MutateGovernor
governorOutputDatum =
ptrace "Resolve governor outoput datum" $
pfromOutputDatum @PGovernorDatum
# (pfield @"datum" # governorOutput)
# txInfoF.datums
----------------------------------------------------------------------------
pguardC "New governor datum correct" $
governorOutputDatum #== effectDatumF.newDatum
let governorOutput =
ptrace "Only governor output is allowed" $
pfromSingleton # pfromData txInfoF.outputs
governorOutputDatum =
ptrace "Resolve governor outoput datum" $
pfromOutputDatum @PGovernorDatum
# (pfield @"datum" # governorOutput)
# txInfoF.datums
pguardC "New governor datum correct" $
governorOutputDatum #== effectDatumF.newDatum
return $ popaque $ pconstant ()
return $ popaque $ pconstant ()

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

@ -9,9 +9,9 @@ module Agora.Effect.NoOp (noOpValidator, PNoOp) where
import Agora.Effect (makeEffect)
import Agora.Plutarch.Orphans ()
import Plutarch.Api.V1 (PCurrencySymbol)
import Plutarch.Api.V2 (PValidator)
import Plutarch.Orphans ()
import PlutusLedgerApi.V1.Value (CurrencySymbol)
{- | Dummy datum for NoOp effect.
@ -38,8 +38,9 @@ instance PTryFrom PData (PAsData PNoOp)
{- | Dummy effect which can only burn its GAT.
@since 0.1.0
@since 1.0.0
-}
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
noOpValidator curr = makeEffect curr $
\_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())
noOpValidator :: ClosedTerm (PCurrencySymbol :--> PValidator)
noOpValidator = plam $
makeEffect $
\_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())

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

@ -18,6 +18,7 @@ import Agora.Plutarch.Orphans ()
import Agora.Utils (pdelete)
import Plutarch.Api.V1 (
PCredential,
PCurrencySymbol,
PValue,
ptuple,
)
@ -38,7 +39,7 @@ import Plutarch.Extra.ScriptContext (pisPubKey)
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
import PlutusLedgerApi.V1.Credential (Credential)
import PlutusLedgerApi.V1.Value (CurrencySymbol, Value)
import PlutusLedgerApi.V1.Value (Value)
import PlutusTx qualified
{- | Datum that encodes behavior of Treasury Withdrawal effect.
@ -128,61 +129,64 @@ instance PTryFrom PData PTreasuryWithdrawalDatum
- The number of outputs themselves
@since 0.1.0
@since 1.0.0
-}
treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
\_cs (datum :: Term _ PTreasuryWithdrawalDatum) effectInputRef txInfo -> unTermCont $ do
datumF <- pletAllC datum
txInfoF <- pletFieldsC @'["outputs", "inputs"] txInfo
treasuryWithdrawalValidator ::
forall (s :: S).
Term s (PCurrencySymbol :--> PValidator)
treasuryWithdrawalValidator = plam $
makeEffect $
\_cs (datum :: Term _ PTreasuryWithdrawalDatum) effectInputRef txInfo -> unTermCont $ do
datumF <- pletAllC datum
txInfoF <- pletFieldsC @'["outputs", "inputs"] txInfo
let validateInput :: Term _ (PTxInInfo :--> PBool)
validateInput = plam $ \input -> unTermCont $ do
inputF <- pletAllC input
let validateInput :: Term _ (PTxInInfo :--> PBool)
validateInput = plam $ \input -> unTermCont $ do
inputF <- pletAllC input
cred <-
pletC $
pfield @"credential"
#$ pfield @"address" # inputF.resolved
cred <-
pletC $
pfield @"credential"
#$ pfield @"address" # inputF.resolved
pure $
foldl1
(#||)
[ ptraceIfTrue "Effect input" $ inputF.outRef #== effectInputRef
, ptraceIfTrue "Treasury input" $ pelem # cred # datumF.treasuries
, ptraceIfTrue "Collateral input" $ pisPubKey # pfromData cred
]
pure $
foldl1
(#||)
[ ptraceIfTrue "Effect input" $ inputF.outRef #== effectInputRef
, ptraceIfTrue "Treasury input" $ pelem # cred # datumF.treasuries
, ptraceIfTrue "Collateral input" $ pisPubKey # pfromData cred
]
validateOutput ::
Term
_
( PBuiltinList (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
:--> PTxOut
:--> PBuiltinList (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
)
validateOutput = plam $ \receivers output -> unTermCont $ do
outputF <- pletFieldsC @'["address", "value"] output
cred <- pletC $ pfield @"credential" # pfromData outputF.address
validateOutput ::
Term
_
( PBuiltinList (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
:--> PTxOut
:--> PBuiltinList (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
)
validateOutput = plam $ \receivers output -> unTermCont $ do
outputF <- pletFieldsC @'["address", "value"] output
cred <- pletC $ pfield @"credential" # pfromData outputF.address
let credValue = pdata $ ptuple # cred # outputF.value
let credValue = pdata $ ptuple # cred # outputF.value
shouldSendToTreasury =
pif
(pelem # cred # datumF.treasuries)
receivers
(ptraceError "Invalid receiver")
shouldSendToTreasury =
pif
(pelem # cred # datumF.treasuries)
receivers
(ptraceError "Invalid receiver")
pure $
pmatch (pdelete # credValue # receivers) $ \case
PJust updatedReceivers ->
ptrace "Receiver output" updatedReceivers
PNothing ->
ptrace "Treasury output" shouldSendToTreasury
pure $
pmatch (pdelete # credValue # receivers) $ \case
PJust updatedReceivers ->
ptrace "Receiver output" updatedReceivers
PNothing ->
ptrace "Treasury output" shouldSendToTreasury
pguardC "All input are valid" $
pall # validateInput # txInfoF.inputs
pguardC "All input are valid" $
pall # validateInput # txInfoF.inputs
pguardC "All receiver get correct output" $
pnull #$ pfoldl # validateOutput # datumF.receivers # txInfoF.outputs
pguardC "All receiver get correct output" $
pnull #$ pfoldl # validateOutput # datumF.receivers # txInfoF.outputs
pure . popaque $ pconstant ()
pure . popaque $ pconstant ()

8
agora/Agora/Governor.hs
View file

@ -23,6 +23,7 @@ module Agora.Governor (
pisGovernorDatumValid,
) where
import Agora.Aeson.Orphans ()
import Agora.Proposal (
PProposalId (PProposalId),
PProposalThresholds,
@ -39,6 +40,7 @@ import Agora.Proposal.Time (
pisProposalTimingConfigValid,
)
import Agora.SafeMoney (GTTag)
import Data.Aeson qualified as Aeson
import Data.Tagged (Tagged)
import Plutarch.DataRepr (
DerivePConstantViaData (DerivePConstantViaData),
@ -140,6 +142,12 @@ data Governor = Governor
, -- | @since 0.2.0
Show
)
deriving anyclass
( -- | @since 1.0.0
Aeson.ToJSON
, -- | @since 1.0.0
Aeson.FromJSON
)
--------------------------------------------------------------------------------

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

@ -36,14 +36,6 @@ import Agora.Proposal (
pwinner,
)
import Agora.Proposal.Time (validateProposalStartingTime)
import Agora.Scripts (
AgoraScripts,
authorityTokenSymbol,
governorSTSymbol,
proposalSTSymbol,
proposalValidatoHash,
stakeSTSymbol,
)
import Agora.Stake (
PStakeDatum (..),
pnumCreatedProposals,
@ -51,14 +43,16 @@ import Agora.Stake (
import Agora.Utils (
plistEqualsBy,
pscriptHashToTokenName,
validatorHashToAddress,
)
import Plutarch.Api.V1 (PCurrencySymbol)
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V1.AssocMap qualified as AssocMap
import Plutarch.Api.V2 (
PAddress,
PMintingPolicy,
PScriptPurpose (PMinting, PSpending),
PTxOut,
PTxOutRef,
PValidator,
)
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
@ -84,7 +78,6 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
ptryFromC,
)
import Plutarch.Extra.Value (psymbolValueOf)
import PlutusLedgerApi.V1 (TxOutRef)
--------------------------------------------------------------------------------
@ -113,11 +106,11 @@ import PlutusLedgerApi.V1 (TxOutRef)
NOTE: It's user's responsibility to make sure the token is sent to the corresponding governor validator.
We /can't/ really check this in the policy, otherwise we create a cyclic reference issue.
@since 0.1.0
@since 1.0.0
-}
governorPolicy :: TxOutRef -> ClosedTerm PMintingPolicy
governorPolicy initialSpend =
plam $ \_ ctx -> unTermCont $ do
governorPolicy :: ClosedTerm (PTxOutRef :--> PMintingPolicy)
governorPolicy =
plam $ \initialSpend _ ctx -> unTermCont $ do
PMinting ((pfield @"_0" #) -> gstSymbol) <-
pmatchC (pfromData $ pfield @"purpose" # ctx)
@ -134,7 +127,7 @@ governorPolicy initialSpend =
txInfo
pguardC "Referenced utxo should be spent" $
pisUTXOSpent # pconstant initialSpend # txInfoF.inputs
pisUTXOSpent # initialSpend # txInfoF.inputs
pguardC "Exactly one token should be minted" $
let vMap = pfromData $ pto txInfoF.mint
@ -249,19 +242,29 @@ governorPolicy initialSpend =
- Exactly one GAT is burnt in the transaction.
- Said GAT is tagged by the effect.
@since 0.1.0
== Arguments
Following arguments should be provided(in this order):
1. proposal validator address
2. state ST symbol
3. governor ST symbol
4. proposal ST symbol
5. authority token symbol.
@since 1.0.0
-}
governorValidator ::
-- | Lazy precompiled scripts.
AgoraScripts ->
ClosedTerm PValidator
governorValidator as =
plam $ \datum redeemer ctx -> unTermCont $ do
pstSymbol <- pletC $ pconstant $ proposalSTSymbol as
atSymbol <- pletC $ pconstant $ authorityTokenSymbol as
----------------------------------------------------------------------------
ClosedTerm
( PAddress
:--> PCurrencySymbol
:--> PCurrencySymbol
:--> PCurrencySymbol
:--> PCurrencySymbol
:--> PValidator
)
governorValidator =
plam $ \proposalValidatorAddress sstSymbol gstSymbol pstSymbol atSymbol datum redeemer ctx -> unTermCont $ do
ctxF <- pletAllC ctx
txInfo <- pletC $ pfromData ctxF.txInfo
txInfoF <-
@ -301,9 +304,7 @@ governorValidator as =
#$ pfindJust
# plam
( flip pletAll $ \outputF ->
let gstSymbol = pconstant $ governorSTSymbol as
isGovernorUTxO =
let isGovernorUTxO =
foldl1
(#&&)
[ ptraceIfFalse "Own by governor validator" $
@ -330,9 +331,7 @@ governorValidator as =
pletC $
plam $
flip (pletFields @'["value", "datum"]) $ \txOutF ->
let sstSymbol = pconstant $ stakeSTSymbol as
isStakeUTxO =
let isStakeUTxO =
psymbolValueOf
# sstSymbol
# txOutF.value #== 1
@ -349,12 +348,7 @@ governorValidator as =
pletC $
plam $
flip (pletFields @'["value", "datum", "address"]) $ \txOutF ->
let proposalValidatorAddress =
pconstant $
validatorHashToAddress $
proposalValidatoHash as
isProposalUTxO =
let isProposalUTxO =
txOutF.address #== pdata proposalValidatorAddress
#&& psymbolValueOf # pstSymbol # txOutF.value #== 1

109
agora/Agora/Linker.hs Normal file
View file

@ -0,0 +1,109 @@
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
module Agora.Linker (linker) where
import Agora.Governor (Governor (gstOutRef, gtClassRef, maximumCosigners))
import Agora.Utils (validatorHashToAddress, validatorHashToTokenName)
import Data.Map (fromList)
import Data.Tagged (untag)
import Plutarch.Api.V2 (mintingPolicySymbol, validatorHash)
import PlutusLedgerApi.V1 (Address, CurrencySymbol, TxOutRef, ValidatorHash)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
import Ply (
ScriptRole (MintingPolicyRole, ValidatorRole),
toMintingPolicy,
toScript,
toValidator,
(#),
)
import ScriptExport.ScriptInfo (
Linker,
ScriptExport (..),
fetchTS,
getParam,
)
import Prelude hiding ((#))
{- | Links parameterized Agora scripts given parameters.
@since 1.0.0
-}
linker :: Linker Governor (ScriptExport Governor)
linker = do
govPol <- fetchTS @MintingPolicyRole @'[TxOutRef] "agora:governorPolicy"
govVal <- fetchTS @ValidatorRole @'[Address, CurrencySymbol, CurrencySymbol, CurrencySymbol, CurrencySymbol] "agora:governorValidator"
stkPol <- fetchTS @MintingPolicyRole @'[AssetClass] "agora:stakePolicy"
stkVal <- fetchTS @ValidatorRole @'[CurrencySymbol, AssetClass, AssetClass] "agora:stakeValidator"
prpPol <- fetchTS @MintingPolicyRole @'[AssetClass] "agora:proposalPolicy"
prpVal <- fetchTS @ValidatorRole @'[AssetClass, CurrencySymbol, CurrencySymbol, Integer] "agora:proposalValidator"
treVal <- fetchTS @ValidatorRole @'[CurrencySymbol] "agora:treasuryValidator"
atkPol <- fetchTS @MintingPolicyRole @'[AssetClass] "agora:authorityTokenPolicy"
noOpVal <- fetchTS @ValidatorRole @'[CurrencySymbol] "agora:noOpValidator"
treaWithdrawalVal <- fetchTS @ValidatorRole @'[CurrencySymbol] "agora:treasuryWithdrawalValidator"
mutateGovVal <- fetchTS @ValidatorRole @'[ValidatorHash, CurrencySymbol, CurrencySymbol] "agora:mutateGovernorValidator"
governor <- getParam
let govPol' = govPol # governor.gstOutRef
govVal' =
govVal
# propValAddress
# sstSymbol
# gstSymbol
# pstSymbol
# atSymbol
gstSymbol =
mintingPolicySymbol $
toMintingPolicy
govPol'
gstAssetClass =
AssetClass (gstSymbol, "")
govValHash = validatorHash $ toValidator govVal'
at = gstAssetClass
atPol' = atkPol # at
atSymbol = mintingPolicySymbol $ toMintingPolicy atPol'
propPol' = prpPol # gstAssetClass
propVal' =
prpVal
# sstAssetClass
# gstSymbol
# pstSymbol
# governor.maximumCosigners
propValAddress =
validatorHashToAddress $ validatorHash $ toValidator propVal'
pstSymbol = mintingPolicySymbol $ toMintingPolicy propPol'
pstAssetClass = AssetClass (pstSymbol, "")
stakPol' = stkPol # untag governor.gtClassRef
stakVal' = stkVal # sstSymbol # pstAssetClass # untag governor.gtClassRef
sstSymbol = mintingPolicySymbol $ toMintingPolicy stakPol'
stakValTokenName =
validatorHashToTokenName $ validatorHash $ toValidator stakVal'
sstAssetClass = AssetClass (sstSymbol, stakValTokenName)
treaVal' = treVal # atSymbol
noOpVal' = noOpVal # atSymbol
treaWithdrawalVal' = treaWithdrawalVal # atSymbol
mutateGovVal' = mutateGovVal # govValHash # gstSymbol # atSymbol
return $
ScriptExport
{ scripts =
fromList
[ ("agora:governorPolicy", toScript govPol')
, ("agora:governorValidator", toScript govVal')
, ("agora:stakePolicy", toScript stakPol')
, ("agora:stakeValidator", toScript stakVal')
, ("agora:proposalPolicy", toScript propPol')
, ("agora:proposalValidator", toScript propVal')
, ("agora:treasuryValidator", toScript treaVal')
, ("agora:authorityTokenPolicy", toScript atPol')
, ("agora:noOpValidator", toScript noOpVal')
, ("agora:treasuryWithdrawalValidator", toScript treaWithdrawalVal')
, ("agora:mutateGovernorValidator", toScript mutateGovVal')
]
, information = governor
}

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

@ -26,7 +26,6 @@ import Agora.Proposal.Time (
isLockingPeriod,
isVotingPeriod,
)
import Agora.Scripts (AgoraScripts, governorSTSymbol, proposalSTSymbol, stakeSTAssetClass)
import Agora.Stake (
PStakeDatum,
pextractVoteOption,
@ -40,7 +39,7 @@ import Agora.Utils (
plistEqualsBy,
pmapMaybe,
)
import Plutarch.Api.V1 (PCredential)
import Plutarch.Api.V1 (PCredential, PCurrencySymbol)
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V2 (
PMintingPolicy,
@ -51,7 +50,7 @@ import Plutarch.Api.V2 (
PTxOut,
PValidator,
)
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
import Plutarch.Extra.AssetClass (PAssetClass, passetClass, passetClassValueOf)
import Plutarch.Extra.Category (PCategory (pidentity))
import Plutarch.Extra.Comonad (pextract)
import Plutarch.Extra.Field (pletAll, pletAllC)
@ -84,7 +83,6 @@ import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Extra.Value (psymbolValueOf)
import Plutarch.SafeMoney (PDiscrete (PDiscrete))
import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
{- | Policy for Proposals.
@ -104,14 +102,16 @@ import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
- This policy cannot be burned.
@since 0.1.0
== Arguments
Following arguments should be provided(in this order):
1. The assetclass of GST, see 'Agora.Governor.Scripts.governorPolicy'.
@since 1.0.0
-}
proposalPolicy ::
-- | The assetclass of GST, see 'Agora.Governor.Scripts.governorPolicy'.
AssetClass ->
ClosedTerm PMintingPolicy
proposalPolicy (AssetClass (govCs, govTn)) =
plam $ \_redeemer ctx' -> unTermCont $ do
proposalPolicy :: ClosedTerm (PAssetClass :--> PMintingPolicy)
proposalPolicy =
plam $ \gtAssetClass _redeemer ctx' -> unTermCont $ do
PScriptContext ctx' <- pmatchC ctx'
ctx <- pletAllC ctx'
PTxInfo txInfo' <- pmatchC $ pfromData ctx.txInfo
@ -125,7 +125,7 @@ proposalPolicy (AssetClass (govCs, govTn)) =
pguardC "Governance state-thread token must move" $
pisTokenSpent
# (passetClass # pconstant govCs # pconstant govTn)
# gtAssetClass
# txInfo.inputs
pguardC "Minted exactly one proposal ST" $
@ -199,16 +199,26 @@ instance DerivePlutusType PStakeInputsContext where
(see 'Agora.Proposal.AdvanceProposal' docs).
- 'Agora.Proposal.Unlock' is always valid.
@since 0.1.0
== Arguments
Following arguments should be provided(in this order):
1. stake ST assetclass
2. governor ST symbol
3. proposal ST symbol
4. maximum number of cosigners
@since 1.0.0
-}
proposalValidator ::
-- | Lazy precompiled scripts.
AgoraScripts ->
-- | See 'Agora.Governor.Governor.maximumCosigners'.
Integer ->
ClosedTerm PValidator
proposalValidator as maximumCosigners =
plam $ \datum redeemer ctx -> unTermCont $ do
ClosedTerm
( PAssetClass
:--> PCurrencySymbol
:--> PCurrencySymbol
:--> PInteger
:--> PValidator
)
proposalValidator =
plam $ \sstClass gstSymbol pstSymbol maximumCosigners datum redeemer ctx -> unTermCont $ do
ctxF <- pletAllC ctx
txInfo <- pletC $ pfromData ctxF.txInfo
@ -259,9 +269,7 @@ proposalValidator as maximumCosigners =
#$ pfindJust
# plam
( flip pletAll $ \outputF ->
let pstSymbol = pconstant $ proposalSTSymbol as
isProposalUTxO =
let isProposalUTxO =
foldl1
(#&&)
[ ptraceIfFalse "Own by proposal validator" $
@ -285,13 +293,6 @@ proposalValidator as maximumCosigners =
# pfromData txInfoF.outputs
--------------------------------------------------------------------------
let AssetClass (sstSymbol, sstName) = stakeSTAssetClass as
sstAssetClass <-
pletC $
passetClass
# pconstant sstSymbol
# pconstant sstName
-- Handle stake inputs/outputs.
@ -304,7 +305,7 @@ proposalValidator as maximumCosigners =
-- A stake UTxO is a UTxO that carries SST.
passetClassValueOf
# txOutF.value
# sstAssetClass
# sstClass
#== 1
stake =
@ -424,7 +425,7 @@ proposalValidator as maximumCosigners =
# proposalInputDatumF.cosigners
pguardC "Less cosigners than maximum limit" $
plength # updatedSigs #< pconstant maximumCosigners
plength # updatedSigs #< maximumCosigners
pguardC "Meet minimum GT requirement" $
pfromData thresholdsF.cosign #<= stakeF.stakedAmount
@ -701,8 +702,7 @@ proposalValidator as maximumCosigners =
pguardC "Proposal status set to Finished" $
proposalOutputStatus #== pconstant Finished
let gstSymbol = pconstant $ governorSTSymbol as
gstMoved =
let gstMoved =
pany
# plam
( \( (pfield @"value" #)

142
agora/Agora/Scripts.hs
View file

@ -1,142 +0,0 @@
{- | Module : Agora.Scripts
Maintainer : connor@mlabs.city
Description: Precompiled core scripts and utilities
Precompiled core scripts and utilities
-}
module Agora.Scripts (
AgoraScripts (..),
governorSTSymbol,
governorSTAssetClass,
governorValidatorHash,
proposalSTSymbol,
proposalSTAssetClass,
proposalValidatoHash,
stakeSTSymbol,
stakeSTAssetClass,
stakeValidatorHash,
authorityTokenSymbol,
treasuryValidatorHash,
) where
import Agora.Effect.TreasuryWithdrawal (TreasuryWithdrawalDatum)
import Agora.Governor (GovernorDatum, GovernorRedeemer)
import Agora.Proposal (ProposalDatum, ProposalRedeemer)
import Agora.Stake (StakeDatum, StakeRedeemer)
import Agora.Utils (
CompiledMintingPolicy (getCompiledMintingPolicy),
CompiledValidator (getCompiledValidator),
validatorHashToTokenName,
)
import Plutarch.Api.V2 (mintingPolicySymbol, validatorHash)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
import PlutusLedgerApi.V2 (CurrencySymbol, ValidatorHash)
{- | Precompiled core scripts.
Including:
- Governor policy
- Governor validator
- Proposal policy
- Proposal validator
- Stake policy
- Stake validator
- Treasury validator
- Authority token policy
@since 0.2.0
-}
data AgoraScripts = AgoraScripts
{ compiledGovernorPolicy :: CompiledMintingPolicy ()
, compiledGovernorValidator :: CompiledValidator GovernorDatum GovernorRedeemer
, compiledStakePolicy :: CompiledMintingPolicy ()
, compiledStakeValidator :: CompiledValidator StakeDatum StakeRedeemer
, compiledProposalPolicy :: CompiledMintingPolicy ()
, compiledProposalValidator :: CompiledValidator ProposalDatum ProposalRedeemer
, compiledTreasuryValidator :: CompiledValidator () ()
, compiledAuthorityTokenPolicy :: CompiledMintingPolicy ()
, compiledTreasuryWithdrawalEffect :: CompiledValidator () TreasuryWithdrawalDatum
}
{- | Get the currency symbol of the governor state token.
@since 0.2.0
-}
governorSTSymbol :: AgoraScripts -> CurrencySymbol
governorSTSymbol = mintingPolicySymbol . (.getCompiledMintingPolicy) . (.compiledGovernorPolicy)
{- | Get the asset class of the governor state token.
@since 0.2.0
-}
governorSTAssetClass :: AgoraScripts -> AssetClass
governorSTAssetClass as = AssetClass (governorSTSymbol as, "")
{- | Get the script hash of the governor validator.
@since 0.2.0
-}
governorValidatorHash :: AgoraScripts -> ValidatorHash
governorValidatorHash = validatorHash . (.getCompiledValidator) . (.compiledGovernorValidator)
{- | Get the currency symbol of the propsoal state token.
@since 0.2.0
-}
proposalSTSymbol :: AgoraScripts -> CurrencySymbol
proposalSTSymbol as = mintingPolicySymbol $ (.getCompiledMintingPolicy) as.compiledProposalPolicy
{- | Get the asset class of the governor state token.
@since 0.2.0
-}
proposalSTAssetClass :: AgoraScripts -> AssetClass
proposalSTAssetClass as = AssetClass (proposalSTSymbol as, "")
{- | Get the script hash of the proposal validator.
@since 0.2.0
-}
proposalValidatoHash :: AgoraScripts -> ValidatorHash
proposalValidatoHash = validatorHash . (.getCompiledValidator) . (.compiledProposalValidator)
{- | Get the script hash of the governor validator.
@since 0.2.0
-}
stakeSTSymbol :: AgoraScripts -> CurrencySymbol
stakeSTSymbol = mintingPolicySymbol . (.getCompiledMintingPolicy) . (.compiledStakePolicy)
{- | Get the asset class of the stake state token.
Note that this token is tagged with the hash of the stake validator.
See 'Agora.Stake.Script.stakePolicy'.
@since 0.2.0
-}
stakeSTAssetClass :: AgoraScripts -> AssetClass
stakeSTAssetClass as =
let tn = validatorHashToTokenName $ stakeValidatorHash as
in AssetClass (stakeSTSymbol as, tn)
{- | Get the script hash of the stake validator.
@since 0.2.0
-}
stakeValidatorHash :: AgoraScripts -> ValidatorHash
stakeValidatorHash = validatorHash . (.getCompiledValidator) . (.compiledStakeValidator)
{- | Get the currency symbol of the authority token.
@since 0.2.0
-}
authorityTokenSymbol :: AgoraScripts -> CurrencySymbol
authorityTokenSymbol = mintingPolicySymbol . (.getCompiledMintingPolicy) . (.compiledAuthorityTokenPolicy)
{- | Get the script hash of the treasury validator.
@since 0.2.0
-}
treasuryValidatorHash :: AgoraScripts -> ValidatorHash
treasuryValidatorHash = validatorHash . (.getCompiledValidator) . (.compiledTreasuryValidator)

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

@ -13,12 +13,6 @@ module Agora.Stake.Scripts (
import Agora.Credential (authorizationContext, pauthorizedBy)
import Agora.Proposal (PProposalDatum, PProposalRedeemer)
import Agora.SafeMoney (GTTag)
import Agora.Scripts (
AgoraScripts,
proposalSTAssetClass,
stakeSTSymbol,
)
import Agora.Stake (
PProposalContext (
PNewProposal,
@ -62,16 +56,13 @@ import Agora.Stake.Redeemers (
pretractVote,
)
import Agora.Utils (passert, pmapMaybe)
import Data.Tagged (Tagged (Tagged))
import Plutarch.Api.V1 (
KeyGuarantees (Sorted),
PCredential (PPubKeyCredential, PScriptCredential),
PCurrencySymbol,
PTokenName,
)
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V1.Value (PValue)
import Plutarch.Api.V2 (
AmountGuarantees,
PMintingPolicy,
PScriptPurpose (PMinting, PSpending),
PTxInfo,
@ -79,7 +70,7 @@ import Plutarch.Api.V2 (
PValidator,
)
import Plutarch.Extra.AssetClass (
passetClass,
PAssetClass,
passetClassValueOf,
pvalueOf,
)
@ -114,10 +105,8 @@ import Plutarch.Extra.Value (
import Plutarch.Num (PNum (pnegate))
import Plutarch.SafeMoney (
pvalueDiscrete,
pvalueDiscrete',
)
import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
import Prelude hiding (Num ((+)))
{- | Policy for Stake state threads.
@ -137,14 +126,18 @@ import Prelude hiding (Num ((+)))
- Check that exactly one state thread is burned.
- Check that datum at state thread is valid and not locked.
@since 0.1.0
== Arguments
Following arguments should be provided(in this order):
1. governor ST assetclass
@since 1.0.0
-}
stakePolicy ::
-- | The (governance) token that a Stake can store.
Tagged GTTag AssetClass ->
ClosedTerm PMintingPolicy
stakePolicy gtClassRef =
plam $ \_redeemer ctx' -> unTermCont $ do
ClosedTerm (PAssetClass :--> PMintingPolicy)
stakePolicy =
plam $ \gstClass _redeemer ctx' -> unTermCont $ do
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
txInfo <- pletC $ ctx.txInfo
let _a :: Term _ PTxInfo
@ -226,7 +219,7 @@ stakePolicy gtClassRef =
let hasExpectedStake =
ptraceIfFalse "Stake ouput has expected amount of stake token" $
pvalueDiscrete' gtClassRef # outputF.value #== datumF.stakedAmount
pvalueDiscrete # gstClass # outputF.value #== datumF.stakedAmount
let ownerSignsTransaction =
ptraceIfFalse "Stake Owner should sign the transaction" $
pauthorizedBy
@ -243,338 +236,319 @@ stakePolicy gtClassRef =
{- | Create a stake validator, given the implementation of stake redeemers.
== Arguments
Following arguments should be provided(in this order):
1. stake ST symbol
2. proposal ST assetclass
3. governor ST assetclass
@since 1.0.0
-}
mkStakeValidator ::
StakeRedeemerImpl ->
AgoraScripts ->
Tagged GTTag AssetClass ->
ClosedTerm PValidator
mkStakeValidator
impl
as
(Tagged (AssetClass (gtSym, gtTn))) =
plam $ \_datum redeemer ctx -> unTermCont $ do
let sstValueOf ::
( forall (ag :: AmountGuarantees) (s :: S).
Term s (PValue 'Sorted ag :--> PInteger)
)
sstValueOf =
phoistAcyclic $
psymbolValueOf # pconstant (stakeSTSymbol as)
--------------------------------------------------------------------------
ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
txInfo <- pletC $ pfromData ctxF.txInfo
txInfoF <-
pletFieldsC
@'[ "inputs"
, "referenceInputs"
, "outputs"
, "mint"
, "validRange"
, "signatories"
, "redeemers"
, "datums"
]
txInfo
--------------------------------------------------------------------------
PSpending stakeInputRef <- pmatchC $ pfromData ctxF.purpose
let validatedInput =
pfield @"resolved"
#$ passertPJust
# "Malformed script context: validated input not found"
#$ pfindTxInByTxOutRef
# (pfield @"_0" # stakeInputRef)
# txInfoF.inputs
stakeValidatorCredential =
pfield @"credential"
#$ pfield @"address" # validatedInput
--------------------------------------------------------------------------
-- Returns stake datum if the given UTxO is a stake UTxO.
getStakeDatum :: Term _ (PTxOut :--> PMaybe PStakeDatum) <-
pletC $
plam $
flip (pletFields @'["value", "datum", "address"]) $ \txOutF ->
pmatch
( pcompareBy # pfromOrd
# (sstValueOf # txOutF.value)
# 1
)
$ \case
-- > 1
PGT -> ptraceError "More than one SST in one UTxO"
-- 1
PEQ ->
let ownerCredential = pfield @"credential" # txOutF.address
isOwnedByStakeValidator =
ownerCredential #== stakeValidatorCredential
datum =
ptrace "Resolve stake datum" $
pfromData $
pfromOutputDatum @(PAsData PStakeDatum)
# txOutF.datum
# txInfoF.datums
in passert
"Should owned by stake validator"
isOwnedByStakeValidator
(pjust # datum)
-- 0
PLT -> pnothing
--------------------------------------------------------------------------
-- Find all stake inputs.
stakeInputDatums <-
pletC $
pmapMaybe
# plam ((getStakeDatum #) . (pfield @"resolved" #))
# pfromData txInfoF.inputs
--------------------------------------------------------------------------
-- Assemble the signature context.
firstStakeInputDatumF <-
pletFieldsC @'["owner", "delegatedTo"] $
phead # stakeInputDatums
restOfStakeInputDatums <- pletC $ ptail # stakeInputDatums
authorizedBy <- pletC $ pauthorizedBy # authorizationContext txInfoF
PPair allHaveSameOwner allHaveSameDelegatee <-
pmatchC $
pfoldr
# plam
( \d p -> unTermCont $ do
dF <- pletFieldsC @'["owner", "delegatedTo"] d
pure $
pmatch p $ \(PPair allHaveSameOwner allHaveSameDelegatee) ->
let allHaveSameOwner' =
allHaveSameOwner
#&& dF.owner #== firstStakeInputDatumF.owner
allHaveSameDelegatee' =
allHaveSameDelegatee
#&& dF.delegatedTo #== firstStakeInputDatumF.delegatedTo
in pcon $ PPair allHaveSameOwner' allHaveSameDelegatee'
)
# pcon (PPair (pconstant True) (pconstant True))
# restOfStakeInputDatums
let ownerSignsTransaction =
allHaveSameOwner
#&& authorizedBy # firstStakeInputDatumF.owner
delegateSignsTransaction =
allHaveSameDelegatee
#&& pmaybeData
# pconstant False
# plam ((authorizedBy #) . pfromData)
# pfromData firstStakeInputDatumF.delegatedTo
signedBy =
pif
ownerSignsTransaction
(pcon PSignedByOwner)
$ pif
delegateSignsTransaction
(pcon PSignedByDelegate)
$ pcon PUnknownSig
sigContext <-
pletC $
pcon $
PSigContext
firstStakeInputDatumF.owner
firstStakeInputDatumF.delegatedTo
signedBy
--------------------------------------------------------------------------
-- Find all stake outputs.
let gtAssetClass = passetClass # pconstant gtSym # pconstant gtTn
-- First step of validating stake outputs. We make sure that every stake
-- output UTxO carries correct amount of GTs specified by its datum.
--
-- Note that non-GT assets are treated transparently.
stakeOutputDatums <-
pletC $
pmapMaybe
# plam
( \output ->
let validateGT = plam $ \stakeDatum ->
let expected = pfield @"stakedAmount" # stakeDatum
actual =
pvalueDiscrete
# gtAssetClass
# (pfield @"value" # output)
in pif
(expected #== actual)
stakeDatum
(ptraceError "Unmatched GT value")
in pfmap
# validateGT
# (getStakeDatum # output)
)
# pfromData txInfoF.outputs
--------------------------------------------------------------------------
mintedST <- pletC $ sstValueOf # txInfoF.mint
pguardC "No new SST minted" $
foldl1
(#||)
[ ptraceIfTrue "All stakes burnt" $
mintedST #< 0 #&& pnull # stakeOutputDatums
, ptraceIfTrue "Nothing burnt" $
mintedST #== 0
ClosedTerm (PCurrencySymbol :--> PAssetClass :--> PAssetClass :--> PValidator)
mkStakeValidator impl =
plam $ \sstSymbol pstClass gstClass _datum redeemer ctx -> unTermCont $ do
ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
txInfo <- pletC $ pfromData ctxF.txInfo
txInfoF <-
pletFieldsC
@'[ "inputs"
, "referenceInputs"
, "outputs"
, "mint"
, "validRange"
, "signatories"
, "redeemers"
, "datums"
]
txInfo
--------------------------------------------------------------------------
--------------------------------------------------------------------------
-- Assemble the proposal context.
PSpending stakeInputRef <- pmatchC $ pfromData ctxF.purpose
let AssetClass (propCs, propTn) = proposalSTAssetClass as
let validatedInput =
pfield @"resolved"
#$ passertPJust
# "Malformed script context: validated input not found"
#$ pfindTxInByTxOutRef
# (pfield @"_0" # stakeInputRef)
# txInfoF.inputs
proposalSTClass <-
pletC $
passetClass
# pconstant propCs
# pconstant propTn
stakeValidatorCredential =
pfield @"credential"
#$ pfield @"address" # validatedInput
getProposalDatum <- pletC $
--------------------------------------------------------------------------
-- Returns stake datum if the given UTxO is a stake UTxO.
getStakeDatum :: Term _ (PTxOut :--> PMaybe PStakeDatum) <-
pletC $
plam $
flip pletAll $ \txOutF ->
let isProposalUTxO =
passetClassValueOf
# txOutF.value
# proposalSTClass #== 1
proposalDatum =
pfromData $
pfromOutputDatum @(PAsData PProposalDatum)
# txOutF.datum
# txInfoF.datums
in pif isProposalUTxO (pjust # proposalDatum) pnothing
flip (pletFields @'["value", "datum", "address"]) $ \txOutF ->
pmatch
( pcompareBy # pfromOrd
# (psymbolValueOf # sstSymbol # txOutF.value)
# 1
)
$ \case
-- > 1
PGT -> ptraceError "More than one SST in one UTxO"
-- 1
PEQ ->
let ownerCredential = pfield @"credential" # txOutF.address
let pstMinted =
passetClassValueOf # txInfoF.mint # proposalSTClass #== 1
isOwnedByStakeValidator =
ownerCredential #== stakeValidatorCredential
newProposalContext =
pcon $
PNewProposal $
pfield @"proposalId"
#$ passertPJust # "Proposal output should present"
#$ pfindJust # getProposalDatum # pfromData txInfoF.outputs
datum =
ptrace "Resolve stake datum" $
pfromData $
pfromOutputDatum @(PAsData PStakeDatum)
# txOutF.datum
# txInfoF.datums
in passert
"Should owned by stake validator"
isOwnedByStakeValidator
(pjust # datum)
-- 0
PLT -> pnothing
spendProposalContext =
let getProposalRedeemer = plam $ \ref ->
flip (ptryFrom @PProposalRedeemer) fst $
pto $
passertPJust
# "Malformed script context: propsoal input not found in redeemer map"
#$ plookup
# pcon
( PSpending $
pdcons @_0
# pdata ref
# pdnil
)
# txInfoF.redeemers
--------------------------------------------------------------------------
getContext = plam $
flip pletAll $ \inInfoF ->
pfmap
# plam
( \proposalDatum ->
let id = pfield @"proposalId" # proposalDatum
status = pfield @"status" # proposalDatum
redeemer = getProposalRedeemer # inInfoF.outRef
in pcon $ PSpendProposal id status redeemer
)
#$ getProposalDatum
# pfromData inInfoF.resolved
-- Find all stake inputs.
contexts =
pmapMaybe @PList # getContext # pfromData txInfoF.inputs
in -- Can only handle one proposal at a time.
precList
( \_ h t ->
pif
(pnull # t)
(pjust # h)
(ptraceError "Ambiguous proposal")
)
(const pnothing)
# contexts
stakeInputDatums <-
pletC $
pmapMaybe
# plam ((getStakeDatum #) . (pfield @"resolved" #))
# pfromData txInfoF.inputs
noProposalContext = pcon PNoProposal
--------------------------------------------------------------------------
proposalContext <-
pletC $
-- Assemble the signature context.
firstStakeInputDatumF <-
pletFieldsC @'["owner", "delegatedTo"] $
phead # stakeInputDatums
restOfStakeInputDatums <- pletC $ ptail # stakeInputDatums
authorizedBy <- pletC $ pauthorizedBy # authorizationContext txInfoF
PPair allHaveSameOwner allHaveSameDelegatee <-
pmatchC $
pfoldr
# plam
( \d p -> unTermCont $ do
dF <- pletFieldsC @'["owner", "delegatedTo"] d
pure $
pmatch p $ \(PPair allHaveSameOwner allHaveSameDelegatee) ->
let allHaveSameOwner' =
allHaveSameOwner
#&& dF.owner #== firstStakeInputDatumF.owner
allHaveSameDelegatee' =
allHaveSameDelegatee
#&& dF.delegatedTo #== firstStakeInputDatumF.delegatedTo
in pcon $ PPair allHaveSameOwner' allHaveSameDelegatee'
)
# pcon (PPair (pconstant True) (pconstant True))
# restOfStakeInputDatums
let ownerSignsTransaction =
allHaveSameOwner
#&& authorizedBy # firstStakeInputDatumF.owner
delegateSignsTransaction =
allHaveSameDelegatee
#&& pmaybeData
# pconstant False
# plam ((authorizedBy #) . pfromData)
# pfromData firstStakeInputDatumF.delegatedTo
signedBy =
pif
pstMinted
newProposalContext
(pfromMaybe # noProposalContext # spendProposalContext)
ownerSignsTransaction
(pcon PSignedByOwner)
$ pif
delegateSignsTransaction
(pcon PSignedByDelegate)
$ pcon PUnknownSig
--------------------------------------------------------------------------
sigContext <-
pletC $
pcon $
PSigContext
firstStakeInputDatumF.owner
firstStakeInputDatumF.delegatedTo
signedBy
-- Assemeble the redeemer handler context.
--------------------------------------------------------------------------
mkRedeemerhandlerContext <- pletC $
plam $ \redeemerContext ->
-- Find all stake outputs.
-- First step of validating stake outputs. We make sure that every stake
-- output UTxO carries correct amount of GTs specified by its datum.
--
-- Note that non-GT assets are treated transparently.
stakeOutputDatums <-
pletC $
pmapMaybe
# plam
( \output ->
let validateGT = plam $ \stakeDatum ->
let expected = pfield @"stakedAmount" # stakeDatum
actual =
pvalueDiscrete
# gstClass
# (pfield @"value" # output)
in pif
(expected #== actual)
stakeDatum
(ptraceError "Unmatched GT value")
in pfmap
# validateGT
# (getStakeDatum # output)
)
# pfromData txInfoF.outputs
--------------------------------------------------------------------------
mintedST <- pletC $ psymbolValueOf # sstSymbol # txInfoF.mint
pguardC "No new SST minted" $
foldl1
(#||)
[ ptraceIfTrue "All stakes burnt" $
mintedST #< 0 #&& pnull # stakeOutputDatums
, ptraceIfTrue "Nothing burnt" $
mintedST #== 0
]
--------------------------------------------------------------------------
-- Assemble the proposal context.
getProposalDatum <- pletC $
plam $
flip pletAll $ \txOutF ->
let isProposalUTxO =
passetClassValueOf
# txOutF.value
# pstClass #== 1
proposalDatum =
pfromData $
pfromOutputDatum @(PAsData PProposalDatum)
# txOutF.datum
# txInfoF.datums
in pif isProposalUTxO (pjust # proposalDatum) pnothing
let pstMinted =
passetClassValueOf # txInfoF.mint # pstClass #== 1
newProposalContext =
pcon $
PStakeRedeemerHandlerContext
stakeInputDatums
stakeOutputDatums
redeemerContext
sigContext
proposalContext
txInfo
PNewProposal $
pfield @"proposalId"
#$ passertPJust # "Proposal output should present"
#$ pfindJust # getProposalDatum # pfromData txInfoF.outputs
noMetadataContext <-
pletC $
mkRedeemerhandlerContext
#$ pcon
$ PNoMetadata
spendProposalContext =
let getProposalRedeemer = plam $ \ref ->
flip (ptryFrom @PProposalRedeemer) fst $
pto $
passertPJust
# "Malformed script context: propsoal input not found in redeemer map"
#$ plookup
# pcon
( PSpending $
pdcons @_0
# pdata ref
# pdnil
)
# txInfoF.redeemers
--------------------------------------------------------------------------
getContext = plam $
flip pletAll $ \inInfoF ->
pfmap
# plam
( \proposalDatum ->
let id = pfield @"proposalId" # proposalDatum
status = pfield @"status" # proposalDatum
redeemer = getProposalRedeemer # inInfoF.outRef
in pcon $ PSpendProposal id status redeemer
)
#$ getProposalDatum
# pfromData inInfoF.resolved
-- Call the redeemer handler.
contexts =
pmapMaybe @PList # getContext # pfromData txInfoF.inputs
in -- Can only handle one proposal at a time.
precList
( \_ h t ->
pif
(pnull # t)
(pjust # h)
(ptraceError "Ambiguous proposal")
)
(const pnothing)
# contexts
stakeRedeemer <- fst <$> ptryFromC redeemer
noProposalContext = pcon PNoProposal
pure $
popaque $
pmatch stakeRedeemer $ \case
PDestroy _ -> runStakeRedeemerHandler impl.onDestroy # noMetadataContext
PPermitVote _ -> runStakeRedeemerHandler impl.onPermitVote # noMetadataContext
PRetractVotes _ -> runStakeRedeemerHandler impl.onRetractVote # noMetadataContext
PClearDelegate _ -> runStakeRedeemerHandler impl.onClearDelegate # noMetadataContext
PDelegateTo ((pfield @"pkh" #) -> pkh) ->
runStakeRedeemerHandler impl.onDelegateTo
#$ mkRedeemerhandlerContext
#$ pcon
$ PSetDelegateTo pkh
PDepositWithdraw ((pfield @"delta" #) -> delta) ->
runStakeRedeemerHandler impl.onDepositWithdraw #$ mkRedeemerhandlerContext
#$ pcon
$ PDepositWithdrawDelta delta
proposalContext <-
pletC $
pif
pstMinted
newProposalContext
(pfromMaybe # noProposalContext # spendProposalContext)
--------------------------------------------------------------------------
-- Assemeble the redeemer handler context.
mkRedeemerhandlerContext <- pletC $
plam $ \redeemerContext ->
pcon $
PStakeRedeemerHandlerContext
stakeInputDatums
stakeOutputDatums
redeemerContext
sigContext
proposalContext
txInfo
noMetadataContext <-
pletC $
mkRedeemerhandlerContext
#$ pcon
$ PNoMetadata
--------------------------------------------------------------------------
-- Call the redeemer handler.
stakeRedeemer <- fst <$> ptryFromC redeemer
pure $
popaque $
pmatch stakeRedeemer $ \case
PDestroy _ -> runStakeRedeemerHandler impl.onDestroy # noMetadataContext
PPermitVote _ -> runStakeRedeemerHandler impl.onPermitVote # noMetadataContext
PRetractVotes _ -> runStakeRedeemerHandler impl.onRetractVote # noMetadataContext
PClearDelegate _ -> runStakeRedeemerHandler impl.onClearDelegate # noMetadataContext
PDelegateTo ((pfield @"pkh" #) -> pkh) ->
runStakeRedeemerHandler impl.onDelegateTo
#$ mkRedeemerhandlerContext
#$ pcon
$ PSetDelegateTo pkh
PDepositWithdraw ((pfield @"delta" #) -> delta) ->
runStakeRedeemerHandler impl.onDepositWithdraw #$ mkRedeemerhandlerContext
#$ pcon
$ PDepositWithdrawDelta delta
{- | Validator intended for Stake UTXOs to be locked by.
@ -617,14 +591,16 @@ mkStakeValidator
- The stakes must not be locked.
- Tx must be signed by the owner.
@since 0.1.0
== Arguments
Following arguments should be provided(in this order):
1. stake ST symbol
2. proposal ST assetclass
3. governor ST assetclass
@since 1.0.0
-}
stakeValidator ::
-- | Lazy precompiled scripts.
AgoraScripts ->
-- | See 'Agora.Governor.Governor.gtClassRef'.
Tagged GTTag AssetClass ->
ClosedTerm PValidator
stakeValidator :: ClosedTerm (PCurrencySymbol :--> PAssetClass :--> PAssetClass :--> PValidator)
stakeValidator =
mkStakeValidator $
StakeRedeemerImpl

21
agora/Agora/Treasury.hs
View file

@ -13,22 +13,23 @@ module Agora.Treasury (
) where
import Agora.AuthorityToken (singleAuthorityTokenBurned)
import Plutarch.Api.V1.Value (PValue)
import Plutarch.Api.V1.Value (PCurrencySymbol, PValue)
import Plutarch.Api.V2 (PScriptPurpose (PSpending), PValidator)
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
import Plutarch.TryFrom ()
import PlutusLedgerApi.V1.Value (CurrencySymbol)
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletFieldsC, pmatchC)
{- | Validator ensuring that transactions consuming the treasury
do so in a valid manner.
== Arguments
Following arguments should be provided(in this order):
1. authority token symbol
@since 0.1.0
-}
treasuryValidator ::
-- | Governance Authority Token that can unlock this validator.
CurrencySymbol ->
ClosedTerm PValidator
treasuryValidator gatCs' = plam $ \_ _ ctx' -> unTermCont $ do
ClosedTerm (PCurrencySymbol :--> PValidator)
treasuryValidator = plam $ \atSymbol _ _ ctx' -> unTermCont $ do
-- plet required fields from script context.
ctx <- pletFieldsC @["txInfo", "purpose"] ctx'
@ -40,9 +41,7 @@ treasuryValidator gatCs' = plam $ \_ _ ctx' -> unTermCont $ do
let mint :: Term _ (PValue _ _)
mint = txInfo.mint
gatCs <- pletC $ pconstant gatCs'
pguardC "A single authority token has been burned" $
singleAuthorityTokenBurned gatCs txInfo.inputs mint
singleAuthorityTokenBurned atSymbol txInfo.inputs mint
pure . popaque $ pconstant ()

29
agora/Agora/Utils.hs
View file

@ -12,9 +12,6 @@ module Agora.Utils (
validatorHashToAddress,
pltAsData,
withBuiltinPairAsData,
CompiledValidator (..),
CompiledMintingPolicy (..),
CompiledEffect (..),
pvalidatorHashToTokenName,
pscriptHashToTokenName,
scriptHashToTokenName,
@ -49,10 +46,8 @@ import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V2 (
Address (Address),
Credential (ScriptCredential),
MintingPolicy,
ScriptHash (ScriptHash),
TokenName (TokenName),
Validator,
ValidatorHash (ValidatorHash),
)
@ -128,30 +123,6 @@ withBuiltinPairAsData f p =
b = pfromData $ psndBuiltin # p
in f a b
{- | Type-safe wrapper for compiled plutus validator.
@since 0.2.0
-}
newtype CompiledValidator (datum :: Type) (redeemer :: Type) = CompiledValidator
{ getCompiledValidator :: Validator
}
{- | Type-safe wrapper for compiled plutus miting policy.
@since 0.2.0
-}
newtype CompiledMintingPolicy (redeemer :: Type) = CompiledMintingPolicy
{ getCompiledMintingPolicy :: MintingPolicy
}
{- | Type-safe wrapper for compiled plutus effect.
@since 0.2.0
-}
newtype CompiledEffect (datum :: Type) = CompiledEffect
{ getCompiledEffect :: Validator
}
-- | @since 1.0.0
plistEqualsBy ::
forall