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

Update types so that ply envlope can be used in Purescript

Browse source
This commit is contained in:
Seungheon Oh 2023-03-04 00:52:10 -06:00
parent 0953580347
commit 13151bb6fb
14 changed files with 115 additions and 61 deletions
Download patch file Download diff file Expand all files Collapse all files

12
agora-scripts/Main.hs
View file

@ -13,21 +13,29 @@ import Agora.Bootstrap qualified as Bootstrap
import Agora.Linker (linker)
import Data.Aeson qualified as Aeson
import Data.Default (def)
import Plutarch (Config (Config), TracingMode (DoTracing))
import Plutarch (Config (Config), TracingMode (DoTracing, NoTracing))
import Ply (TypedScriptEnvelope)
import ScriptExport.Export (exportMain)
import ScriptExport.Types (
Builders,
insertBuilder,
insertScriptExportWithLinker,
insertStaticBuilder,
)
main :: IO ()
main = exportMain builders
rawScripts :: Config -> [TypedScriptEnvelope]
rawScripts conf =
either (error . show) id $ Bootstrap.agoraScripts' conf
builders :: Builders
builders =
mconcat
[ insertScriptExportWithLinker "agora" (Bootstrap.agoraScripts def) linker
[ insertStaticBuilder "raw" (rawScripts (Config NoTracing))
, insertStaticBuilder "rawDebug" (rawScripts (Config DoTracing))
, insertScriptExportWithLinker "agora" (Bootstrap.agoraScripts def) linker
, insertScriptExportWithLinker
"agoraDebug"
( Bootstrap.agoraScripts

4
agora/Agora/AuthorityToken.hs
View file

@ -146,7 +146,7 @@ singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
@since 0.1.0
-}
authorityTokenPolicy :: ClosedTerm (PTagged GovernorSTTag PAssetClassData :--> PMintingPolicy)
authorityTokenPolicy :: ClosedTerm (PAsData (PTagged GovernorSTTag PAssetClassData) :--> PMintingPolicy)
authorityTokenPolicy =
plam $ \gstAssetClass _redeemer ctx -> unTermCont $ do
ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
@ -176,7 +176,7 @@ authorityTokenPolicy =
passertPJust
# "GST should move"
#$ presolveGovernorRedeemer
# (ptoScottEncodingT # gstAssetClass)
# (ptoScottEncodingT # pfromData gstAssetClass)
# pfromData txInfoF.inputs
# txInfoF.redeemers
pguardC "Governor redeemr correct" $

26
agora/Agora/Bootstrap.hs
View file

@ -4,7 +4,7 @@
Initialize a governance system
-}
module Agora.Bootstrap (agoraScripts, alwaysSucceedsPolicyRoledScript) where
module Agora.Bootstrap (agoraScripts, agoraScripts', alwaysSucceedsPolicyRoledScript) where
import Agora.AuthorityToken (authorityTokenPolicy)
import Agora.Effect.GovernorMutation (mutateGovernorValidator)
@ -53,6 +53,30 @@ agoraScripts conf =
(Text, TypedScriptEnvelope)
envelope d t = (d, either (error . unpack) id $ mkEnvelope conf d t)
agoraScripts' :: Config -> Either Text [TypedScriptEnvelope]
agoraScripts' conf =
sequenceA
[ 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
envelope ::
forall (pt :: S -> Type).
TypedWriter pt =>
Text ->
ClosedTerm pt ->
Either Text TypedScriptEnvelope
envelope = mkEnvelope conf
{- | A minting policy that always succeeds.
NOTE(Emily, Jan 3rd 2023): Adding this in here because it's useful for testnet GT.

5
agora/Agora/Effect.hs
View file

@ -38,10 +38,11 @@ makeEffect ::
Term s (PAsData PTxInfo) ->
Term s POpaque
) ->
Term s (PTagged AuthorityTokenTag PCurrencySymbol) ->
Term s (PAsData (PTagged AuthorityTokenTag PCurrencySymbol)) ->
Term s PValidator
makeEffect f atSymbol =
makeEffect f atSymbol' =
plam $ \datum _redeemer ctx' -> unTermCont $ do
atSymbol <- pletC $ pfromData atSymbol'
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
-- Convert input datum, PData, into desierable type

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

@ -151,9 +151,9 @@ deriving anyclass instance PTryFrom PData PMutateGovernorDatum
-}
mutateGovernorValidator ::
ClosedTerm
( PScriptHash
:--> PTagged GovernorSTTag PCurrencySymbol
:--> PTagged AuthorityTokenTag PCurrencySymbol
( PAsData PScriptHash
:--> PAsData (PTagged GovernorSTTag PCurrencySymbol)
:--> PAsData (PTagged AuthorityTokenTag PCurrencySymbol)
:--> PValidator
)
mutateGovernorValidator =
@ -189,7 +189,7 @@ mutateGovernorValidator =
(#&&)
[ ptraceIfFalse "Governor UTxO should carry GST" $
ptaggedSymbolValueOf
# gstSymbol
# pfromData gstSymbol
# (pfield @"value" # inputF.resolved)
#== 1
, ptraceIfFalse "Can only modify the pinned governor" $
@ -200,7 +200,7 @@ mutateGovernorValidator =
#$ pscriptHashFromAddress
#$ pfield @"address"
# inputF.resolved
in inputScriptHash #== govValidatorHash
in inputScriptHash #== pfromData govValidatorHash
]
in isGovernorInput
)

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

@ -40,7 +40,7 @@ instance PTryFrom PData (PAsData PNoOp)
@since 1.0.0
-}
noOpValidator :: ClosedTerm (PTagged AuthorityTokenTag PCurrencySymbol :--> PValidator)
noOpValidator :: ClosedTerm (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
noOpValidator = plam $
makeEffect $
\_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())

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

@ -134,7 +134,7 @@ instance PTryFrom PData PTreasuryWithdrawalDatum
-}
treasuryWithdrawalValidator ::
forall (s :: S).
Term s (PTagged AuthorityTokenTag PCurrencySymbol :--> PValidator)
Term s (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
treasuryWithdrawalValidator = plam $
makeEffect $
\_cs (datum :: Term _ PTreasuryWithdrawalDatum) effectInputRef txInfo -> unTermCont $ do

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

@ -102,7 +102,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
@since 1.0.0
-}
governorPolicy :: ClosedTerm (PTxOutRef :--> PMintingPolicy)
governorPolicy :: ClosedTerm (PAsData PTxOutRef :--> PMintingPolicy)
governorPolicy =
plam $ \initialSpend _ ctx -> unTermCont $ do
PMinting ((pfield @"_0" #) -> gstSymbol) <-
@ -121,7 +121,7 @@ governorPolicy =
txInfo
pguardC "Referenced utxo should be spent" $
pisUTXOSpent # initialSpend # txInfoF.inputs
pisUTXOSpent # pfromData initialSpend # txInfoF.inputs
pguardC "Exactly one token should be minted" $
let vMap = pfromData $ pto txInfoF.mint
@ -257,15 +257,17 @@ governorPolicy =
governorValidator ::
-- | Lazy precompiled scripts.
ClosedTerm
( PScriptHash
:--> PTagged StakeSTTag PAssetClassData
:--> PTagged GovernorSTTag PCurrencySymbol
:--> PTagged ProposalSTTag PCurrencySymbol
:--> PTagged AuthorityTokenTag PCurrencySymbol
( PAsData PScriptHash
:--> PAsData (PTagged StakeSTTag PAssetClassData)
:--> PAsData (PTagged GovernorSTTag PCurrencySymbol)
:--> PAsData (PTagged ProposalSTTag PCurrencySymbol)
:--> PAsData (PTagged AuthorityTokenTag PCurrencySymbol)
:--> PValidator
)
governorValidator =
plam $ \proposalScriptHash sstClass gstSymbol pstSymbol atSymbol datum redeemer ctx -> unTermCont $ do
plam $ \proposalScriptHash sstClass gstSymbol pstSymbol' atSymbol' datum redeemer ctx -> unTermCont $ do
atSymbol <- pletC $ pfromData atSymbol'
pstSymbol <- pletC $ pfromData pstSymbol'
ctxF <- pletAllC ctx
txInfo <- pletC $ pfromData ctxF.txInfo
txInfoF <-
@ -314,7 +316,7 @@ governorValidator =
outputF.address
governorInputF.address
, ptraceIfFalse "Has governor ST" $
ptaggedSymbolValueOf # gstSymbol # outputF.value #== 1
ptaggedSymbolValueOf # pfromData gstSymbol # outputF.value #== 1
]
datum =
@ -339,7 +341,7 @@ governorValidator =
flip (pletFields @'["value", "datum", "address"]) $ \txOutF ->
let isProposalUTxO =
(pfromJust #$ pscriptHashFromAddress # pfromData txOutF.address)
#== proposalScriptHash
#== pfromData proposalScriptHash
#&& passetClassValueOf
# pstClass
# txOutF.value
@ -396,7 +398,7 @@ governorValidator =
# "Stake input should present"
#$ pfindJust
# ( presolveStakeInputDatum
# (ptoScottEncodingT # sstClass)
# (ptoScottEncodingT # pfromData sstClass)
# txInfoF.datums
)
# pfromData txInfoF.inputs

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

@ -113,7 +113,7 @@ import "plutarch-extra" Plutarch.Extra.Map (pupdate)
@since 1.0.0
-}
proposalPolicy :: ClosedTerm (PTagged GovernorSTTag PAssetClassData :--> PMintingPolicy)
proposalPolicy :: ClosedTerm (PAsData (PTagged GovernorSTTag PAssetClassData) :--> PMintingPolicy)
proposalPolicy =
plam $ \gstAssetClass _redeemer ctx -> unTermCont $ do
ctxF <- pletAllC ctx
@ -137,7 +137,7 @@ proposalPolicy =
passertPJust
# "GST should move"
#$ presolveGovernorRedeemer
# (ptoScottEncodingT # gstAssetClass)
# (ptoScottEncodingT # pfromData gstAssetClass)
# pfromData txInfoF.inputs
# txInfoF.redeemers
@ -224,10 +224,10 @@ instance DerivePlutusType PStakeInputsContext where
-}
proposalValidator ::
ClosedTerm
( PTagged StakeSTTag PAssetClassData
:--> PTagged GovernorSTTag PCurrencySymbol
:--> PTagged ProposalSTTag PCurrencySymbol
:--> PInteger
( PAsData (PTagged StakeSTTag PAssetClassData)
:--> PAsData (PTagged GovernorSTTag PCurrencySymbol)
:--> PAsData (PTagged ProposalSTTag PCurrencySymbol)
:--> PAsData PInteger
:--> PValidator
)
proposalValidator =
@ -289,7 +289,7 @@ proposalValidator =
outputF.address
proposalInputF.address
, ptraceIfFalse "Has proposal ST" $
ptaggedSymbolValueOf # pstSymbol # outputF.value #== 1
ptaggedSymbolValueOf # pfromData pstSymbol # outputF.value #== 1
]
handleProposalUTxO =
@ -335,7 +335,7 @@ proposalValidator =
resolveStakeInputDatum <-
pletC $
presolveStakeInputDatum
# (ptoScottEncodingT # sstClass)
# (ptoScottEncodingT # pfromData sstClass)
# txInfoF.datums
spendStakes' :: Term _ ((PStakeInputsContext :--> PUnit) :--> PUnit) <-
@ -450,7 +450,7 @@ proposalValidator =
# proposalInputDatumF.cosigners
pguardC "Less cosigners than maximum limit" $
plength # updatedSigs #<= maximumCosigners
plength # updatedSigs #<= pfromData maximumCosigners
pguardC "Meet minimum GT requirement" $
pfromData thresholdsF.cosign #<= stakeF.stakedAmount
@ -741,7 +741,7 @@ proposalValidator =
. (pfield @"resolved" #) ->
value
) ->
ptaggedSymbolValueOf # gstSymbol # value #== 1
ptaggedSymbolValueOf # pfromData gstSymbol # value #== 1
)
# pfromData txInfoF.inputs

12
agora/Agora/SafeMoney.hs
View file

@ -22,37 +22,37 @@ import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
@since 0.1.0
-}
data GTTag
type GTTag = "GTTag"
{- | ADA.
@since 0.1.0
-}
data ADATag
type ADATag = "ADATag"
{- | Governor ST token.
@since 0.1.0
-}
data GovernorSTTag
type GovernorSTTag = "GovernorSTTag"
{- | Stake ST token.
@since 0.1.0
-}
data StakeSTTag
type StakeSTTag = "StakeSTTag"
{- | Proposal ST token.
@since 0.1.0
-}
data ProposalSTTag
type ProposalSTTag = "ProposalSTTag"
{- | Authority token.
@since 1.0.0
-}
data AuthorityTokenTag
type AuthorityTokenTag = "AuthorityTokenTag"
{- | Resolves ada tags.

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

@ -138,7 +138,7 @@ import Prelude hiding (Num ((+)))
@since 1.0.0
-}
stakePolicy ::
ClosedTerm (PTagged GTTag PAssetClassData :--> PMintingPolicy)
ClosedTerm (PAsData (PTagged GTTag PAssetClassData) :--> PMintingPolicy)
stakePolicy =
plam $ \gtClass _redeemer ctx' -> unTermCont $ do
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
@ -207,7 +207,7 @@ stakePolicy =
(#&&)
[ ptraceIfFalse "Stake ouput has expected amount of stake token" $
passetClassValueOfT
# (ptoScottEncodingT # gtClass)
# (ptoScottEncodingT # pfromData gtClass)
# outputF.value
#== pfromData datumF.stakedAmount
, ptraceIfFalse "Stake Owner should sign the transaction" $
@ -656,9 +656,9 @@ mkStakeValidator impl sstSymbol pstClass gtClass =
-}
stakeValidator ::
ClosedTerm
( PTagged StakeSTTag PCurrencySymbol
:--> PTagged ProposalSTTag PAssetClassData
:--> PTagged GTTag PAssetClassData
( PAsData (PTagged StakeSTTag PCurrencySymbol)
:--> PAsData (PTagged ProposalSTTag PAssetClassData)
:--> PAsData (PTagged GTTag PAssetClassData)
:--> PValidator
)
stakeValidator =
@ -673,6 +673,6 @@ stakeValidator =
, onClearDelegate = pclearDelegate
}
)
sstSymbol
(ptoScottEncodingT # pstClass)
(ptoScottEncodingT # gstClass)
(pfromData sstSymbol)
(ptoScottEncodingT # pfromData pstClass)
(ptoScottEncodingT # pfromData gstClass)

4
agora/Agora/Treasury.hs
View file

@ -30,7 +30,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletFieldsC, pm
@since 1.0.0
-}
treasuryValidator ::
ClosedTerm (PTagged AuthorityTokenTag PCurrencySymbol :--> PValidator)
ClosedTerm (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
treasuryValidator = plam $ \atSymbol _ _ ctx' -> unTermCont $ do
-- plet required fields from script context.
ctx <- pletFieldsC @["txInfo", "purpose"] ctx'
@ -44,6 +44,6 @@ treasuryValidator = plam $ \atSymbol _ _ ctx' -> unTermCont $ do
mint = txInfo.mint
pguardC "A single authority token has been burned" $
singleAuthorityTokenBurned atSymbol txInfo.inputs mint
singleAuthorityTokenBurned (pfromData atSymbol) txInfo.inputs mint
pure . popaque $ pconstant ()

37
flake.lock generated
View file

@ -1437,6 +1437,23 @@
"type": "github"
}
},
"easy-purescript-nix": {
"flake": false,
"locked": {
"lastModified": 1666686938,
"narHash": "sha256-/UOLRdnEhIOcxcm5ouOipOiSgHRzJde0ccAx4xB1dnU=",
"owner": "justinwoo",
"repo": "easy-purescript-nix",
"rev": "da7acb2662961fd355f0a01a25bd32bf33577fa8",
"type": "github"
},
"original": {
"owner": "justinwoo",
"repo": "easy-purescript-nix",
"rev": "da7acb2662961fd355f0a01a25bd32bf33577fa8",
"type": "github"
}
},
"ema": {
"flake": false,
"locked": {
@ -3598,15 +3615,16 @@
"ply": "ply"
},
"locked": {
"lastModified": 1674830336,
"narHash": "sha256-KIJH4kJzBIaDqV3N/f8Dolt//GBc4Cwam7+10HKGg18=",
"lastModified": 1677208361,
"narHash": "sha256-b+mflc7SI9Iwben5BGxJJZBLeCvIzc5s2zWTvgPIuzo=",
"owner": "Liqwid-Labs",
"repo": "liqwid-libs",
"rev": "45f591ddfbf6342f958c4ead6dc6175965f8ce1d",
"rev": "9d0ba961872c2691853ec5683fc3ee2c48b2cc6f",
"type": "github"
},
"original": {
"owner": "Liqwid-Labs",
"ref": "seungheonoh/bumpPly",
"repo": "liqwid-libs",
"type": "github"
}
@ -6279,6 +6297,7 @@
"ply": {
"inputs": {
"CHaP": "CHaP_2",
"easy-purescript-nix": "easy-purescript-nix",
"flake-utils": "flake-utils_13",
"haskellNix": "haskellNix",
"nixpkgs": [
@ -6290,16 +6309,16 @@
"pre-commit-hooks": "pre-commit-hooks"
},
"locked": {
"lastModified": 1672869303,
"narHash": "sha256-hX2nxIpyJWTqQnllc9bLIqQH3LXtLxof56TYkMPSOZ0=",
"owner": "mlabs-haskell",
"lastModified": 1676952116,
"narHash": "sha256-BuiXDtCxOZQCs0hHhBtHGNBIxFTZxbSSp+f0U8kP/+c=",
"owner": "liqwid-labs",
"repo": "ply",
"rev": "2cda3b44f87c659980bea2bc0b4a822d1e9eaef4",
"rev": "623c017d2867147022283c6d4f6886a77bced09e",
"type": "github"
},
"original": {
"owner": "mlabs-haskell",
"ref": "master",
"owner": "liqwid-labs",
"ref": "seungheonoh/purs",
"repo": "ply",
"type": "github"
}

2
flake.nix
View file

@ -19,7 +19,7 @@
inputs.nixpkgs-latest.follows = "nixpkgs-latest";
};
liqwid-libs.url = "github:Liqwid-Labs/liqwid-libs";
liqwid-libs.url = "github:Liqwid-Labs/liqwid-libs?ref=seungheonoh/bumpPly";
};
outputs = inputs@{ self, flake-parts, ... }: