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

Merge pull request #230 from Liqwid-Labs/seungheonoh/purslinker

Browse source 
Update types so that ply envlope can be used in Purescript
This commit is contained in:
SeungheonOh 2023-03-14 15:13:47 -05:00 • committed by GitHub
commit 1d3451cb5a
16 changed files with 163 additions and 106 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 Agora.Linker (linker)
import Data.Aeson qualified as Aeson import Data.Aeson qualified as Aeson
import Data.Default (def) 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.Export (exportMain)
import ScriptExport.Types ( import ScriptExport.Types (
Builders, Builders,
insertBuilder, insertBuilder,
insertScriptExportWithLinker, insertScriptExportWithLinker,
insertStaticBuilder,
) )
main :: IO () main :: IO ()
main = exportMain builders main = exportMain builders
rawScripts :: Config -> [TypedScriptEnvelope]
rawScripts conf =
either (error . show) id $ Bootstrap.agoraScripts' conf
builders :: Builders builders :: Builders
builders = builders =
mconcat mconcat
[ insertScriptExportWithLinker "agora" (Bootstrap.agoraScripts def) linker [ insertStaticBuilder "raw" (rawScripts (Config NoTracing))
, insertStaticBuilder "rawDebug" (rawScripts (Config DoTracing))
, insertScriptExportWithLinker "agora" (Bootstrap.agoraScripts def) linker
, insertScriptExportWithLinker , insertScriptExportWithLinker
"agoraDebug" "agoraDebug"
( Bootstrap.agoraScripts ( Bootstrap.agoraScripts

2
agora-specs/Property/Governor.hs
View file

@ -221,7 +221,7 @@ mkPolicyScript ctx = mustCompile (go # pconstant ctx)
go = loudEval $ go = loudEval $
plam $ \sc -> plam $ \sc ->
governorPolicy governorPolicy
# pconstant (view #gstOutRef governor) # pdata (pconstant (view #gstOutRef governor))
# pforgetData (pconstantData ()) # pforgetData (pconstantData ())
# sc # sc

4
agora/Agora/AuthorityToken.hs
View file

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

27
agora/Agora/Bootstrap.hs
View file

@ -4,7 +4,7 @@
Initialize a governance system Initialize a governance system
-} -}
module Agora.Bootstrap (agoraScripts, alwaysSucceedsPolicyRoledScript) where module Agora.Bootstrap (agoraScripts, agoraScripts', alwaysSucceedsPolicyRoledScript) where
import Agora.AuthorityToken (authorityTokenPolicy) import Agora.AuthorityToken (authorityTokenPolicy)
import Agora.Effect.GovernorMutation (mutateGovernorValidator) import Agora.Effect.GovernorMutation (mutateGovernorValidator)
@ -53,6 +53,31 @@ agoraScripts conf =
(Text, TypedScriptEnvelope) (Text, TypedScriptEnvelope)
envelope d t = (d, either (error . unpack) id $ mkEnvelope conf d t) envelope d t = (d, either (error . unpack) id $ mkEnvelope conf d t)
agoraScripts' :: Config -> Either Text [TypedScriptEnvelope]
agoraScripts' conf =
sequenceA
[ envelope "Governor Policy" governorPolicy
, envelope "Governor Validator" governorValidator
, envelope "Stake Policy" stakePolicy
, envelope "Stake Validator" stakeValidator
, envelope "Proposal Policy" proposalPolicy
, envelope "Proposal Validator" proposalValidator
, envelope "Treasury Validator" treasuryValidator
, envelope "Authority Token Policy" authorityTokenPolicy
, envelope "NoOp Validator" noOpValidator
, envelope "Treasury Withdrawal Validator" treasuryWithdrawalValidator
, envelope "Mutate Governor Validator" mutateGovernorValidator
, envelope "Always Succeeds Policy" $ ((plam $ \_ _ -> popaque $ pcon PUnit) :: Term s PMintingPolicy)
]
where
envelope ::
forall (pt :: S -> Type).
TypedWriter pt =>
Text ->
ClosedTerm pt ->
Either Text TypedScriptEnvelope
envelope = mkEnvelope conf
{- | A minting policy that always succeeds. {- | A minting policy that always succeeds.
NOTE(Emily, Jan 3rd 2023): Adding this in here because it's useful for testnet GT. 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 (PAsData PTxInfo) ->
Term s POpaque Term s POpaque
) -> ) ->
Term s (PTagged AuthorityTokenTag PCurrencySymbol) -> Term s (PAsData (PTagged AuthorityTokenTag PCurrencySymbol)) ->
Term s PValidator Term s PValidator
makeEffect f atSymbol = makeEffect f atSymbol' =
plam $ \datum _redeemer ctx' -> unTermCont $ do plam $ \datum _redeemer ctx' -> unTermCont $ do
atSymbol <- pletC $ pfromData atSymbol'
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
-- Convert input datum, PData, into desierable type -- Convert input datum, PData, into desierable type

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

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

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

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

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

@ -149,7 +149,7 @@ instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum)
-} -}
treasuryWithdrawalValidator :: treasuryWithdrawalValidator ::
forall (s :: S). forall (s :: S).
Term s (PTagged AuthorityTokenTag PCurrencySymbol :--> PValidator) Term s (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
treasuryWithdrawalValidator = plam $ treasuryWithdrawalValidator = plam $
makeEffect @(PAsData PTreasuryWithdrawalDatum) $ makeEffect @(PAsData PTreasuryWithdrawalDatum) $
\_cs (pfromData -> datum) effectInputRef txInfo -> unTermCont $ do \_cs (pfromData -> datum) 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 @since 1.0.0
-} -}
governorPolicy :: ClosedTerm (PTxOutRef :--> PMintingPolicy) governorPolicy :: ClosedTerm (PAsData PTxOutRef :--> PMintingPolicy)
governorPolicy = governorPolicy =
plam $ \initialSpend _ ctx -> unTermCont $ do plam $ \initialSpend _ ctx -> unTermCont $ do
PMinting ((pfield @"_0" #) -> gstSymbol) <- PMinting ((pfield @"_0" #) -> gstSymbol) <-
@ -121,7 +121,7 @@ governorPolicy =
txInfo txInfo
pguardC "Referenced utxo should be spent" $ pguardC "Referenced utxo should be spent" $
pisUTXOSpent # initialSpend # txInfoF.inputs pisUTXOSpent # pfromData initialSpend # txInfoF.inputs
pguardC "Exactly one token should be minted" $ pguardC "Exactly one token should be minted" $
let vMap = pfromData $ pto txInfoF.mint let vMap = pfromData $ pto txInfoF.mint
@ -258,15 +258,17 @@ governorPolicy =
governorValidator :: governorValidator ::
-- | Lazy precompiled scripts. -- | Lazy precompiled scripts.
ClosedTerm ClosedTerm
( PScriptHash ( PAsData PScriptHash
:--> PTagged StakeSTTag PAssetClassData :--> PAsData (PTagged StakeSTTag PAssetClassData)
:--> PTagged GovernorSTTag PCurrencySymbol :--> PAsData (PTagged GovernorSTTag PCurrencySymbol)
:--> PTagged ProposalSTTag PCurrencySymbol :--> PAsData (PTagged ProposalSTTag PCurrencySymbol)
:--> PTagged AuthorityTokenTag PCurrencySymbol :--> PAsData (PTagged AuthorityTokenTag PCurrencySymbol)
:--> PValidator :--> PValidator
) )
governorValidator = 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 ctxF <- pletAllC ctx
txInfo <- pletC $ pfromData ctxF.txInfo txInfo <- pletC $ pfromData ctxF.txInfo
txInfoF <- txInfoF <-
@ -315,7 +317,7 @@ governorValidator =
outputF.address outputF.address
governorInputF.address governorInputF.address
, ptraceIfFalse "Has governor ST" $ , ptraceIfFalse "Has governor ST" $
ptaggedSymbolValueOf # gstSymbol # outputF.value #== 1 ptaggedSymbolValueOf # pfromData gstSymbol # outputF.value #== 1
] ]
datum = datum =
@ -341,7 +343,7 @@ governorValidator =
flip (pletFields @'["value", "datum", "address"]) $ \txOutF -> flip (pletFields @'["value", "datum", "address"]) $ \txOutF ->
let isProposalUTxO = let isProposalUTxO =
(pfromJust #$ pscriptHashFromAddress # pfromData txOutF.address) (pfromJust #$ pscriptHashFromAddress # pfromData txOutF.address)
#== proposalScriptHash #== pfromData proposalScriptHash
#&& passetClassValueOf #&& passetClassValueOf
# pstClass # pstClass
# txOutF.value # txOutF.value
@ -398,7 +400,7 @@ governorValidator =
# "Stake input should present" # "Stake input should present"
#$ pfindJust #$ pfindJust
# ( presolveStakeInputDatum # ( presolveStakeInputDatum
# (ptoScottEncodingT # sstClass) # (ptoScottEncodingT # pfromData sstClass)
# txInfoF.datums # txInfoF.datums
) )
# pfromData txInfoF.inputs # pfromData txInfoF.inputs

89
agora/Agora/Linker.hs
View file

@ -12,6 +12,7 @@ import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
import Plutarch.Extra.ScriptContext (scriptHashToTokenName) import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
import PlutusLedgerApi.V2 (CurrencySymbol (CurrencySymbol), ScriptHash, TxOutRef, getScriptHash) import PlutusLedgerApi.V2 (CurrencySymbol (CurrencySymbol), ScriptHash, TxOutRef, getScriptHash)
import Ply ( import Ply (
AsData (AsData),
ScriptRole (MintingPolicyRole, ValidatorRole), ScriptRole (MintingPolicyRole, ValidatorRole),
(#), (#),
) )
@ -48,122 +49,122 @@ linker = do
govPol <- govPol <-
fetchTS fetchTS
@MintingPolicyRole @MintingPolicyRole
@'[TxOutRef] @'[AsData TxOutRef]
"agora:governorPolicy" "agora:governorPolicy"
govVal <- govVal <-
fetchTS fetchTS
@ValidatorRole @ValidatorRole
@'[ ScriptHash @'[ AsData ScriptHash
, Tagged StakeSTTag AssetClass , AsData (Tagged StakeSTTag AssetClass)
, Tagged GovernorSTTag CurrencySymbol , AsData (Tagged GovernorSTTag CurrencySymbol)
, Tagged ProposalSTTag CurrencySymbol , AsData (Tagged ProposalSTTag CurrencySymbol)
, Tagged AuthorityTokenTag CurrencySymbol , AsData (Tagged AuthorityTokenTag CurrencySymbol)
] ]
"agora:governorValidator" "agora:governorValidator"
stkPol <- stkPol <-
fetchTS fetchTS
@MintingPolicyRole @MintingPolicyRole
@'[Tagged GTTag AssetClass] @'[AsData (Tagged GTTag AssetClass)]
"agora:stakePolicy" "agora:stakePolicy"
stkVal <- stkVal <-
fetchTS fetchTS
@ValidatorRole @ValidatorRole
@'[ Tagged StakeSTTag CurrencySymbol @'[ AsData (Tagged StakeSTTag CurrencySymbol)
, Tagged ProposalSTTag AssetClass , AsData (Tagged ProposalSTTag AssetClass)
, Tagged GTTag AssetClass , AsData (Tagged GTTag AssetClass)
] ]
"agora:stakeValidator" "agora:stakeValidator"
prpPol <- prpPol <-
fetchTS @MintingPolicyRole fetchTS @MintingPolicyRole
@'[Tagged GovernorSTTag AssetClass] @'[AsData (Tagged GovernorSTTag AssetClass)]
"agora:proposalPolicy" "agora:proposalPolicy"
prpVal <- prpVal <-
fetchTS fetchTS
@ValidatorRole @ValidatorRole
@'[ Tagged StakeSTTag AssetClass @'[ AsData (Tagged StakeSTTag AssetClass)
, Tagged GovernorSTTag CurrencySymbol , AsData (Tagged GovernorSTTag CurrencySymbol)
, Tagged ProposalSTTag CurrencySymbol , AsData (Tagged ProposalSTTag CurrencySymbol)
, Integer , AsData Integer
] ]
"agora:proposalValidator" "agora:proposalValidator"
treVal <- treVal <-
fetchTS fetchTS
@ValidatorRole @ValidatorRole
@'[Tagged AuthorityTokenTag CurrencySymbol] @'[AsData (Tagged AuthorityTokenTag CurrencySymbol)]
"agora:treasuryValidator" "agora:treasuryValidator"
atkPol <- atkPol <-
fetchTS fetchTS
@MintingPolicyRole @MintingPolicyRole
@'[Tagged GovernorSTTag AssetClass] @'[AsData (Tagged GovernorSTTag AssetClass)]
"agora:authorityTokenPolicy" "agora:authorityTokenPolicy"
noOpVal <- noOpVal <-
fetchTS fetchTS
@ValidatorRole @ValidatorRole
@'[Tagged AuthorityTokenTag CurrencySymbol] @'[AsData (Tagged AuthorityTokenTag CurrencySymbol)]
"agora:noOpValidator" "agora:noOpValidator"
treaWithdrawalVal <- treaWithdrawalVal <-
fetchTS fetchTS
@ValidatorRole @ValidatorRole
@'[Tagged AuthorityTokenTag CurrencySymbol] @'[AsData (Tagged AuthorityTokenTag CurrencySymbol)]
"agora:treasuryWithdrawalValidator" "agora:treasuryWithdrawalValidator"
mutateGovVal <- mutateGovVal <-
fetchTS fetchTS
@ValidatorRole @ValidatorRole
@'[ ScriptHash @'[ AsData ScriptHash
, Tagged GovernorSTTag CurrencySymbol , AsData (Tagged GovernorSTTag CurrencySymbol)
, Tagged AuthorityTokenTag CurrencySymbol , AsData (Tagged AuthorityTokenTag CurrencySymbol)
] ]
"agora:mutateGovernorValidator" "agora:mutateGovernorValidator"
governor <- getParam governor <- getParam
let govPol' = govPol # governor.gstOutRef let govPol' = govPol # AsData governor.gstOutRef
govVal' = govVal' =
govVal govVal
# propValHash # AsData propValHash
# Tagged sstAssetClass # AsData (Tagged sstAssetClass)
# Tagged gstSymbol # AsData (Tagged gstSymbol)
# Tagged pstSymbol # AsData (Tagged pstSymbol)
# Tagged atSymbol # AsData (Tagged atSymbol)
gstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript govPol' gstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript govPol'
gstAssetClass = gstAssetClass =
AssetClass gstSymbol "" AssetClass gstSymbol ""
govValHash = scriptHash $ toScript govVal' govValHash = scriptHash $ toScript govVal'
atPol' = atkPol # Tagged gstAssetClass atPol' = atkPol # AsData (Tagged gstAssetClass)
atSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript atPol' atSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript atPol'
propPol' = prpPol # Tagged gstAssetClass propPol' = prpPol # AsData (Tagged gstAssetClass)
propVal' = propVal' =
prpVal prpVal
# Tagged sstAssetClass # AsData (Tagged sstAssetClass)
# Tagged gstSymbol # AsData (Tagged gstSymbol)
# Tagged pstSymbol # AsData (Tagged pstSymbol)
# governor.maximumCosigners # AsData governor.maximumCosigners
propValHash = scriptHash $ toScript propVal' propValHash = scriptHash $ toScript propVal'
pstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript propPol' pstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript propPol'
pstAssetClass = AssetClass pstSymbol "" pstAssetClass = AssetClass pstSymbol ""
stakPol' = stkPol # governor.gtClassRef stakPol' = stkPol # AsData governor.gtClassRef
stakVal' = stakVal' =
stkVal stkVal
# Tagged sstSymbol # AsData (Tagged sstSymbol)
# Tagged pstAssetClass # AsData (Tagged pstAssetClass)
# governor.gtClassRef # AsData governor.gtClassRef
sstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript stakPol' sstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript stakPol'
stakValTokenName = stakValTokenName =
scriptHashToTokenName $ scriptHash $ toScript stakVal' scriptHashToTokenName $ scriptHash $ toScript stakVal'
sstAssetClass = AssetClass sstSymbol stakValTokenName sstAssetClass = AssetClass sstSymbol stakValTokenName
treaVal' = treVal # Tagged atSymbol treaVal' = treVal # AsData (Tagged atSymbol)
noOpVal' = noOpVal # Tagged atSymbol noOpVal' = noOpVal # AsData (Tagged atSymbol)
treaWithdrawalVal' = treaWithdrawalVal # Tagged atSymbol treaWithdrawalVal' = treaWithdrawalVal # AsData (Tagged atSymbol)
mutateGovVal' = mutateGovVal' =
mutateGovVal mutateGovVal
# govValHash # AsData govValHash
# Tagged gstSymbol # AsData (Tagged gstSymbol)
# Tagged atSymbol # AsData (Tagged atSymbol)
return $ return $
ScriptExport ScriptExport

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

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

12
agora/Agora/SafeMoney.hs
View file

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

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

@ -138,7 +138,7 @@ import Prelude hiding (Num ((+)))
@since 1.0.0 @since 1.0.0
-} -}
stakePolicy :: stakePolicy ::
ClosedTerm (PTagged GTTag PAssetClassData :--> PMintingPolicy) ClosedTerm (PAsData (PTagged GTTag PAssetClassData) :--> PMintingPolicy)
stakePolicy = stakePolicy =
plam $ \gtClass _redeemer ctx' -> unTermCont $ do plam $ \gtClass _redeemer ctx' -> unTermCont $ do
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
@ -207,7 +207,7 @@ stakePolicy =
(#&&) (#&&)
[ ptraceIfFalse "Stake ouput has expected amount of stake token" $ [ ptraceIfFalse "Stake ouput has expected amount of stake token" $
passetClassValueOfT passetClassValueOfT
# (ptoScottEncodingT # gtClass) # (ptoScottEncodingT # pfromData gtClass)
# outputF.value # outputF.value
#== pfromData datumF.stakedAmount #== pfromData datumF.stakedAmount
, ptraceIfFalse "Stake Owner should sign the transaction" $ , ptraceIfFalse "Stake Owner should sign the transaction" $
@ -656,9 +656,9 @@ mkStakeValidator impl sstSymbol pstClass gtClass =
-} -}
stakeValidator :: stakeValidator ::
ClosedTerm ClosedTerm
( PTagged StakeSTTag PCurrencySymbol ( PAsData (PTagged StakeSTTag PCurrencySymbol)
:--> PTagged ProposalSTTag PAssetClassData :--> PAsData (PTagged ProposalSTTag PAssetClassData)
:--> PTagged GTTag PAssetClassData :--> PAsData (PTagged GTTag PAssetClassData)
:--> PValidator :--> PValidator
) )
stakeValidator = stakeValidator =
@ -673,6 +673,6 @@ stakeValidator =
, onClearDelegate = pclearDelegate , onClearDelegate = pclearDelegate
} }
) )
sstSymbol (pfromData sstSymbol)
(ptoScottEncodingT # pstClass) (ptoScottEncodingT # pfromData pstClass)
(ptoScottEncodingT # gstClass) (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 @since 1.0.0
-} -}
treasuryValidator :: treasuryValidator ::
ClosedTerm (PTagged AuthorityTokenTag PCurrencySymbol :--> PValidator) ClosedTerm (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
treasuryValidator = plam $ \atSymbol _ _ ctx' -> unTermCont $ do treasuryValidator = plam $ \atSymbol _ _ ctx' -> unTermCont $ do
-- plet required fields from script context. -- plet required fields from script context.
ctx <- pletFieldsC @["txInfo", "purpose"] ctx' ctx <- pletFieldsC @["txInfo", "purpose"] ctx'
@ -44,6 +44,6 @@ treasuryValidator = plam $ \atSymbol _ _ ctx' -> unTermCont $ do
mint = txInfo.mint mint = txInfo.mint
pguardC "A single authority token has been burned" $ pguardC "A single authority token has been burned" $
singleAuthorityTokenBurned atSymbol txInfo.inputs mint singleAuthorityTokenBurned (pfromData atSymbol) txInfo.inputs mint
pure . popaque $ pconstant () pure . popaque $ pconstant ()

18
flake.lock generated
View file

@ -3598,11 +3598,11 @@
"ply": "ply" "ply": "ply"
}, },
"locked": { "locked": {
"lastModified": 1674830336, "lastModified": 1678823448,
"narHash": "sha256-KIJH4kJzBIaDqV3N/f8Dolt//GBc4Cwam7+10HKGg18=", "narHash": "sha256-vdaA8lP0AlUIKLlWfwkLoqix3eMxvFP4cDWEeyoFHHM=",
"owner": "Liqwid-Labs", "owner": "Liqwid-Labs",
"repo": "liqwid-libs", "repo": "liqwid-libs",
"rev": "45f591ddfbf6342f958c4ead6dc6175965f8ce1d", "rev": "050b2b6a3ee29dbba5bd43c38786b2947f45b2cb",
"type": "github" "type": "github"
}, },
"original": { "original": {
@ -6290,16 +6290,16 @@
"pre-commit-hooks": "pre-commit-hooks" "pre-commit-hooks": "pre-commit-hooks"
}, },
"locked": { "locked": {
"lastModified": 1672869303, "lastModified": 1677814602,
"narHash": "sha256-hX2nxIpyJWTqQnllc9bLIqQH3LXtLxof56TYkMPSOZ0=", "narHash": "sha256-evpKJ5aWZGlr1Y5xV9chmG6D/Vx2OdAjzBdLtctXPXo=",
"owner": "mlabs-haskell", "owner": "liqwid-labs",
"repo": "ply", "repo": "ply",
"rev": "2cda3b44f87c659980bea2bc0b4a822d1e9eaef4", "rev": "8e686d78cd5a498df577376a502b49efa3e06fd8",
"type": "github" "type": "github"
}, },
"original": { "original": {
"owner": "mlabs-haskell", "owner": "liqwid-labs",
"ref": "master", "ref": "seungheonoh/purs",
"repo": "ply", "repo": "ply",
"type": "github" "type": "github"
} }

22
flake.nix
View file

@ -19,7 +19,8 @@
inputs.nixpkgs-latest.follows = "nixpkgs-latest"; inputs.nixpkgs-latest.follows = "nixpkgs-latest";
}; };
liqwid-libs.url = "github:Liqwid-Labs/liqwid-libs"; liqwid-libs.url =
"github:Liqwid-Labs/liqwid-libs";
}; };
outputs = inputs@{ self, flake-parts, ... }: outputs = inputs@{ self, flake-parts, ... }:
@ -53,6 +54,25 @@
]; ];
}; };
ci.required = [ "all_onchain" ]; ci.required = [ "all_onchain" ];
packages.export =
pkgs.stdenv.mkDerivation {
name = "export";
src = ./.;
buildInput = [
self'.packages."agora:exe:agora-scripts"
];
buildPhase = ''
export PATH=$PATH:${self'.packages."agora:exe:agora-scripts"}/bin
agora-scripts file --builder raw
agora-scripts file --builder rawDebug
'';
installPhase = ''
NAME=${if self ? rev then self.shortRev else "dirty"}
mkdir $out
cp raw.json $out/agora-"$NAME".json
cp rawDebug.json $out/agora-debug-"$NAME".json
'';
};
}; };
flake.hydraJobs.x86_64-linux = ( flake.hydraJobs.x86_64-linux = (