Merge branch 'staging' into seungheonoh/updatepse
This commit is contained in:
SeungheonOh
GitHub
commit
dac9dc2394
42 changed files with 2344 additions and 1716 deletions
|
|
@ -11,10 +11,9 @@ module Agora.AuthorityToken (
|
|||
singleAuthorityTokenBurned,
|
||||
) where
|
||||
|
||||
import Agora.Utils (
|
||||
passert,
|
||||
psymbolValueOf',
|
||||
)
|
||||
import Agora.Governor (PGovernorRedeemer (PMintGATs), presolveGovernorRedeemer)
|
||||
import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag)
|
||||
import Agora.Utils (ptag, ptaggedSymbolValueOf, ptoScottEncodingT, puntag)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (..),
|
||||
PCurrencySymbol (..),
|
||||
|
|
@ -26,17 +25,16 @@ import Plutarch.Api.V2 (
|
|||
KeyGuarantees,
|
||||
PAddress (PAddress),
|
||||
PMintingPolicy,
|
||||
PScriptContext (PScriptContext),
|
||||
PScriptPurpose (PMinting),
|
||||
PTxInInfo (PTxInInfo),
|
||||
PTxInfo (PTxInfo),
|
||||
PTxOut (PTxOut),
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (PAssetClassData, ptoScottEncoding)
|
||||
import Plutarch.Extra.AssetClass (PAssetClassData)
|
||||
import Plutarch.Extra.Bool (passert)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (plookupAssoc)
|
||||
import Plutarch.Extra.Maybe (pfromJust)
|
||||
import Plutarch.Extra.ScriptContext (pisTokenSpent)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pfromJust)
|
||||
import Plutarch.Extra.Sum (PSum (PSum))
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
||||
pguardC,
|
||||
pletC,
|
||||
|
|
@ -44,7 +42,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
|||
pmatchC,
|
||||
)
|
||||
import Plutarch.Extra.Traversable (pfoldMap)
|
||||
import Plutarch.Extra.Value (psymbolValueOf)
|
||||
import Plutarch.Extra.Value (psymbolValueOf')
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -66,7 +64,7 @@ import Plutarch.Extra.Value (psymbolValueOf)
|
|||
|
||||
@since 1.0.0
|
||||
-}
|
||||
authorityTokensValidIn :: forall (s :: S). Term s (PCurrencySymbol :--> PTxOut :--> PBool)
|
||||
authorityTokensValidIn :: forall (s :: S). Term s (PTagged AuthorityTokenTag PCurrencySymbol :--> PTxOut :--> PBool)
|
||||
authorityTokensValidIn = phoistAcyclic $
|
||||
plam $ \authorityTokenSym txOut'' -> unTermCont $ do
|
||||
PTxOut txOut' <- pmatchC txOut''
|
||||
|
|
@ -75,7 +73,7 @@ authorityTokensValidIn = phoistAcyclic $
|
|||
PValue value' <- pmatchC txOut.value
|
||||
PMap value <- pmatchC value'
|
||||
pure $
|
||||
pmatch (plookupAssoc # pfstBuiltin # psndBuiltin # pdata authorityTokenSym # value) $ \case
|
||||
pmatch (plookupAssoc # pfstBuiltin # psndBuiltin # pdata (puntag authorityTokenSym) # value) $ \case
|
||||
PJust (pfromData -> _tokenMap') ->
|
||||
pmatch (pfield @"credential" # address) $ \case
|
||||
PPubKeyCredential _ ->
|
||||
|
|
@ -97,13 +95,13 @@ authorityTokensValidIn = phoistAcyclic $
|
|||
-}
|
||||
singleAuthorityTokenBurned ::
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
Term s PCurrencySymbol ->
|
||||
Term s (PTagged AuthorityTokenTag PCurrencySymbol) ->
|
||||
Term s (PBuiltinList PTxInInfo) ->
|
||||
Term s (PValue keys amounts) ->
|
||||
Term s PBool
|
||||
singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
|
||||
let gatAmountMinted :: Term _ PInteger
|
||||
gatAmountMinted = psymbolValueOf # gatCs # mint
|
||||
gatAmountMinted = ptaggedSymbolValueOf # gatCs # mint
|
||||
|
||||
let inputsWithGAT =
|
||||
pfoldMap
|
||||
|
|
@ -119,12 +117,13 @@ singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
|
|||
$ resolved
|
||||
|
||||
pure . pcon . PSum $
|
||||
psymbolValueOf
|
||||
ptaggedSymbolValueOf
|
||||
# gatCs
|
||||
#$ pfield @"value"
|
||||
#$ resolved
|
||||
)
|
||||
# inputs
|
||||
|
||||
pure $
|
||||
foldr1
|
||||
(#&&)
|
||||
|
|
@ -147,35 +146,46 @@ singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
authorityTokenPolicy :: ClosedTerm (PAssetClassData :--> PMintingPolicy)
|
||||
authorityTokenPolicy :: ClosedTerm (PTagged GovernorSTTag PAssetClassData :--> 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
|
||||
govTokenSpent = pisTokenSpent # (ptoScottEncoding # atAssetClass) # inputs
|
||||
plam $ \gstAssetClass _redeemer ctx -> unTermCont $ do
|
||||
ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
|
||||
txInfoF <-
|
||||
pletFieldsC
|
||||
@'[ "inputs"
|
||||
, "mint"
|
||||
, "outputs"
|
||||
, "redeemers"
|
||||
]
|
||||
ctxF.txInfo
|
||||
|
||||
PMinting ownSymbol' <- pmatchC $ pfromData ctx.purpose
|
||||
PMinting ownSymbol' <- pmatchC $ pfromData ctxF.purpose
|
||||
|
||||
let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
|
||||
let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
|
||||
|
||||
PPair mintedATs burntATs <-
|
||||
pmatchC $ pfromJust #$ psymbolValueOf' # ownSymbol # txInfo.mint
|
||||
PPair mintedATs burntATs <-
|
||||
pmatchC $ pfromJust #$ psymbolValueOf' # ownSymbol # txInfoF.mint
|
||||
|
||||
pure $
|
||||
popaque $
|
||||
pif
|
||||
(0 #< mintedATs)
|
||||
( unTermCont $ do
|
||||
pguardC "No GAT burnt" $ 0 #== burntATs
|
||||
pguardC "Parent token did not move in minting GATs" govTokenSpent
|
||||
pguardC "All outputs only emit valid GATs" $
|
||||
pall
|
||||
# plam
|
||||
(authorityTokensValidIn # ownSymbol #)
|
||||
# txInfo.outputs
|
||||
pure $ pconstant ()
|
||||
)
|
||||
(passert "No GAT minted" (0 #== mintedATs) (pconstant ()))
|
||||
pure $
|
||||
popaque $
|
||||
pif
|
||||
(0 #< mintedATs)
|
||||
( unTermCont $ do
|
||||
pguardC "No GAT burnt" $ 0 #== burntATs
|
||||
let governorRedeemer =
|
||||
passertPJust
|
||||
# "GST should move"
|
||||
#$ presolveGovernorRedeemer
|
||||
# (ptoScottEncodingT # gstAssetClass)
|
||||
# pfromData txInfoF.inputs
|
||||
# txInfoF.redeemers
|
||||
pguardC "Governor redeemr correct" $
|
||||
pcon PMintGATs #== governorRedeemer
|
||||
pguardC "All outputs only emit valid GATs" $
|
||||
pall
|
||||
# plam
|
||||
(authorityTokensValidIn # ptag ownSymbol #)
|
||||
# txInfoF.outputs
|
||||
pure $ pconstant ()
|
||||
)
|
||||
(passert "No GAT minted" (0 #== mintedATs) (pconstant ()))
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ Helpers for constructing effects.
|
|||
module Agora.Effect (makeEffect) where
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.SafeMoney (AuthorityTokenTag)
|
||||
import Plutarch.Api.V1 (
|
||||
PCurrencySymbol,
|
||||
)
|
||||
|
|
@ -17,6 +18,7 @@ import Plutarch.Api.V2 (
|
|||
PTxOutRef,
|
||||
PValidator,
|
||||
)
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
|
||||
|
||||
{- | Helper "template" for creating effect validator.
|
||||
|
|
@ -30,13 +32,13 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFiel
|
|||
makeEffect ::
|
||||
forall (datum :: PType) (s :: S).
|
||||
(PTryFrom PData datum, PIsData datum) =>
|
||||
( Term s PCurrencySymbol ->
|
||||
( Term s (PTagged AuthorityTokenTag PCurrencySymbol) ->
|
||||
Term s datum ->
|
||||
Term s PTxOutRef ->
|
||||
Term s (PAsData PTxInfo) ->
|
||||
Term s POpaque
|
||||
) ->
|
||||
Term s PCurrencySymbol ->
|
||||
Term s (PTagged AuthorityTokenTag PCurrencySymbol) ->
|
||||
Term s PValidator
|
||||
makeEffect f atSymbol =
|
||||
plam $ \datum _redeemer ctx' -> unTermCont $ do
|
||||
|
|
|
|||
|
|
@ -25,8 +25,8 @@ import Agora.Governor (
|
|||
PGovernorDatum,
|
||||
PGovernorRedeemer,
|
||||
)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Agora.Utils (pfromSingleton, ptryFromRedeemer)
|
||||
import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag)
|
||||
import Agora.Utils (ptaggedSymbolValueOf)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol, PValidatorHash)
|
||||
import Plutarch.Api.V2 (
|
||||
PScriptPurpose (PSpending),
|
||||
|
|
@ -38,11 +38,17 @@ import Plutarch.DataRepr (
|
|||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pdnothing)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (ptryFromSingleton)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pfromJust)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.=))
|
||||
import Plutarch.Extra.ScriptContext (paddressFromValidatorHash, pfromOutputDatum, pisScriptAddress)
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pisScriptAddress,
|
||||
ptryFromOutputDatum,
|
||||
ptryFromRedeemer,
|
||||
pvalidatorHashFromAddress,
|
||||
)
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC)
|
||||
import Plutarch.Extra.Value (psymbolValueOf)
|
||||
import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
|
||||
import PlutusLedgerApi.V1 (TxOutRef)
|
||||
import PlutusTx qualified
|
||||
|
|
@ -145,8 +151,8 @@ deriving anyclass instance PTryFrom PData PMutateGovernorDatum
|
|||
mutateGovernorValidator ::
|
||||
ClosedTerm
|
||||
( PValidatorHash
|
||||
:--> PCurrencySymbol
|
||||
:--> PCurrencySymbol
|
||||
:--> PTagged GovernorSTTag PCurrencySymbol
|
||||
:--> PTagged AuthorityTokenTag PCurrencySymbol
|
||||
:--> PValidator
|
||||
)
|
||||
mutateGovernorValidator =
|
||||
|
|
@ -177,25 +183,23 @@ mutateGovernorValidator =
|
|||
pany
|
||||
# plam
|
||||
( flip pletAll $ \inputF ->
|
||||
let governorAddress =
|
||||
paddressFromValidatorHash
|
||||
# govValidatorHash
|
||||
# pdnothing
|
||||
|
||||
isGovernorInput =
|
||||
let isGovernorInput =
|
||||
foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Governor UTxO should carry GST" $
|
||||
psymbolValueOf
|
||||
ptaggedSymbolValueOf
|
||||
# gstSymbol
|
||||
# (pfield @"value" # inputF.resolved)
|
||||
#== 1
|
||||
, ptraceIfFalse "Can only modify the pinned governor" $
|
||||
inputF.outRef #== effectDatumF.governorRef
|
||||
, ptraceIfFalse "Governor validator run" $
|
||||
pfield @"address"
|
||||
# inputF.resolved
|
||||
#== governorAddress
|
||||
let inputValidatorHash =
|
||||
pfromJust
|
||||
#$ pvalidatorHashFromAddress
|
||||
#$ pfield @"address"
|
||||
# inputF.resolved
|
||||
in inputValidatorHash #== govValidatorHash
|
||||
]
|
||||
in isGovernorInput
|
||||
)
|
||||
|
|
@ -216,11 +220,11 @@ mutateGovernorValidator =
|
|||
|
||||
let governorOutput =
|
||||
ptrace "Only governor output is allowed" $
|
||||
pfromSingleton # pfromData txInfoF.outputs
|
||||
ptryFromSingleton # pfromData txInfoF.outputs
|
||||
|
||||
governorOutputDatum =
|
||||
ptrace "Resolve governor outoput datum" $
|
||||
pfromOutputDatum @PGovernorDatum
|
||||
ptryFromOutputDatum @PGovernorDatum
|
||||
# (pfield @"datum" # governorOutput)
|
||||
# txInfoF.datums
|
||||
|
||||
|
|
|
|||
|
|
@ -8,10 +8,10 @@ A dumb effect that only burns its GAT.
|
|||
module Agora.Effect.NoOp (noOpValidator, PNoOp) where
|
||||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Agora.SafeMoney (AuthorityTokenTag)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol)
|
||||
import Plutarch.Api.V2 (PValidator)
|
||||
import Plutarch.Orphans ()
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
|
||||
{- | Dummy datum for NoOp effect.
|
||||
|
||||
|
|
@ -40,7 +40,7 @@ instance PTryFrom PData (PAsData PNoOp)
|
|||
|
||||
@since 1.0.0
|
||||
-}
|
||||
noOpValidator :: ClosedTerm (PCurrencySymbol :--> PValidator)
|
||||
noOpValidator :: ClosedTerm (PTagged AuthorityTokenTag PCurrencySymbol :--> PValidator)
|
||||
noOpValidator = plam $
|
||||
makeEffect $
|
||||
\_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())
|
||||
|
|
|
|||
|
|
@ -14,8 +14,7 @@ module Agora.Effect.TreasuryWithdrawal (
|
|||
) where
|
||||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Agora.Utils (pdelete)
|
||||
import Agora.SafeMoney (AuthorityTokenTag)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential,
|
||||
PCurrencySymbol,
|
||||
|
|
@ -35,7 +34,9 @@ import Plutarch.DataRepr (
|
|||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pdeleteFirst)
|
||||
import Plutarch.Extra.ScriptContext (pisPubKey)
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
|
||||
import PlutusLedgerApi.V1.Credential (Credential)
|
||||
|
|
@ -133,7 +134,7 @@ instance PTryFrom PData PTreasuryWithdrawalDatum
|
|||
-}
|
||||
treasuryWithdrawalValidator ::
|
||||
forall (s :: S).
|
||||
Term s (PCurrencySymbol :--> PValidator)
|
||||
Term s (PTagged AuthorityTokenTag PCurrencySymbol :--> PValidator)
|
||||
treasuryWithdrawalValidator = plam $
|
||||
makeEffect $
|
||||
\_cs (datum :: Term _ PTreasuryWithdrawalDatum) effectInputRef txInfo -> unTermCont $ do
|
||||
|
|
@ -178,7 +179,7 @@ treasuryWithdrawalValidator = plam $
|
|||
(ptraceError "Invalid receiver")
|
||||
|
||||
pure $
|
||||
pmatch (pdelete # credValue # receivers) $ \case
|
||||
pmatch (pdeleteFirst # credValue # receivers) $ \case
|
||||
PJust updatedReceivers ->
|
||||
ptrace "Receiver output" updatedReceivers
|
||||
PNothing ->
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ module Agora.Governor (
|
|||
pgetNextProposalId,
|
||||
getNextProposalId,
|
||||
pisGovernorDatumValid,
|
||||
presolveGovernorRedeemer,
|
||||
) where
|
||||
|
||||
import Agora.Aeson.Orphans ()
|
||||
|
|
@ -39,20 +40,33 @@ import Agora.Proposal.Time (
|
|||
pisMaxTimeRangeWidthValid,
|
||||
pisProposalTimingConfigValid,
|
||||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.SafeMoney (GTTag, GovernorSTTag)
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Tagged (Tagged)
|
||||
import Optics.TH (makeFieldLabelsNoPrefix)
|
||||
import Plutarch.Api.V1.Scripts (PRedeemer)
|
||||
import Plutarch.Api.V2 (KeyGuarantees (Unsorted), PMap, PScriptPurpose (PSpending), PTxInInfo)
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (DerivePConstantViaData),
|
||||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (AssetClass)
|
||||
import Plutarch.Extra.AssetClass (AssetClass, PAssetClass)
|
||||
import Plutarch.Extra.Bind (PBind ((#>>=)))
|
||||
import Plutarch.Extra.Field (pletAll)
|
||||
import Plutarch.Extra.Function (pflip)
|
||||
import Plutarch.Extra.Functor (PFunctor (pfmap))
|
||||
import Plutarch.Extra.IsData (
|
||||
DerivePConstantViaEnum (DerivePConstantEnum),
|
||||
EnumIsData (EnumIsData),
|
||||
PlutusTypeEnumData,
|
||||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import Plutarch.Extra.Maybe (pjust, pnothing)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.=))
|
||||
import Plutarch.Extra.ScriptContext (ptryFromRedeemer)
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletFieldsC)
|
||||
import Plutarch.Extra.Value (passetClassValueOfT)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
|
||||
import PlutusLedgerApi.V1 (TxOutRef)
|
||||
import PlutusTx qualified
|
||||
|
|
@ -73,9 +87,8 @@ data GovernorDatum = GovernorDatum
|
|||
-- Will get copied over upon the creation of proposals.
|
||||
, createProposalTimeRangeMaxWidth :: MaxTimeRangeWidth
|
||||
-- ^ The maximum valid duration of a transaction that creats a proposal.
|
||||
, maximumProposalsPerStake :: Integer
|
||||
-- ^ The maximum number of unfinished proposals that a stake is allowed to be
|
||||
-- associated to.
|
||||
, maximumCreatedProposalsPerStake :: Integer
|
||||
-- ^ The maximum number of proposals created by any given stakes.
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
|
|
@ -84,6 +97,9 @@ data GovernorDatum = GovernorDatum
|
|||
Generic
|
||||
)
|
||||
|
||||
-- | @since 0.2.1
|
||||
makeFieldLabelsNoPrefix ''GovernorDatum
|
||||
|
||||
-- | @since 0.1.0
|
||||
PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
|
||||
|
||||
|
|
@ -149,6 +165,8 @@ data Governor = Governor
|
|||
Aeson.FromJSON
|
||||
)
|
||||
|
||||
makeFieldLabelsNoPrefix ''Governor
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Plutarch-level datum for the Governor script.
|
||||
|
|
@ -164,7 +182,7 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
|
|||
, "nextProposalId" ':= PProposalId
|
||||
, "proposalTimings" ':= PProposalTimingConfig
|
||||
, "createProposalTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
|
||||
, "maximumProposalsPerStake" ':= PInteger
|
||||
, "maximumCreatedProposalsPerStake" ':= PInteger
|
||||
]
|
||||
)
|
||||
}
|
||||
|
|
@ -181,6 +199,8 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
|
|||
PDataFields
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
, -- | @since 0.2.1
|
||||
PShow
|
||||
)
|
||||
|
||||
-- | @since 0.2.0
|
||||
|
|
@ -277,3 +297,53 @@ pisGovernorDatumValid = phoistAcyclic $
|
|||
, ptraceIfFalse "time range valid" $
|
||||
pisMaxTimeRangeWidthValid # datumF.createProposalTimeRangeMaxWidth
|
||||
]
|
||||
|
||||
{- | Find the governor input and resolve the corresponding governor redeemer,
|
||||
given the assetclass of GST.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
presolveGovernorRedeemer ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PTagged GovernorSTTag PAssetClass
|
||||
:--> PBuiltinList PTxInInfo
|
||||
:--> PMap 'Unsorted PScriptPurpose PRedeemer
|
||||
:--> PMaybe PGovernorRedeemer
|
||||
)
|
||||
presolveGovernorRedeemer = phoistAcyclic $
|
||||
plam $ \gstClass inputs redeemers ->
|
||||
let governorInputRef =
|
||||
pfindJust
|
||||
# plam
|
||||
( flip pletAll $ \inputF ->
|
||||
let value = pfield @"value" # inputF.resolved
|
||||
isGovernorInput =
|
||||
passetClassValueOfT
|
||||
# gstClass
|
||||
# value
|
||||
#== 1
|
||||
in pif
|
||||
isGovernorInput
|
||||
(pjust # inputF.outRef)
|
||||
pnothing
|
||||
)
|
||||
# inputs
|
||||
|
||||
governorScriptPurpose =
|
||||
pfmap
|
||||
# plam
|
||||
( \ref ->
|
||||
mkRecordConstr
|
||||
PSpending
|
||||
(#_0 .= ref)
|
||||
)
|
||||
# governorInputRef
|
||||
|
||||
governorRedeemer =
|
||||
governorScriptPurpose
|
||||
#>>= pflip
|
||||
# ptryFromRedeemer @(PAsData PGovernorRedeemer)
|
||||
# redeemers
|
||||
in pfmap # plam pfromData # governorRedeemer
|
||||
|
|
|
|||
|
|
@ -35,41 +35,42 @@ import Agora.Proposal (
|
|||
pneutralOption,
|
||||
pwinner,
|
||||
)
|
||||
import Agora.Proposal.Time (validateProposalStartingTime)
|
||||
import Agora.Proposal.Time (pvalidateProposalStartingTime)
|
||||
import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag, ProposalSTTag, StakeSTTag)
|
||||
import Agora.Stake (
|
||||
pnumCreatedProposals,
|
||||
presolveStakeInputDatum,
|
||||
)
|
||||
import Agora.Utils (
|
||||
plistEqualsBy,
|
||||
pscriptHashToTokenName,
|
||||
)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol)
|
||||
import Agora.Utils (ptaggedSymbolValueOf, ptoScottEncodingT, puntag)
|
||||
import Data.Function (on)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol, PValidatorHash)
|
||||
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 (PAssetClassData, passetClass, ptoScottEncoding)
|
||||
import Plutarch.Extra.AssetClass (PAssetClassData, passetClass)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, plistEqualsBy, pmapMaybe)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.Map (pkeys, ptryLookup)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pjust, pmaybe, pmaybeData, pnothing)
|
||||
import Plutarch.Extra.Ord (psort)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pfromJust, pjust, pmaybeData, pnothing)
|
||||
import Plutarch.Extra.Ord (POrdering (..), pcompareBy, pfromOrd, psort)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromDatumHash,
|
||||
pfromOutputDatum,
|
||||
pisUTXOSpent,
|
||||
pscriptHashFromAddress,
|
||||
pscriptHashToTokenName,
|
||||
ptryFromDatumHash,
|
||||
ptryFromOutputDatum,
|
||||
pvalidatorHashFromAddress,
|
||||
pvalueSpent,
|
||||
)
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
||||
pguardC,
|
||||
pletC,
|
||||
|
|
@ -153,7 +154,7 @@ governorPolicy =
|
|||
|
||||
governorDatum =
|
||||
ptrace "Resolve governor datum" $
|
||||
pfromOutputDatum @PGovernorDatum
|
||||
ptryFromOutputDatum @PGovernorDatum
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in pif isGovernorUTxO (pjust # governorDatum) pnothing
|
||||
|
|
@ -263,15 +264,15 @@ governorPolicy =
|
|||
governorValidator ::
|
||||
-- | Lazy precompiled scripts.
|
||||
ClosedTerm
|
||||
( PAddress
|
||||
:--> PAssetClassData
|
||||
:--> PCurrencySymbol
|
||||
:--> PCurrencySymbol
|
||||
:--> PCurrencySymbol
|
||||
( PValidatorHash
|
||||
:--> PTagged StakeSTTag PAssetClassData
|
||||
:--> PTagged GovernorSTTag PCurrencySymbol
|
||||
:--> PTagged ProposalSTTag PCurrencySymbol
|
||||
:--> PTagged AuthorityTokenTag PCurrencySymbol
|
||||
:--> PValidator
|
||||
)
|
||||
governorValidator =
|
||||
plam $ \proposalValidatorAddress sstClass gstSymbol pstSymbol atSymbol datum redeemer ctx -> unTermCont $ do
|
||||
plam $ \proposalValidatorHash sstClass gstSymbol pstSymbol atSymbol datum redeemer ctx -> unTermCont $ do
|
||||
ctxF <- pletAllC ctx
|
||||
txInfo <- pletC $ pfromData ctxF.txInfo
|
||||
txInfoF <-
|
||||
|
|
@ -316,14 +317,16 @@ governorValidator =
|
|||
foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Own by governor validator" $
|
||||
outputF.address #== governorInputF.address
|
||||
((#==) `on` (pvalidatorHashFromAddress #))
|
||||
outputF.address
|
||||
governorInputF.address
|
||||
, ptraceIfFalse "Has governor ST" $
|
||||
psymbolValueOf # gstSymbol # outputF.value #== 1
|
||||
ptaggedSymbolValueOf # gstSymbol # outputF.value #== 1
|
||||
]
|
||||
|
||||
datum =
|
||||
ptrace "Resolve governor datum" $
|
||||
pfromOutputDatum @PGovernorDatum
|
||||
ptryFromOutputDatum @PGovernorDatum
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
in pif
|
||||
|
|
@ -335,22 +338,24 @@ governorValidator =
|
|||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
pstClass <- pletC $ passetClass # pto pstSymbol # pconstant ""
|
||||
|
||||
getProposalDatum :: Term _ (PTxOut :--> PMaybe PProposalDatum) <-
|
||||
pletC $
|
||||
plam $
|
||||
flip (pletFields @'["value", "datum", "address"]) $ \txOutF ->
|
||||
let isProposalUTxO =
|
||||
txOutF.address
|
||||
#== pdata proposalValidatorAddress
|
||||
#&& psymbolValueOf
|
||||
# pstSymbol
|
||||
(pfromJust #$ pvalidatorHashFromAddress # pfromData txOutF.address)
|
||||
#== proposalValidatorHash
|
||||
#&& passetClassValueOf
|
||||
# pstClass
|
||||
# txOutF.value
|
||||
#== 1
|
||||
|
||||
proposalDatum =
|
||||
ptrace "Resolve proposal output datum" $
|
||||
pfromData $
|
||||
pfromOutputDatum
|
||||
ptryFromOutputDatum
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in pif isProposalUTxO (pjust # proposalDatum) pnothing
|
||||
|
|
@ -378,8 +383,8 @@ governorValidator =
|
|||
.= governorInputDatumF.proposalTimings
|
||||
.& #createProposalTimeRangeMaxWidth
|
||||
.= governorInputDatumF.createProposalTimeRangeMaxWidth
|
||||
.& #maximumProposalsPerStake
|
||||
.= governorInputDatumF.maximumProposalsPerStake
|
||||
.& #maximumCreatedProposalsPerStake
|
||||
.= governorInputDatumF.maximumCreatedProposalsPerStake
|
||||
)
|
||||
|
||||
pguardC "Only next proposal id gets advanced" $
|
||||
|
|
@ -388,16 +393,7 @@ governorValidator =
|
|||
-- Check that exactly one proposal token is being minted.
|
||||
|
||||
pguardC "Exactly one proposal token must be minted" $
|
||||
let vMap = pfromData $ pto txInfoF.mint
|
||||
tnMap = plookup # pstSymbol # vMap
|
||||
-- Ada and PST
|
||||
onlyPST = plength # pto vMap #== 2
|
||||
onePST =
|
||||
pmaybe
|
||||
# pconstant False
|
||||
# plam (#== AssocMap.psingleton # pconstant "" # 1)
|
||||
# tnMap
|
||||
in onlyPST #&& onePST
|
||||
passetClassValueOf # pstClass # txInfoF.mint #== 1
|
||||
|
||||
-- Check that a stake is spent to create the propsal,
|
||||
-- and the value it contains meets the requirement.
|
||||
|
|
@ -407,7 +403,7 @@ governorValidator =
|
|||
# "Stake input should present"
|
||||
#$ pfindJust
|
||||
# ( presolveStakeInputDatum
|
||||
# (ptoScottEncoding # sstClass)
|
||||
# (ptoScottEncodingT # sstClass)
|
||||
# txInfoF.datums
|
||||
)
|
||||
# pfromData txInfoF.inputs
|
||||
|
|
@ -417,7 +413,7 @@ governorValidator =
|
|||
pguardC "Proposals created by the stake must not exceed the limit" $
|
||||
pnumCreatedProposals
|
||||
# stakeInputDatumF.lockedBy
|
||||
#< governorInputDatumF.maximumProposalsPerStake
|
||||
#< governorInputDatumF.maximumCreatedProposalsPerStake
|
||||
|
||||
let gtThreshold =
|
||||
pfromData $
|
||||
|
|
@ -425,7 +421,7 @@ governorValidator =
|
|||
# governorInputDatumF.proposalThresholds
|
||||
|
||||
pguardC "Require minimum amount of GTs" $
|
||||
gtThreshold #< stakeInputDatumF.stakedAmount
|
||||
gtThreshold #<= stakeInputDatumF.stakedAmount
|
||||
|
||||
-- Check that the newly minted PST is sent to the proposal validator,
|
||||
-- and the datum it carries is legal.
|
||||
|
|
@ -457,7 +453,7 @@ governorValidator =
|
|||
, ptraceIfFalse "cosigners correct" $
|
||||
plistEquals # pfromData proposalOutputDatumF.cosigners # expectedCosigners
|
||||
, ptraceIfFalse "starting time valid" $
|
||||
validateProposalStartingTime
|
||||
pvalidateProposalStartingTime
|
||||
# governorInputDatumF.createProposalTimeRangeMaxWidth
|
||||
# txInfoF.validRange
|
||||
# proposalOutputDatumF.startingTime
|
||||
|
|
@ -478,7 +474,7 @@ governorValidator =
|
|||
-- Filter out proposal inputs and ouputs using PST and the address of proposal validator.
|
||||
|
||||
pguardC "The governor can only process one proposal at a time" $
|
||||
(psymbolValueOf # pstSymbol #$ pvalueSpent # txInfoF.inputs) #== 1
|
||||
(ptaggedSymbolValueOf # pstSymbol #$ pvalueSpent # txInfoF.inputs) #== 1
|
||||
|
||||
let proposalInputDatum =
|
||||
passertPJust
|
||||
|
|
@ -510,14 +506,13 @@ governorValidator =
|
|||
( \output -> unTermCont $ do
|
||||
outputF <- pletFieldsC @'["address", "datum", "value"] output
|
||||
|
||||
let isAuthorityUTxO =
|
||||
psymbolValueOf
|
||||
let atAmount =
|
||||
ptaggedSymbolValueOf
|
||||
# atSymbol
|
||||
# outputF.value
|
||||
#== 1
|
||||
|
||||
handleAuthorityUTxO =
|
||||
unTermCont $ do
|
||||
do
|
||||
receiverScriptHash <-
|
||||
pletC $
|
||||
passertPJust
|
||||
|
|
@ -538,7 +533,7 @@ governorValidator =
|
|||
# pconstant ""
|
||||
# plam (pscriptHashToTokenName . pfromData)
|
||||
# effect.scriptHash
|
||||
gatAssetClass = passetClass # atSymbol # tagToken
|
||||
gatAssetClass = passetClass # puntag atSymbol # tagToken
|
||||
valueGATCorrect =
|
||||
passetClassValueOf
|
||||
# gatAssetClass
|
||||
|
|
@ -546,7 +541,7 @@ governorValidator =
|
|||
#== 1
|
||||
|
||||
let hasCorrectDatum =
|
||||
effect.datumHash #== pfromDatumHash # outputF.datum
|
||||
effect.datumHash #== ptryFromDatumHash # outputF.datum
|
||||
|
||||
pguardC "Authority output valid" $
|
||||
foldr1
|
||||
|
|
@ -556,19 +551,27 @@ governorValidator =
|
|||
, ptraceIfFalse "Value correctly encodes Auth Check script" valueGATCorrect
|
||||
]
|
||||
|
||||
pure receiverScriptHash
|
||||
pure $ pjust # receiverScriptHash
|
||||
|
||||
pure $
|
||||
pif
|
||||
isAuthorityUTxO
|
||||
(pjust # handleAuthorityUTxO)
|
||||
pnothing
|
||||
pmatchC
|
||||
( pcompareBy
|
||||
# pfromOrd
|
||||
# atAmount
|
||||
# 1
|
||||
)
|
||||
>>= \case
|
||||
-- atAmount == 1
|
||||
PEQ -> handleAuthorityUTxO
|
||||
-- atAmount < 1
|
||||
PLT -> pure pnothing
|
||||
-- atAmount > 1
|
||||
PGT -> pure $ ptraceError "More than one GAT in one UTxO"
|
||||
)
|
||||
|
||||
-- The sorted hashes of all the GAT receivers.
|
||||
actualReceivers =
|
||||
psort
|
||||
#$ pmapMaybe
|
||||
#$ pmapMaybe @PList
|
||||
# getReceiverScriptHash
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
|
|
|
|||
|
|
@ -3,13 +3,14 @@
|
|||
module Agora.Linker (linker, AgoraScriptInfo (..)) where
|
||||
|
||||
import Agora.Governor (Governor (gstOutRef, gtClassRef, maximumCosigners))
|
||||
import Agora.Utils (validatorHashToAddress, validatorHashToTokenName)
|
||||
import Agora.SafeMoney (AuthorityTokenTag, GTTag, GovernorSTTag, ProposalSTTag, StakeSTTag)
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Map (fromList)
|
||||
import Data.Tagged (untag)
|
||||
import Data.Tagged (Tagged (Tagged))
|
||||
import Plutarch.Api.V2 (mintingPolicySymbol, validatorHash)
|
||||
import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
|
||||
import PlutusLedgerApi.V1 (Address, CurrencySymbol, TxOutRef, ValidatorHash)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1 (CurrencySymbol, TxOutRef, ValidatorHash)
|
||||
import Ply (
|
||||
ScriptRole (MintingPolicyRole, ValidatorRole),
|
||||
toMintingPolicy,
|
||||
|
|
@ -30,10 +31,10 @@ import Prelude hiding ((#))
|
|||
@since 1.0.0
|
||||
-}
|
||||
data AgoraScriptInfo = AgoraScriptInfo
|
||||
{ governorAssetClass :: AssetClass
|
||||
, authorityTokenSymbol :: CurrencySymbol
|
||||
, proposalAssetClass :: AssetClass
|
||||
, stakeAssetClass :: AssetClass
|
||||
{ governorAssetClass :: Tagged GovernorSTTag AssetClass
|
||||
, authorityTokenSymbol :: Tagged AuthorityTokenTag CurrencySymbol
|
||||
, proposalAssetClass :: Tagged ProposalSTTag AssetClass
|
||||
, stakeAssetClass :: Tagged StakeSTTag AssetClass
|
||||
, governor :: Governor
|
||||
}
|
||||
deriving stock (Generic, Show)
|
||||
|
|
@ -45,28 +46,86 @@ data AgoraScriptInfo = AgoraScriptInfo
|
|||
-}
|
||||
linker :: Linker Governor (ScriptExport AgoraScriptInfo)
|
||||
linker = do
|
||||
govPol <- fetchTS @MintingPolicyRole @'[TxOutRef] "agora:governorPolicy"
|
||||
govVal <- fetchTS @ValidatorRole @'[Address, AssetClass, 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"
|
||||
govPol <-
|
||||
fetchTS
|
||||
@MintingPolicyRole
|
||||
@'[TxOutRef]
|
||||
"agora:governorPolicy"
|
||||
govVal <-
|
||||
fetchTS
|
||||
@ValidatorRole
|
||||
@'[ ValidatorHash
|
||||
, Tagged StakeSTTag AssetClass
|
||||
, Tagged GovernorSTTag CurrencySymbol
|
||||
, Tagged ProposalSTTag CurrencySymbol
|
||||
, Tagged AuthorityTokenTag CurrencySymbol
|
||||
]
|
||||
"agora:governorValidator"
|
||||
stkPol <-
|
||||
fetchTS
|
||||
@MintingPolicyRole
|
||||
@'[Tagged GTTag AssetClass]
|
||||
"agora:stakePolicy"
|
||||
stkVal <-
|
||||
fetchTS
|
||||
@ValidatorRole
|
||||
@'[ Tagged StakeSTTag CurrencySymbol
|
||||
, Tagged ProposalSTTag AssetClass
|
||||
, Tagged GTTag AssetClass
|
||||
]
|
||||
"agora:stakeValidator"
|
||||
prpPol <-
|
||||
fetchTS @MintingPolicyRole
|
||||
@'[Tagged GovernorSTTag AssetClass]
|
||||
"agora:proposalPolicy"
|
||||
prpVal <-
|
||||
fetchTS
|
||||
@ValidatorRole
|
||||
@'[ Tagged StakeSTTag AssetClass
|
||||
, Tagged GovernorSTTag CurrencySymbol
|
||||
, Tagged ProposalSTTag CurrencySymbol
|
||||
, Integer
|
||||
]
|
||||
"agora:proposalValidator"
|
||||
treVal <-
|
||||
fetchTS
|
||||
@ValidatorRole
|
||||
@'[Tagged AuthorityTokenTag CurrencySymbol]
|
||||
"agora:treasuryValidator"
|
||||
atkPol <-
|
||||
fetchTS
|
||||
@MintingPolicyRole
|
||||
@'[Tagged GovernorSTTag AssetClass]
|
||||
"agora:authorityTokenPolicy"
|
||||
noOpVal <-
|
||||
fetchTS
|
||||
@ValidatorRole
|
||||
@'[Tagged AuthorityTokenTag CurrencySymbol]
|
||||
"agora:noOpValidator"
|
||||
treaWithdrawalVal <-
|
||||
fetchTS
|
||||
@ValidatorRole
|
||||
@'[Tagged AuthorityTokenTag CurrencySymbol]
|
||||
"agora:treasuryWithdrawalValidator"
|
||||
mutateGovVal <-
|
||||
fetchTS
|
||||
@ValidatorRole
|
||||
@'[ ValidatorHash
|
||||
, Tagged GovernorSTTag CurrencySymbol
|
||||
, Tagged AuthorityTokenTag CurrencySymbol
|
||||
]
|
||||
"agora:mutateGovernorValidator"
|
||||
|
||||
governor <- getParam
|
||||
|
||||
let govPol' = govPol # governor.gstOutRef
|
||||
govVal' =
|
||||
govVal
|
||||
# propValAddress
|
||||
# sstAssetClass
|
||||
# gstSymbol
|
||||
# pstSymbol
|
||||
# atSymbol
|
||||
# propValHash
|
||||
# Tagged sstAssetClass
|
||||
# Tagged gstSymbol
|
||||
# Tagged pstSymbol
|
||||
# Tagged atSymbol
|
||||
gstSymbol =
|
||||
mintingPolicySymbol $
|
||||
toMintingPolicy
|
||||
|
|
@ -75,34 +134,40 @@ linker = do
|
|||
AssetClass gstSymbol ""
|
||||
govValHash = validatorHash $ toValidator govVal'
|
||||
|
||||
at = gstAssetClass
|
||||
atPol' = atkPol # at
|
||||
atPol' = atkPol # Tagged gstAssetClass
|
||||
atSymbol = mintingPolicySymbol $ toMintingPolicy atPol'
|
||||
|
||||
propPol' = prpPol # gstAssetClass
|
||||
propPol' = prpPol # Tagged gstAssetClass
|
||||
propVal' =
|
||||
prpVal
|
||||
# sstAssetClass
|
||||
# gstSymbol
|
||||
# pstSymbol
|
||||
# Tagged sstAssetClass
|
||||
# Tagged gstSymbol
|
||||
# Tagged pstSymbol
|
||||
# governor.maximumCosigners
|
||||
propValAddress =
|
||||
validatorHashToAddress $ validatorHash $ toValidator propVal'
|
||||
propValHash = validatorHash $ toValidator propVal'
|
||||
pstSymbol = mintingPolicySymbol $ toMintingPolicy propPol'
|
||||
pstAssetClass = AssetClass pstSymbol ""
|
||||
|
||||
stakPol' = stkPol # untag governor.gtClassRef
|
||||
stakVal' = stkVal # sstSymbol # pstAssetClass # untag governor.gtClassRef
|
||||
stakPol' = stkPol # governor.gtClassRef
|
||||
stakVal' =
|
||||
stkVal
|
||||
# Tagged sstSymbol
|
||||
# Tagged pstAssetClass
|
||||
# governor.gtClassRef
|
||||
sstSymbol = mintingPolicySymbol $ toMintingPolicy stakPol'
|
||||
stakValTokenName =
|
||||
validatorHashToTokenName $ validatorHash $ toValidator stakVal'
|
||||
sstAssetClass = AssetClass sstSymbol stakValTokenName
|
||||
|
||||
treaVal' = treVal # atSymbol
|
||||
treaVal' = treVal # Tagged atSymbol
|
||||
|
||||
noOpVal' = noOpVal # atSymbol
|
||||
treaWithdrawalVal' = treaWithdrawalVal # atSymbol
|
||||
mutateGovVal' = mutateGovVal # govValHash # gstSymbol # atSymbol
|
||||
noOpVal' = noOpVal # Tagged atSymbol
|
||||
treaWithdrawalVal' = treaWithdrawalVal # Tagged atSymbol
|
||||
mutateGovVal' =
|
||||
mutateGovVal
|
||||
# govValHash
|
||||
# Tagged gstSymbol
|
||||
# Tagged atSymbol
|
||||
|
||||
return $
|
||||
ScriptExport
|
||||
|
|
@ -122,10 +187,10 @@ linker = do
|
|||
]
|
||||
, information =
|
||||
AgoraScriptInfo
|
||||
{ governorAssetClass = gstAssetClass
|
||||
, authorityTokenSymbol = atSymbol
|
||||
, proposalAssetClass = pstAssetClass
|
||||
, stakeAssetClass = sstAssetClass
|
||||
{ governorAssetClass = Tagged gstAssetClass
|
||||
, authorityTokenSymbol = Tagged atSymbol
|
||||
, proposalAssetClass = Tagged pstAssetClass
|
||||
, stakeAssetClass = Tagged sstAssetClass
|
||||
, governor = governor
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -6,10 +6,14 @@ import Plutarch.Lift (PConstantDecl (..), PUnsafeLiftDecl (PLifted))
|
|||
|
||||
import Data.Bifunctor (Bifunctor (bimap))
|
||||
import Data.Map.Strict qualified as StrictMap
|
||||
import Data.Tagged (Tagged (Tagged))
|
||||
import Data.Traversable (for)
|
||||
import Plutarch.Api.V1 (KeyGuarantees (Sorted), PMap)
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import PlutusTx qualified
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Ply (PlyArg)
|
||||
import Ply.Plutarch.Class (PlyArgOf)
|
||||
|
||||
-- | @since 1.0.0
|
||||
instance
|
||||
|
|
@ -74,3 +78,9 @@ instance
|
|||
isSorted [] = True
|
||||
isSorted [_] = True
|
||||
isSorted (x : y : xs) = x < y && isSorted (y : xs)
|
||||
|
||||
-- | @since 1.0.0
|
||||
type instance PlyArgOf (PTagged tag a) = Tagged tag (PlyArgOf a)
|
||||
|
||||
-- | @since 1.0.0
|
||||
deriving newtype instance PlyArg a => PlyArg (Tagged tag a)
|
||||
|
|
|
|||
|
|
@ -162,7 +162,7 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
|
|||
data ProposalStatus
|
||||
= -- | A draft proposal represents a proposal that has yet to be realized.
|
||||
--
|
||||
-- In effect, this means one which didn't have enough LQ to be a full
|
||||
-- In effect, this means one which didn't have enough GT to be a full
|
||||
-- proposal, and needs cosigners to enable that to happen. This is
|
||||
-- similar to a "temperature check", but only useful if multiple people
|
||||
-- want to pool governance tokens together. If the proposal doesn't get to
|
||||
|
|
@ -579,6 +579,8 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
|
|||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PDataFields
|
||||
, -- | @since 0.2.1
|
||||
PShow
|
||||
)
|
||||
|
||||
-- | @since 0.2.0
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ module Agora.Proposal.Scripts (
|
|||
proposalPolicy,
|
||||
) where
|
||||
|
||||
import Agora.Governor (PGovernorRedeemer (PCreateProposal))
|
||||
import Agora.Governor (PGovernorRedeemer (PCreateProposal), presolveGovernorRedeemer)
|
||||
import Agora.Proposal (
|
||||
PProposalDatum (PProposalDatum),
|
||||
PProposalRedeemer (PAdvanceProposal, PCosign, PUnlockStake, PVote),
|
||||
|
|
@ -23,10 +23,12 @@ import Agora.Proposal (
|
|||
import Agora.Proposal.Time (
|
||||
PPeriod (PDraftingPeriod, PExecutingPeriod, PLockingPeriod, PVotingPeriod),
|
||||
PTimingRelation (PAfter, PWithin),
|
||||
currentProposalTime,
|
||||
pcurrentProposalTime,
|
||||
pgetRelation,
|
||||
pisWithin,
|
||||
psatisfyMaximumWidth,
|
||||
)
|
||||
import Agora.SafeMoney (GovernorSTTag, ProposalSTTag, StakeSTTag)
|
||||
import Agora.Stake (
|
||||
PStakeDatum,
|
||||
pextractVoteOption,
|
||||
|
|
@ -35,13 +37,8 @@ import Agora.Stake (
|
|||
pisVoter,
|
||||
presolveStakeInputDatum,
|
||||
)
|
||||
import Agora.Utils (
|
||||
pfromSingleton,
|
||||
pinsertUniqueBy,
|
||||
plistEqualsBy,
|
||||
pmapMaybe,
|
||||
ptryFromRedeemer,
|
||||
)
|
||||
import Agora.Utils (ptaggedSymbolValueOf, ptoScottEncodingT)
|
||||
import Data.Function (on)
|
||||
import Plutarch.Api.V1 (PCredential, PCurrencySymbol)
|
||||
import Plutarch.Api.V1.AssocMap (plookup)
|
||||
import Plutarch.Api.V2 (
|
||||
|
|
@ -52,11 +49,15 @@ import Plutarch.Api.V2 (
|
|||
)
|
||||
import Plutarch.Extra.AssetClass (
|
||||
PAssetClassData,
|
||||
ptoScottEncoding,
|
||||
)
|
||||
import Plutarch.Extra.Category (PCategory (pidentity))
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (
|
||||
pfindJust,
|
||||
plistEqualsBy,
|
||||
pmapMaybe,
|
||||
ptryFromSingleton,
|
||||
)
|
||||
import "plutarch-extra" Plutarch.Extra.Map (pupdate)
|
||||
import Plutarch.Extra.Maybe (
|
||||
passertPJust,
|
||||
|
|
@ -66,13 +67,15 @@ import Plutarch.Extra.Maybe (
|
|||
pmaybe,
|
||||
pnothing,
|
||||
)
|
||||
import Plutarch.Extra.Ord (pfromOrdBy, psort)
|
||||
import Plutarch.Extra.Ord (pfromOrdBy, pinsertUniqueBy, psort)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromOutputDatum,
|
||||
ptryFromOutputDatum,
|
||||
pvalidatorHashFromAddress,
|
||||
)
|
||||
import Plutarch.Extra.Sum (PSum (PSum))
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
||||
pguardC,
|
||||
pletC,
|
||||
|
|
@ -80,8 +83,9 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
|||
pmatchC,
|
||||
ptryFromC,
|
||||
)
|
||||
import Plutarch.Extra.Time (PCurrentTime)
|
||||
import Plutarch.Extra.Traversable (pfoldMap)
|
||||
import Plutarch.Extra.Value (passetClassValueOf, psymbolValueOf)
|
||||
import Plutarch.Extra.Value (psymbolValueOf')
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
|
||||
{- | Policy for Proposals.
|
||||
|
|
@ -109,7 +113,7 @@ import Plutarch.Unsafe (punsafeCoerce)
|
|||
|
||||
@since 1.0.0
|
||||
-}
|
||||
proposalPolicy :: ClosedTerm (PAssetClassData :--> PMintingPolicy)
|
||||
proposalPolicy :: ClosedTerm (PTagged GovernorSTTag PAssetClassData :--> PMintingPolicy)
|
||||
proposalPolicy =
|
||||
plam $ \gstAssetClass _redeemer ctx -> unTermCont $ do
|
||||
ctxF <- pletAllC ctx
|
||||
|
|
@ -117,44 +121,25 @@ proposalPolicy =
|
|||
|
||||
PMinting ((pfield @"_0" #) -> ownSymbol) <- pmatchC $ pfromData ctxF.purpose
|
||||
|
||||
let mintedProposalST =
|
||||
psymbolValueOf
|
||||
pguardC "Minted exactly one proposal ST"
|
||||
$ pmatch
|
||||
( pfromJust
|
||||
#$ psymbolValueOf'
|
||||
# ownSymbol
|
||||
# txInfoF.mint
|
||||
)
|
||||
$ \(PPair minted burnt) ->
|
||||
minted
|
||||
#== 1
|
||||
#&& ptraceIfFalse "Burning a proposal is not supported" (burnt #== 0)
|
||||
|
||||
pguardC "Minted exactly one proposal ST" $
|
||||
mintedProposalST #== 1
|
||||
|
||||
let governorInputRef =
|
||||
let governorRedeemer =
|
||||
passertPJust
|
||||
# "GST should move"
|
||||
#$ pfindJust
|
||||
# plam
|
||||
( flip pletAll $ \inputF ->
|
||||
let value = pfield @"value" # inputF.resolved
|
||||
isGovernorInput =
|
||||
passetClassValueOf
|
||||
# (ptoScottEncoding # gstAssetClass)
|
||||
# value
|
||||
#== 1
|
||||
in pif
|
||||
isGovernorInput
|
||||
(pjust # inputF.outRef)
|
||||
pnothing
|
||||
)
|
||||
#$ presolveGovernorRedeemer
|
||||
# (ptoScottEncodingT # gstAssetClass)
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
governorScriptPurpose =
|
||||
mkRecordConstr
|
||||
PSpending
|
||||
(#_0 .= governorInputRef)
|
||||
|
||||
governorRedeemer =
|
||||
pfromData $
|
||||
pfromJust
|
||||
#$ ptryFromRedeemer @(PAsData PGovernorRedeemer)
|
||||
# governorScriptPurpose
|
||||
# txInfoF.redeemers
|
||||
# txInfoF.redeemers
|
||||
|
||||
pguardC "Govenor redeemer correct" $
|
||||
pcon PCreateProposal #== governorRedeemer
|
||||
|
|
@ -239,9 +224,9 @@ instance DerivePlutusType PStakeInputsContext where
|
|||
-}
|
||||
proposalValidator ::
|
||||
ClosedTerm
|
||||
( PAssetClassData
|
||||
:--> PCurrencySymbol
|
||||
:--> PCurrencySymbol
|
||||
( PTagged StakeSTTag PAssetClassData
|
||||
:--> PTagged GovernorSTTag PCurrencySymbol
|
||||
:--> PTagged ProposalSTTag PCurrencySymbol
|
||||
:--> PInteger
|
||||
:--> PValidator
|
||||
)
|
||||
|
|
@ -300,16 +285,18 @@ proposalValidator =
|
|||
foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Own by proposal validator" $
|
||||
outputF.address #== proposalInputF.address
|
||||
((#==) `on` (pvalidatorHashFromAddress #))
|
||||
outputF.address
|
||||
proposalInputF.address
|
||||
, ptraceIfFalse "Has proposal ST" $
|
||||
psymbolValueOf # pstSymbol # outputF.value #== 1
|
||||
ptaggedSymbolValueOf # pstSymbol # outputF.value #== 1
|
||||
]
|
||||
|
||||
handleProposalUTxO =
|
||||
-- Using inline datum to avoid O(n^2) lookup.
|
||||
pfromData $
|
||||
ptrace "Resolve proposal datum" $
|
||||
pfromOutputDatum @(PAsData PProposalDatum)
|
||||
ptryFromOutputDatum @(PAsData PProposalDatum)
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
in pif
|
||||
|
|
@ -321,17 +308,23 @@ proposalValidator =
|
|||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
currentTime <- pletC $ pcurrentProposalTime # txInfoF.validRange
|
||||
|
||||
let withCurrentTime ::
|
||||
forall (a :: PType).
|
||||
Term _ (PCurrentTime :--> a) ->
|
||||
Term _ a
|
||||
withCurrentTime f =
|
||||
pmatch currentTime $ \case
|
||||
PJust currentTime -> f # currentTime
|
||||
PNothing -> ptraceError "Unable to resolve current time"
|
||||
|
||||
getTimingRelation' <-
|
||||
pletC $
|
||||
let currentTime =
|
||||
passertPJust
|
||||
# "Current time should be resolved"
|
||||
#$ currentProposalTime
|
||||
# txInfoF.validRange
|
||||
in pgetRelation
|
||||
# proposalInputDatumF.timingConfig
|
||||
# proposalInputDatumF.startingTime
|
||||
# currentTime
|
||||
withCurrentTime $
|
||||
pgetRelation
|
||||
# proposalInputDatumF.timingConfig
|
||||
# proposalInputDatumF.startingTime
|
||||
|
||||
let getTimingRelation = (getTimingRelation' #) . pcon
|
||||
|
||||
|
|
@ -342,18 +335,23 @@ proposalValidator =
|
|||
resolveStakeInputDatum <-
|
||||
pletC $
|
||||
presolveStakeInputDatum
|
||||
# (ptoScottEncoding # sstClass)
|
||||
# (ptoScottEncodingT # sstClass)
|
||||
# txInfoF.datums
|
||||
|
||||
spendStakes' :: Term _ ((PStakeInputsContext :--> PUnit) :--> PUnit) <-
|
||||
pletC $
|
||||
plam $
|
||||
let stakeInputs =
|
||||
pmapMaybe
|
||||
# resolveStakeInputDatum
|
||||
# pfromData txInfoF.inputs
|
||||
plam $ \val -> unTermCont $ do
|
||||
stakeInputs <-
|
||||
pletC $
|
||||
pmapMaybe @PList
|
||||
# resolveStakeInputDatum
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
ctx = pcon $ PStakeInputsContext stakeInputs
|
||||
in (# ctx)
|
||||
pguardC "Stake inputs not null" $
|
||||
pnot #$ pnull # stakeInputs
|
||||
|
||||
let ctx = pcon $ PStakeInputsContext stakeInputs
|
||||
pure $ val # ctx
|
||||
|
||||
let spendStakes ::
|
||||
( PStakeInputsContext _ ->
|
||||
|
|
@ -439,7 +437,7 @@ proposalValidator =
|
|||
stakeF <-
|
||||
pletFieldsC @'["owner", "stakedAmount"] $
|
||||
ptrace "Exactly one stake input" $
|
||||
pfromSingleton # sctxF.inputStakes
|
||||
ptryFromSingleton # sctxF.inputStakes
|
||||
|
||||
let newCosigner = stakeF.owner
|
||||
|
||||
|
|
@ -512,6 +510,12 @@ proposalValidator =
|
|||
pguardC "Proposal time should be wthin the voting period" $
|
||||
pisWithin # getTimingRelation PVotingPeriod
|
||||
|
||||
pguardC "Width of time should meet maximum requirement" $
|
||||
withCurrentTime $
|
||||
psatisfyMaximumWidth
|
||||
#$ pfield @"votingTimeRangeMaxWidth"
|
||||
# proposalInputDatumF.timingConfig
|
||||
|
||||
-- Ensure the transaction is voting to a valid 'ResultTag'(outcome).
|
||||
PProposalVotes voteMap <- pmatchC proposalInputDatumF.votes
|
||||
voteFor <- pletC $ pfromData $ pfield @"resultTag" # r
|
||||
|
|
@ -563,40 +567,41 @@ proposalValidator =
|
|||
|
||||
PUnlockStake _ -> spendStakes $ \sctxF -> do
|
||||
let expectedVotes =
|
||||
pfoldl
|
||||
# plam
|
||||
( \votes stake -> unTermCont $ do
|
||||
stakeF <-
|
||||
pletFieldsC
|
||||
@'["stakedAmount", "lockedBy"]
|
||||
stake
|
||||
pdata $
|
||||
pfoldl
|
||||
# plam
|
||||
( \votes stake -> unTermCont $ do
|
||||
stakeF <-
|
||||
pletFieldsC
|
||||
@'["stakedAmount", "lockedBy"]
|
||||
stake
|
||||
|
||||
stakeRoles <-
|
||||
pletC $
|
||||
pgetStakeRoles
|
||||
# proposalInputDatumF.proposalId
|
||||
# stakeF.lockedBy
|
||||
stakeRoles <-
|
||||
pletC $
|
||||
pgetStakeRoles
|
||||
# proposalInputDatumF.proposalId
|
||||
# stakeF.lockedBy
|
||||
|
||||
pguardC "Stake input should be relevant" $
|
||||
pnot #$ pisIrrelevant # stakeRoles
|
||||
pguardC "Stake input should be relevant" $
|
||||
pnot #$ pisIrrelevant # stakeRoles
|
||||
|
||||
let canRetractVotes =
|
||||
pisVoter # stakeRoles
|
||||
let canRetractVotes =
|
||||
pisVoter # stakeRoles
|
||||
|
||||
voteCount =
|
||||
pto $
|
||||
pfromData stakeF.stakedAmount
|
||||
voteCount =
|
||||
pto $
|
||||
pfromData stakeF.stakedAmount
|
||||
|
||||
newVotes =
|
||||
pretractVotes
|
||||
# (pextractVoteOption # stakeRoles)
|
||||
# voteCount
|
||||
# votes
|
||||
newVotes =
|
||||
pretractVotes
|
||||
# (pextractVoteOption # stakeRoles)
|
||||
# voteCount
|
||||
# votes
|
||||
|
||||
pure $ pif canRetractVotes newVotes votes
|
||||
)
|
||||
# proposalInputDatumF.votes
|
||||
# sctxF.inputStakes
|
||||
pure $ pif canRetractVotes newVotes votes
|
||||
)
|
||||
# proposalInputDatumF.votes
|
||||
# sctxF.inputStakes
|
||||
|
||||
inVotingPeriod =
|
||||
pisWithin # getTimingRelation PVotingPeriod
|
||||
|
|
@ -625,14 +630,19 @@ proposalValidator =
|
|||
.& #thresholds
|
||||
.= proposalInputDatumF.thresholds
|
||||
.& #votes
|
||||
.= pdata expectedVotes
|
||||
.= expectedVotes
|
||||
.& #timingConfig
|
||||
.= proposalInputDatumF.timingConfig
|
||||
.& #startingTime
|
||||
.= proposalInputDatumF.startingTime
|
||||
)
|
||||
in ptraceIfFalse "Update votes" $
|
||||
expectedProposalOut #== proposalOutputDatum
|
||||
in foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Votes changed" $
|
||||
pnot #$ expectedVotes #== proposalInputDatumF.votes
|
||||
, ptraceIfFalse "Proposal update correct" $
|
||||
expectedProposalOut #== proposalOutputDatum
|
||||
]
|
||||
)
|
||||
-- No change to the proposal is allowed.
|
||||
( ptraceIfFalse "Proposal unchanged" $
|
||||
|
|
@ -728,7 +738,7 @@ proposalValidator =
|
|||
. (pfield @"resolved" #) ->
|
||||
value
|
||||
) ->
|
||||
psymbolValueOf # gstSymbol # value #== 1
|
||||
ptaggedSymbolValueOf # gstSymbol # value #== 1
|
||||
)
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
|
|
|
|||
|
|
@ -22,16 +22,15 @@ module Agora.Proposal.Time (
|
|||
PPeriod (..),
|
||||
|
||||
-- * Compute periods given config and starting time.
|
||||
validateProposalStartingTime,
|
||||
currentProposalTime,
|
||||
pvalidateProposalStartingTime,
|
||||
pcurrentProposalTime,
|
||||
pisProposalTimingConfigValid,
|
||||
pisMaxTimeRangeWidthValid,
|
||||
pgetRelation,
|
||||
pisWithin,
|
||||
psatisfyMaximumWidth,
|
||||
) where
|
||||
|
||||
import Agora.Utils (pcurrentTimeDuration)
|
||||
import Control.Composition ((.*))
|
||||
import Data.Functor ((<&>))
|
||||
import Plutarch.Api.V1 (
|
||||
PExtended (PFinite),
|
||||
|
|
@ -46,12 +45,14 @@ import Plutarch.DataRepr (
|
|||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Applicative (PApply (pliftA2))
|
||||
import Plutarch.Extra.Bool (passert)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import Plutarch.Extra.IsData (PlutusTypeEnumData)
|
||||
import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pmatchC)
|
||||
import Plutarch.Extra.Time (
|
||||
PCurrentTime (PCurrentTime),
|
||||
pcurrentTimeDuration,
|
||||
pisWithinCurrentTime,
|
||||
)
|
||||
import Plutarch.Lift (
|
||||
|
|
@ -59,6 +60,7 @@ import Plutarch.Lift (
|
|||
PConstantDecl,
|
||||
PUnsafeLiftDecl (PLifted),
|
||||
)
|
||||
import Plutarch.Num (PNum)
|
||||
import PlutusLedgerApi.V1 (POSIXTime)
|
||||
import PlutusTx qualified
|
||||
|
||||
|
|
@ -88,33 +90,6 @@ newtype ProposalStartingTime = ProposalStartingTime
|
|||
PlutusTx.UnsafeFromData
|
||||
)
|
||||
|
||||
{- | Configuration of proposal timings.
|
||||
|
||||
See: https://liqwid.notion.site/Proposals-589853145a994057aa77f397079f75e4#d25ea378768d4c76b52dd4c1b6bc0fcd
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
data ProposalTimingConfig = ProposalTimingConfig
|
||||
{ draftTime :: POSIXTime
|
||||
-- ^ "D": the length of the draft period.
|
||||
, votingTime :: POSIXTime
|
||||
-- ^ "V": the length of the voting period.
|
||||
, lockingTime :: POSIXTime
|
||||
-- ^ "L": the length of the locking period.
|
||||
, executingTime :: POSIXTime
|
||||
-- ^ "E": the length of the execution period.
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Eq
|
||||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
|
||||
PlutusTx.makeIsDataIndexed 'ProposalTimingConfig [('ProposalTimingConfig, 0)]
|
||||
|
||||
-- | Represents the maximum width of a 'PlutusLedgerApi.V1.Time.POSIXTimeRange'.
|
||||
newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
|
||||
deriving stock
|
||||
|
|
@ -134,8 +109,41 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
|
|||
PlutusTx.FromData
|
||||
, -- | @since 0.1.0
|
||||
PlutusTx.UnsafeFromData
|
||||
, -- | @since 1.0.0
|
||||
Num
|
||||
)
|
||||
|
||||
{- | Configuration of proposal timings.
|
||||
|
||||
See: https://liqwid.notion.site/Proposals-589853145a994057aa77f397079f75e4#d25ea378768d4c76b52dd4c1b6bc0fcd
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
data ProposalTimingConfig = ProposalTimingConfig
|
||||
{ draftTime :: POSIXTime
|
||||
-- ^ "D": the length of the draft period.
|
||||
, votingTime :: POSIXTime
|
||||
-- ^ "V": the length of the voting period.
|
||||
, lockingTime :: POSIXTime
|
||||
-- ^ "L": the length of the locking period.
|
||||
, executingTime :: POSIXTime
|
||||
-- ^ "E": the length of the execution period.
|
||||
, minStakeVotingTime :: POSIXTime
|
||||
-- ^ Minimum time from creating a voting lock until it can be destroyed.
|
||||
, votingTimeRangeMaxWidth :: MaxTimeRangeWidth
|
||||
-- ^ The maximum width of transaction time range while voting.
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Eq
|
||||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
|
||||
PlutusTx.makeIsDataIndexed 'ProposalTimingConfig [('ProposalTimingConfig, 0)]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | == Establishing timing in Proposal interactions.
|
||||
|
|
@ -210,6 +218,8 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
|
|||
, "votingTime" ':= PPOSIXTime
|
||||
, "lockingTime" ':= PPOSIXTime
|
||||
, "executingTime" ':= PPOSIXTime
|
||||
, "minStakeVotingTime" ':= PPOSIXTime
|
||||
, "votingTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
|
||||
]
|
||||
)
|
||||
}
|
||||
|
|
@ -224,6 +234,8 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
|
|||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PDataFields
|
||||
, -- | @since 0.2.1
|
||||
PShow
|
||||
)
|
||||
|
||||
instance DerivePlutusType PProposalTimingConfig where
|
||||
|
|
@ -260,6 +272,10 @@ newtype PMaxTimeRangeWidth (s :: S)
|
|||
PPartialOrd
|
||||
, -- | @since 0.1.0
|
||||
POrd
|
||||
, -- | @since 0.2.1
|
||||
PShow
|
||||
, -- | @since 1.0.0
|
||||
PNum
|
||||
)
|
||||
|
||||
instance DerivePlutusType PMaxTimeRangeWidth where
|
||||
|
|
@ -303,6 +319,8 @@ pisProposalTimingConfigValid = phoistAcyclic $
|
|||
, confF.votingTime
|
||||
, confF.lockingTime
|
||||
, confF.executingTime
|
||||
, confF.minStakeVotingTime
|
||||
, pto confF.votingTimeRangeMaxWidth
|
||||
]
|
||||
|
||||
{- | Return true if the maximum time width is greater than 0.
|
||||
|
|
@ -322,7 +340,7 @@ pisMaxTimeRangeWidthValid =
|
|||
|
||||
@since 1.0.0
|
||||
-}
|
||||
validateProposalStartingTime ::
|
||||
pvalidateProposalStartingTime ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
|
|
@ -331,26 +349,23 @@ validateProposalStartingTime ::
|
|||
:--> PProposalStartingTime
|
||||
:--> PBool
|
||||
)
|
||||
validateProposalStartingTime = phoistAcyclic $
|
||||
plam $ \(pto -> maxDuration) iv (pto -> st) ->
|
||||
pvalidateProposalStartingTime = phoistAcyclic $
|
||||
plam $ \maxWidth iv (pto -> st) ->
|
||||
pmaybe
|
||||
# ptrace
|
||||
"validateProposalStartingTime: unable to get current time"
|
||||
(pconstant False)
|
||||
# pconstant False
|
||||
# plam
|
||||
( \ct ->
|
||||
let duration = pcurrentTimeDuration # ct
|
||||
isTightEnough =
|
||||
let isTightEnough =
|
||||
ptraceIfFalse
|
||||
"createProposalStartingTime: given time range should be tight enough"
|
||||
$ duration #<= maxDuration
|
||||
$ psatisfyMaximumWidth # maxWidth # ct
|
||||
isInCurrentTimeRange =
|
||||
ptraceIfFalse
|
||||
"createProposalStartingTime: starting time should be in current time range"
|
||||
$ pisWithinCurrentTime # st # ct
|
||||
in isTightEnough #&& isInCurrentTimeRange
|
||||
)
|
||||
# (currentProposalTime # iv)
|
||||
# (pcurrentProposalTime # iv)
|
||||
|
||||
{- | Get the current proposal time, given the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
|
||||
|
||||
|
|
@ -364,8 +379,8 @@ validateProposalStartingTime = phoistAcyclic $
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime)
|
||||
currentProposalTime = phoistAcyclic $
|
||||
pcurrentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime)
|
||||
pcurrentProposalTime = phoistAcyclic $
|
||||
plam $ \iv -> unTermCont $ do
|
||||
PInterval iv' <- pmatchC iv
|
||||
ivf <- pletAllC iv'
|
||||
|
|
@ -386,7 +401,13 @@ currentProposalTime = phoistAcyclic $
|
|||
PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d
|
||||
_ -> ptrace "currentProposalTime: time range should be bounded" pnothing
|
||||
|
||||
mkTime = phoistAcyclic $ plam $ pcon .* PCurrentTime
|
||||
mkTime = phoistAcyclic $
|
||||
plam $ \lb ub ->
|
||||
passert
|
||||
"Upper bound bigger than lower bound"
|
||||
(lb #< ub)
|
||||
(pcon $ PCurrentTime lb ub)
|
||||
|
||||
pure $ pliftA2 # mkTime # lowerBound # upperBound
|
||||
|
||||
{- | Represent relation between current time and a given period.
|
||||
|
|
@ -494,3 +515,22 @@ pgetRelation = phoistAcyclic $
|
|||
pif (plb #<= lb #&& ub #<= pub) (pcon PWithin) $
|
||||
pif (pub #< lb) (pcon PAfter) $
|
||||
ptraceError "pgetRelation: too early or invalid current time"
|
||||
|
||||
{- | Return true if the width of given 'PProposalTime' is shorter than the
|
||||
maximum.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
psatisfyMaximumWidth ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PMaxTimeRangeWidth
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
psatisfyMaximumWidth = phoistAcyclic $
|
||||
plam $ \maxWidth time ->
|
||||
let width = pcurrentTimeDuration # time
|
||||
max = pto maxWidth
|
||||
in width #<= max
|
||||
|
|
|
|||
|
|
@ -12,11 +12,13 @@ module Agora.Stake (
|
|||
-- * Haskell-land
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (..),
|
||||
ProposalAction (..),
|
||||
ProposalLock (..),
|
||||
|
||||
-- * Plutarch-land
|
||||
PStakeDatum (..),
|
||||
PStakeRedeemer (..),
|
||||
PProposalAction (..),
|
||||
PProposalLock (..),
|
||||
PStakeRole (..),
|
||||
|
||||
|
|
@ -42,18 +44,18 @@ module Agora.Stake (
|
|||
) where
|
||||
|
||||
import Agora.Proposal (
|
||||
PProposalDatum,
|
||||
PProposalId,
|
||||
PProposalRedeemer,
|
||||
PProposalStatus,
|
||||
PResultTag,
|
||||
ProposalId,
|
||||
ResultTag,
|
||||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Utils (pmapMaybe, ppureIf)
|
||||
import Agora.Proposal.Time (PProposalTime)
|
||||
import Agora.SafeMoney (GTTag, StakeSTTag)
|
||||
import Data.Tagged (Tagged)
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (PCredential)
|
||||
import Plutarch.Api.V1 (PCredential, PPOSIXTime)
|
||||
import Plutarch.Api.V2 (
|
||||
KeyGuarantees (Unsorted),
|
||||
PDatum,
|
||||
|
|
@ -67,26 +69,62 @@ import Plutarch.DataRepr (
|
|||
DerivePConstantViaData (DerivePConstantViaData),
|
||||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Applicative (ppureIf)
|
||||
import Plutarch.Extra.AssetClass (PAssetClass)
|
||||
import Plutarch.Extra.Field (pletAll)
|
||||
import Plutarch.Extra.IsData (
|
||||
DerivePConstantViaDataList (DerivePConstantViaDataList),
|
||||
ProductIsData (ProductIsData),
|
||||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
|
||||
import Plutarch.Extra.ScriptContext (pfromOutputDatum)
|
||||
import Plutarch.Extra.ScriptContext (ptryFromOutputDatum)
|
||||
import Plutarch.Extra.Sum (PSum (PSum))
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import Plutarch.Extra.Traversable (pfoldMap)
|
||||
import Plutarch.Extra.Value (passetClassValueOf)
|
||||
import Plutarch.Extra.Value (passetClassValueOfT)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
|
||||
import Plutarch.Orphans ()
|
||||
import PlutusLedgerApi.V2 (Credential)
|
||||
import PlutusLedgerApi.V2 (Credential, POSIXTime)
|
||||
import PlutusTx qualified
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | The action that was performed on a particular proposal.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
data ProposalAction
|
||||
= -- | The stake was used to create a proposal.
|
||||
--
|
||||
-- This kind of lock is placed upon the creation of a proposal, in order
|
||||
-- to limit creation of proposals per stake.
|
||||
--
|
||||
-- See also: https://github.com/Liqwid-Labs/agora/issues/68
|
||||
Created
|
||||
| -- | The stake was used to vote on a proposal.
|
||||
--
|
||||
-- This kind of lock is placed while voting on a proposal, in order to
|
||||
-- prevent depositing and withdrawing when votes are in place.
|
||||
Voted
|
||||
ResultTag
|
||||
-- ^ The option which was voted on. This allows votes to be retracted.
|
||||
POSIXTime
|
||||
-- ^ The upper bound of the transaction time range when the lock is created.
|
||||
| -- | The stake was used to cosign a proposal.`
|
||||
Cosigned
|
||||
deriving stock
|
||||
( -- | @since 1.0.0
|
||||
Show
|
||||
, -- | @since 1.0.0
|
||||
Generic
|
||||
)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
''ProposalAction
|
||||
[ ('Created, 0)
|
||||
, ('Voted, 1)
|
||||
, ('Cosigned, 2)
|
||||
]
|
||||
|
||||
{- | Locks that are stored in the stake datums for various purposes.
|
||||
|
||||
NOTE: Due to retracting votes always being possible,
|
||||
|
|
@ -112,45 +150,31 @@ import PlutusTx qualified
|
|||
└──────────────┘ └─────────────────┘
|
||||
@
|
||||
|
||||
@since 0.1.0
|
||||
@since 1.0.0
|
||||
-}
|
||||
data ProposalLock
|
||||
= -- | The stake was used to create a proposal.
|
||||
--
|
||||
-- This kind of lock is placed upon the creation of a proposal, in order
|
||||
-- to limit creation of proposals per stake.
|
||||
--
|
||||
-- See also: https://github.com/Liqwid-Labs/agora/issues/68
|
||||
--
|
||||
-- @since 0.2.0
|
||||
Created
|
||||
ProposalId
|
||||
-- ^ The identifier of the proposal.
|
||||
| -- | The stake was used to vote on a proposal.
|
||||
--
|
||||
-- This kind of lock is placed while voting on a proposal, in order to
|
||||
-- prevent depositing and withdrawing when votes are in place.
|
||||
--
|
||||
-- @since 0.2.0
|
||||
Voted
|
||||
ProposalId
|
||||
-- ^ The identifier of the proposal.
|
||||
ResultTag
|
||||
-- ^ The option which was voted on. This allows votes to be retracted.
|
||||
| Cosigned ProposalId
|
||||
data ProposalLock = ProposalLock
|
||||
{ proposalId :: ProposalId
|
||||
-- ^ The identifier of the proposal.
|
||||
, action :: ProposalAction
|
||||
-- ^ The action that has been performed.
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
''ProposalLock
|
||||
[ ('Created, 0)
|
||||
, ('Voted, 1)
|
||||
, ('Cosigned, 2)
|
||||
]
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
PlutusTx.ToData
|
||||
, -- | @since 0.1.0
|
||||
PlutusTx.FromData
|
||||
)
|
||||
via (ProductIsData ProposalLock)
|
||||
|
||||
{- | Haskell-level redeemer for Stake scripts.
|
||||
|
||||
|
|
@ -160,7 +184,7 @@ data StakeRedeemer
|
|||
= -- | Deposit or withdraw a discrete amount of the staked governance token.
|
||||
-- Stake must be unlocked.
|
||||
DepositWithdraw (Tagged GTTag Integer)
|
||||
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
|
||||
| -- | Destroy a stake, retrieving its GT, the minimum ADA and any other assets.
|
||||
-- Stake must be unlocked.
|
||||
Destroy
|
||||
| -- | Permit a Vote to be added onto a 'Agora.Proposal.Proposal'.
|
||||
|
|
@ -268,6 +292,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum
|
|||
PShow
|
||||
)
|
||||
|
||||
-- | @since 1.0.0
|
||||
instance DerivePlutusType PStakeDatum where
|
||||
type DPTStrat _ = PlutusTypeNewtype
|
||||
|
||||
|
|
@ -291,7 +316,7 @@ instance PTryFrom PData (PAsData PStakeDatum)
|
|||
data PStakeRedeemer (s :: S)
|
||||
= -- | Deposit or withdraw a discrete amount of the staked governance token.
|
||||
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PTagged GTTag PInteger]))
|
||||
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
|
||||
| -- | Destroy a stake, retrieving its GT, the minimum ADA and any other assets.
|
||||
PDestroy (Term s (PDataRecord '[]))
|
||||
| PPermitVote (Term s (PDataRecord '[]))
|
||||
| PRetractVotes (Term s (PDataRecord '[]))
|
||||
|
|
@ -325,32 +350,65 @@ deriving via
|
|||
instance
|
||||
(PConstantDecl StakeRedeemer)
|
||||
|
||||
{- | Plutarch-level version of 'ProposalLock'.
|
||||
{- | Plutarch-level version of 'ProposalAction'.
|
||||
|
||||
@since 0.2.0
|
||||
@since 1.0.0
|
||||
-}
|
||||
data PProposalLock (s :: S)
|
||||
= PCreated
|
||||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'["created" ':= PProposalId]
|
||||
)
|
||||
)
|
||||
data PProposalAction (s :: S)
|
||||
= PCreated (Term s (PDataRecord '[]))
|
||||
| PVoted
|
||||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "votedOn" ':= PProposalId
|
||||
, "votedFor" ':= PResultTag
|
||||
'[ "votedFor" ':= PResultTag
|
||||
, "createdAt" ':= PPOSIXTime
|
||||
]
|
||||
)
|
||||
)
|
||||
| PCosigned
|
||||
| PCosigned (Term s (PDataRecord '[]))
|
||||
deriving stock
|
||||
( -- | @since 1.0.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 1.0.0
|
||||
PlutusType
|
||||
, -- | @since 1.0.0
|
||||
PIsData
|
||||
, -- | @since 1.0.0
|
||||
PEq
|
||||
, -- | @since 1.0.0
|
||||
PShow
|
||||
)
|
||||
|
||||
-- | @since 1.0.0
|
||||
instance DerivePlutusType PProposalAction where
|
||||
type DPTStrat _ = PlutusTypeData
|
||||
|
||||
-- | @since 1.0.0
|
||||
instance PUnsafeLiftDecl PProposalAction where
|
||||
type PLifted _ = ProposalAction
|
||||
|
||||
-- | @since 1.0.0
|
||||
deriving via
|
||||
(DerivePConstantViaData ProposalAction PProposalAction)
|
||||
instance
|
||||
(PConstantDecl ProposalAction)
|
||||
|
||||
-- | @since 1.0.0
|
||||
instance PTryFrom PData PProposalAction
|
||||
|
||||
{- | Plutarch-level version of 'ProposalLock'.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
newtype PProposalLock (s :: S)
|
||||
= PProposalLock
|
||||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "cosigned" ':= PProposalId
|
||||
'[ "proposalId" ':= PProposalId
|
||||
, "action" ':= PProposalAction
|
||||
]
|
||||
)
|
||||
)
|
||||
|
|
@ -365,15 +423,15 @@ data PProposalLock (s :: S)
|
|||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
, -- | @since 1.0.0
|
||||
PDataFields
|
||||
, -- | @since 0.2.0
|
||||
PShow
|
||||
)
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PProposalLock where
|
||||
type DPTStrat _ = PlutusTypeData
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PTryFrom PData PProposalLock
|
||||
type DPTStrat _ = PlutusTypeNewtype
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance PTryFrom PData (PAsData PProposalLock)
|
||||
|
|
@ -384,7 +442,7 @@ instance PUnsafeLiftDecl PProposalLock where
|
|||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
(DerivePConstantViaData ProposalLock PProposalLock)
|
||||
(DerivePConstantViaDataList ProposalLock PProposalLock)
|
||||
instance
|
||||
(PConstantDecl ProposalLock)
|
||||
|
||||
|
|
@ -412,9 +470,11 @@ pnumCreatedProposals =
|
|||
pto $
|
||||
pfoldMap
|
||||
# plam
|
||||
( \(pfromData -> lock) -> pmatch lock $ \case
|
||||
PCreated _ -> pcon $ PSum 1
|
||||
_ -> mempty
|
||||
( \lock ->
|
||||
let action = pfromData $ pfield @"action" # lock
|
||||
in pmatch action $ \case
|
||||
PCreated _ -> pcon $ PSum 1
|
||||
_ -> mempty
|
||||
)
|
||||
# l
|
||||
|
||||
|
|
@ -525,9 +585,9 @@ instance DerivePlutusType PStakeRedeemerContext where
|
|||
data PProposalContext (s :: S)
|
||||
= -- | A proposal is spent.
|
||||
PSpendProposal
|
||||
(Term s PProposalId)
|
||||
(Term s PProposalStatus)
|
||||
(Term s PProposalDatum)
|
||||
(Term s PProposalRedeemer)
|
||||
(Term s PProposalTime)
|
||||
| -- | A new proposal is created.
|
||||
PNewProposal
|
||||
(Term s PProposalId)
|
||||
|
|
@ -665,26 +725,17 @@ pgetStakeRoles ::
|
|||
)
|
||||
pgetStakeRoles = phoistAcyclic $
|
||||
plam $ \pid ->
|
||||
pmapMaybe
|
||||
# plam
|
||||
( flip
|
||||
pmatch
|
||||
( \case
|
||||
PCreated ((pfield @"created" #) -> pid') ->
|
||||
ppureIf
|
||||
# (pid' #== pid)
|
||||
# pcon PCreator
|
||||
PVoted r -> pletAll r $ \rF ->
|
||||
ppureIf
|
||||
# (rF.votedOn #== pid)
|
||||
# pcon (PVoter rF.votedFor)
|
||||
PCosigned ((pfield @"cosigned" #) -> pid') ->
|
||||
ppureIf
|
||||
# (pid' #== pid)
|
||||
# pcon PCosigner
|
||||
)
|
||||
. pfromData
|
||||
)
|
||||
let getStakeRole = flip (pletFields @'["proposalId", "action"]) $
|
||||
\lockF ->
|
||||
ppureIf
|
||||
# (pid #== lockF.proposalId)
|
||||
#$ pmatch lockF.action
|
||||
$ \case
|
||||
PCreated _ -> pcon PCreator
|
||||
PVoted ((pfield @"votedFor" #) -> tag) ->
|
||||
pcon $ PVoter tag
|
||||
PCosigned _ -> pcon PCosigner
|
||||
in pmapMaybe # plam (getStakeRole . pfromData)
|
||||
|
||||
{- | Get the outcome that was voted for.
|
||||
|
||||
|
|
@ -715,7 +766,7 @@ presolveStakeInputDatum ::
|
|||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PAssetClass
|
||||
( PTagged StakeSTTag PAssetClass
|
||||
:--> PMap 'Unsorted PDatumHash PDatum
|
||||
:--> PTxInInfo
|
||||
:--> PMaybe PStakeDatum
|
||||
|
|
@ -726,7 +777,7 @@ presolveStakeInputDatum = phoistAcyclic $
|
|||
(pletFields @'["value", "datum", "address"])
|
||||
( \txOutF ->
|
||||
let isStakeUTxO =
|
||||
passetClassValueOf
|
||||
passetClassValueOfT
|
||||
# sstClass
|
||||
# txOutF.value
|
||||
#== 1
|
||||
|
|
@ -734,7 +785,7 @@ presolveStakeInputDatum = phoistAcyclic $
|
|||
datum =
|
||||
ptrace "Resolve stake datum" $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
ptryFromOutputDatum @(PAsData PStakeDatum)
|
||||
# txOutF.datum
|
||||
# datums
|
||||
in pif
|
||||
|
|
|
|||
|
|
@ -19,13 +19,15 @@ import Agora.Proposal (
|
|||
PProposalRedeemer (PCosign, PUnlockStake, PVote),
|
||||
ProposalStatus (Finished),
|
||||
)
|
||||
import Agora.Proposal.Time (PProposalTime)
|
||||
import Agora.Stake (
|
||||
PProposalAction (PCosigned, PCreated, PVoted),
|
||||
PProposalContext (
|
||||
PNewProposal,
|
||||
PNoProposal,
|
||||
PSpendProposal
|
||||
),
|
||||
PProposalLock (PCosigned, PCreated, PVoted),
|
||||
PProposalLock (PProposalLock),
|
||||
PSigContext (owner, signedBy),
|
||||
PSignedBy (
|
||||
PSignedByDelegate,
|
||||
|
|
@ -48,13 +50,20 @@ import Agora.Stake (
|
|||
),
|
||||
pstakeLocked,
|
||||
)
|
||||
import Agora.Utils (pfromSingleton, pisSingleton, pmustDeleteBy)
|
||||
import Data.Functor ((<&>))
|
||||
import Plutarch.Api.V1.Address (PCredential)
|
||||
import Plutarch.Api.V2 (PMaybeData)
|
||||
import Plutarch.Api.V2 (PMaybeData, PPOSIXTime)
|
||||
import Plutarch.Extra.Bool (passert)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (
|
||||
pisSingleton,
|
||||
ptryDeleteFirstBy,
|
||||
ptryFromSingleton,
|
||||
)
|
||||
import Plutarch.Extra.Maybe (pdjust, pdnothing, pjust, pmaybe, pmaybeData, pnothing)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
|
||||
import Plutarch.Extra.Time (PCurrentTime (PCurrentTime))
|
||||
|
||||
-- | A wrapper which ensures that no proposal is presented in the transaction.
|
||||
pwithoutProposal ::
|
||||
|
|
@ -87,7 +96,7 @@ pbatchUpdateInputs = phoistAcyclic $
|
|||
plam $ \f -> flip pmatch $ \ctxF ->
|
||||
pnull
|
||||
#$ pfoldr
|
||||
# (pmustDeleteBy # f)
|
||||
# plam (\x -> ptryDeleteFirstBy # (f # x))
|
||||
# ctxF.stakeOutputDatums
|
||||
# ctxF.stakeInputDatums
|
||||
|
||||
|
|
@ -159,17 +168,13 @@ pvoteHelper ::
|
|||
:--> PStakeRedeemerHandler
|
||||
)
|
||||
pvoteHelper = phoistAcyclic $
|
||||
plam $ \valProposalCtx ctx -> unTermCont $ do
|
||||
pguardC "Owner or delegate signs this transaction" $
|
||||
pisSignedBy # pconstant True # ctx
|
||||
|
||||
plam $ \valProposalCtx ctx ->
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
|
||||
pguardC "Correct outputs" $
|
||||
ponlyLocksUpdated # (valProposalCtx # ctx) # ctx
|
||||
|
||||
pure $ pconstant ()
|
||||
passert
|
||||
"Correct outputs"
|
||||
(ponlyLocksUpdated # (valProposalCtx # ctx) # ctx)
|
||||
(pconstant ())
|
||||
|
||||
-- | Add new lock the the existing list of locked.
|
||||
paddNewLock ::
|
||||
|
|
@ -199,33 +204,60 @@ ppermitVote = pvoteHelper #$ phoistAcyclic $
|
|||
pguardC "Only one stake input allowed" $
|
||||
pisSingleton # ctxF.stakeInputDatums
|
||||
|
||||
pguardC "Owner signs this transaction" $
|
||||
pisSignedBy # pconstant False # ctx
|
||||
|
||||
pure lock
|
||||
|
||||
pure $
|
||||
paddNewLock #$ pmatch ctxF.proposalContext $ \case
|
||||
PSpendProposal pid _ r -> pmatch r $ \case
|
||||
PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) ->
|
||||
mkRecordConstr
|
||||
PVoted
|
||||
( #votedOn
|
||||
.= pdata pid
|
||||
.& #votedFor
|
||||
.= pdata voteFor
|
||||
)
|
||||
PCosign _ ->
|
||||
withOnlyOneStakeInput
|
||||
#$ mkRecordConstr
|
||||
PCosigned
|
||||
( #cosigned .= pdata pid
|
||||
PSpendProposal proposal redeemer currentTime -> unTermCont $ do
|
||||
mkLock <- pletC $
|
||||
plam $ \action ->
|
||||
mkRecordConstr
|
||||
PProposalLock
|
||||
( #proposalId
|
||||
.= pfield @"proposalId"
|
||||
# proposal
|
||||
.& #action
|
||||
.= pdata action
|
||||
)
|
||||
_ -> ptraceError "Expected Vote"
|
||||
PNewProposal pid ->
|
||||
withOnlyOneStakeInput
|
||||
#$ mkRecordConstr
|
||||
PCreated
|
||||
( #created .= pdata pid
|
||||
)
|
||||
_ -> ptraceError "Expected proposal"
|
||||
|
||||
pure $
|
||||
pmatch redeemer $ \case
|
||||
PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) ->
|
||||
unTermCont $ do
|
||||
pguardC "Owner or delegatee signs the transaction" $
|
||||
pisSignedBy # pconstant True # ctx
|
||||
|
||||
PCurrentTime _ upperBound <- pmatchC currentTime
|
||||
|
||||
let action =
|
||||
mkRecordConstr
|
||||
PVoted
|
||||
( #votedFor
|
||||
.= pdata voteFor
|
||||
.& #createdAt
|
||||
.= pdata upperBound
|
||||
)
|
||||
|
||||
pure $ mkLock # action
|
||||
PCosign _ ->
|
||||
let action = pcon $ PCosigned pdnil
|
||||
in withOnlyOneStakeInput #$ mkLock # action
|
||||
_ -> ptraceError "Expected Vote or Cosign"
|
||||
PNewProposal proposalId ->
|
||||
let action = pcon $ PCreated pdnil
|
||||
lock =
|
||||
mkRecordConstr
|
||||
PProposalLock
|
||||
( #proposalId
|
||||
.= pdata proposalId
|
||||
.& #action
|
||||
.= pdata action
|
||||
)
|
||||
in withOnlyOneStakeInput # lock
|
||||
_ -> ptraceError "Expected a proposal to be spent or created"
|
||||
|
||||
data PRemoveLocksMode (s :: S) = PRemoveVoterLockOnly | PRemoveAllLocks
|
||||
deriving stock (Generic)
|
||||
|
|
@ -235,33 +267,59 @@ instance DerivePlutusType PRemoveLocksMode where
|
|||
type DPTStrat _ = PlutusTypeScott
|
||||
|
||||
{- | Remove stake locks with the proposal id given the list of existing locks.
|
||||
The first parameter controls whether to revmove creator locks or not.
|
||||
The first parameter controls whether to remove creator locks or not. If
|
||||
one of the locks performed voting action, the unlock cooldown will be
|
||||
checked if it's given.
|
||||
-}
|
||||
premoveLocks ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PProposalId
|
||||
:--> PMaybe PPOSIXTime
|
||||
:--> PProposalTime
|
||||
:--> PRemoveLocksMode
|
||||
:--> PBuiltinList (PAsData PProposalLock)
|
||||
:--> PBuiltinList (PAsData PProposalLock)
|
||||
)
|
||||
premoveLocks = phoistAcyclic $
|
||||
plam $ \pid rl -> unTermCont $ do
|
||||
shouldRemoveOtherLocks <- pletC $
|
||||
plam $ \pid' ->
|
||||
pid' #== pid #&& rl #== pcon PRemoveAllLocks
|
||||
premoveLocks =
|
||||
phoistAcyclic $
|
||||
plam $ \proposalId unlockCooldown currentTime mode -> unTermCont $ do
|
||||
shouldRemoveAllLocks <- pletC $ mode #== pcon PRemoveAllLocks
|
||||
|
||||
pure $
|
||||
pfilter
|
||||
# plam
|
||||
( \(pfromData -> l) -> pnot #$ pmatch l $ \case
|
||||
PCosigned ((pfield @"cosigned" #) -> pid') ->
|
||||
shouldRemoveOtherLocks # pid'
|
||||
PCreated ((pfield @"created" #) -> pid') ->
|
||||
shouldRemoveOtherLocks # pid'
|
||||
PVoted ((pfield @"votedOn" #) -> pid') -> pid' #== pid
|
||||
)
|
||||
PCurrentTime lowerBound _ <- pmatchC currentTime
|
||||
|
||||
let handleVoter
|
||||
( (pfield @"createdAt" #) ->
|
||||
createdAt
|
||||
) =
|
||||
let notInCooldown =
|
||||
pmaybe
|
||||
# pconstant True
|
||||
# plam (\c -> createdAt + c #<= lowerBound)
|
||||
# unlockCooldown
|
||||
in foldl1
|
||||
(#||)
|
||||
[ shouldRemoveAllLocks
|
||||
, ptraceIfFalse "Stake lock in cooldown" notInCooldown
|
||||
]
|
||||
|
||||
handleLock =
|
||||
plam $
|
||||
flip
|
||||
pletAll
|
||||
( \lockF ->
|
||||
foldl1
|
||||
(#&&)
|
||||
[ proposalId #== lockF.proposalId
|
||||
, pmatch lockF.action $ \case
|
||||
PVoted r -> handleVoter r
|
||||
_ -> shouldRemoveAllLocks
|
||||
]
|
||||
)
|
||||
. pfromData
|
||||
|
||||
pure $ pfilter # handleLock
|
||||
|
||||
{- | Default implementation of 'Agora.Stake.RetractVotes'.
|
||||
|
||||
|
|
@ -269,17 +327,41 @@ premoveLocks = phoistAcyclic $
|
|||
-}
|
||||
pretractVote :: forall (s :: S). Term s PStakeRedeemerHandler
|
||||
pretractVote = pvoteHelper #$ phoistAcyclic $
|
||||
plam $
|
||||
flip pmatch $ \ctxF ->
|
||||
plam $ \ctx ->
|
||||
pmatch ctx $ \ctxF ->
|
||||
pmatch ctxF.proposalContext $ \case
|
||||
PSpendProposal pid s r -> pmatch r $ \case
|
||||
PUnlockStake _ ->
|
||||
let mode =
|
||||
pif
|
||||
(s #== pconstant Finished)
|
||||
(pcon PRemoveAllLocks)
|
||||
(pcon PRemoveVoterLockOnly)
|
||||
in premoveLocks # pid # mode
|
||||
PSpendProposal proposal redeemer currentTime -> pmatch redeemer $ \case
|
||||
PUnlockStake _ -> unTermCont $ do
|
||||
proposalF <-
|
||||
pletFieldsC
|
||||
@'[ "proposalId"
|
||||
, "status"
|
||||
, "timingConfig"
|
||||
]
|
||||
proposal
|
||||
|
||||
(mode, unlockCooldown) <-
|
||||
pmatchC (proposalF.status #== pconstant Finished) <&> \case
|
||||
PTrue ->
|
||||
( pcon PRemoveAllLocks
|
||||
, pnothing
|
||||
)
|
||||
_ ->
|
||||
( pcon PRemoveVoterLockOnly
|
||||
, pjust
|
||||
#$ pfield @"minStakeVotingTime"
|
||||
# proposalF.timingConfig
|
||||
)
|
||||
|
||||
pguardC "Authorized by either opwner or delegatee" $
|
||||
pisSignedBy # pconstant True # ctx
|
||||
|
||||
pure $
|
||||
premoveLocks
|
||||
# proposalF.proposalId
|
||||
# unlockCooldown
|
||||
# currentTime
|
||||
# mode
|
||||
_ -> ptraceError "Expected unlock"
|
||||
_ -> ptraceError "Expected spending proposal"
|
||||
|
||||
|
|
@ -387,12 +469,12 @@ pdepositWithdraw = phoistAcyclic $
|
|||
stakeInputDatum <-
|
||||
pletC $
|
||||
ptrace "Single stake input" $
|
||||
pfromSingleton # ctxF.stakeInputDatums
|
||||
ptryFromSingleton # ctxF.stakeInputDatums
|
||||
stakeInputDatumF <- pletAllC stakeInputDatum
|
||||
|
||||
let stakeOutputDatum =
|
||||
ptrace "Single stake output" $
|
||||
pfromSingleton # ctxF.stakeOutputDatums
|
||||
ptryFromSingleton # ctxF.stakeOutputDatums
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -13,6 +13,8 @@ module Agora.Stake.Scripts (
|
|||
|
||||
import Agora.Credential (authorizationContext, pauthorizedBy)
|
||||
import Agora.Proposal (PProposalDatum, PProposalRedeemer)
|
||||
import Agora.Proposal.Time (pcurrentProposalTime)
|
||||
import Agora.SafeMoney (GTTag, ProposalSTTag, StakeSTTag)
|
||||
import Agora.Stake (
|
||||
PProposalContext (
|
||||
PNewProposal,
|
||||
|
|
@ -52,13 +54,7 @@ import Agora.Stake.Redeemers (
|
|||
ppermitVote,
|
||||
pretractVote,
|
||||
)
|
||||
import Agora.Utils (
|
||||
passert,
|
||||
pisDNothing,
|
||||
pmapMaybe,
|
||||
psymbolValueOf',
|
||||
pvalidatorHashToTokenName,
|
||||
)
|
||||
import Agora.Utils (pisDNothing, ptoScottEncodingT, puntag)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PCurrencySymbol,
|
||||
|
|
@ -77,13 +73,14 @@ import Plutarch.Extra.AssetClass (
|
|||
PAssetClass,
|
||||
PAssetClassData,
|
||||
passetClass,
|
||||
ptoScottEncoding,
|
||||
)
|
||||
import Plutarch.Extra.Bool (passert)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import Plutarch.Extra.Functor (PFunctor (pfmap))
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
|
||||
import Plutarch.Extra.Maybe (
|
||||
passertPJust,
|
||||
pdjust,
|
||||
pfromJust,
|
||||
pfromMaybe,
|
||||
pjust,
|
||||
|
|
@ -93,9 +90,12 @@ import Plutarch.Extra.Maybe (
|
|||
import Plutarch.Extra.Ord (POrdering (PEQ, PGT, PLT), pcompareBy, pfromOrd)
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromOutputDatum,
|
||||
ptryFromOutputDatum,
|
||||
pvalidatorHashFromAddress,
|
||||
pvalidatorHashToTokenName,
|
||||
pvalueSpent,
|
||||
)
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
||||
pguardC,
|
||||
pletC,
|
||||
|
|
@ -105,7 +105,9 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
|||
)
|
||||
import Plutarch.Extra.Value (
|
||||
passetClassValueOf,
|
||||
passetClassValueOfT,
|
||||
psymbolValueOf,
|
||||
psymbolValueOf',
|
||||
)
|
||||
import Plutarch.Num (PNum (pnegate))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
|
|
@ -131,15 +133,14 @@ import Prelude hiding (Num ((+)))
|
|||
== Arguments
|
||||
|
||||
Following arguments should be provided(in this order):
|
||||
1. governor ST assetclass
|
||||
1. governance token assetclass
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
stakePolicy ::
|
||||
-- | The (governance) token that a Stake can store.
|
||||
ClosedTerm (PAssetClassData :--> PMintingPolicy)
|
||||
ClosedTerm (PTagged GTTag PAssetClassData :--> PMintingPolicy)
|
||||
stakePolicy =
|
||||
plam $ \gstClass _redeemer ctx' -> unTermCont $ do
|
||||
plam $ \gtClass _redeemer ctx' -> unTermCont $ do
|
||||
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- pletC $ ctx.txInfo
|
||||
let _a :: Term _ PTxInfo
|
||||
|
|
@ -197,7 +198,7 @@ stakePolicy =
|
|||
datumF <-
|
||||
pletAllC $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
ptryFromOutputDatum @(PAsData PStakeDatum)
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
|
||||
|
|
@ -205,10 +206,10 @@ stakePolicy =
|
|||
foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Stake ouput has expected amount of stake token" $
|
||||
passetClassValueOf
|
||||
# (ptoScottEncoding # gstClass)
|
||||
passetClassValueOfT
|
||||
# (ptoScottEncodingT # gtClass)
|
||||
# outputF.value
|
||||
#== pto (pfromData datumF.stakedAmount)
|
||||
#== pfromData datumF.stakedAmount
|
||||
, ptraceIfFalse "Stake Owner should sign the transaction" $
|
||||
pauthorizedBy
|
||||
# authorizationContext txInfoF
|
||||
|
|
@ -232,17 +233,17 @@ stakePolicy =
|
|||
Following arguments should be provided(in this order):
|
||||
1. stake ST symbol
|
||||
2. proposal ST assetclass
|
||||
3. governor ST assetclass
|
||||
3. governance token assetclass
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
mkStakeValidator ::
|
||||
StakeRedeemerImpl s ->
|
||||
Term s PCurrencySymbol ->
|
||||
Term s PAssetClass ->
|
||||
Term s PAssetClass ->
|
||||
Term s (PTagged StakeSTTag PCurrencySymbol) ->
|
||||
Term s (PTagged ProposalSTTag PAssetClass) ->
|
||||
Term s (PTagged GTTag PAssetClass) ->
|
||||
Term s PValidator
|
||||
mkStakeValidator impl sstSymbol pstClass gstClass =
|
||||
mkStakeValidator impl sstSymbol pstClass gtClass =
|
||||
plam $ \_datum redeemer ctx -> unTermCont $ do
|
||||
ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
|
||||
txInfo <- pletC $ pfromData ctxF.txInfo
|
||||
|
|
@ -256,6 +257,7 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
, "signatories"
|
||||
, "redeemers"
|
||||
, "datums"
|
||||
, "validRange"
|
||||
]
|
||||
txInfo
|
||||
|
||||
|
|
@ -271,18 +273,16 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
# (pfield @"_0" # stakeInputRef)
|
||||
# txInfoF.inputs
|
||||
|
||||
stakeValidatorCredential <-
|
||||
stakeValidatorHash <-
|
||||
pletC $
|
||||
pfield @"credential"
|
||||
pfromJust
|
||||
#$ pvalidatorHashFromAddress
|
||||
#$ pfield @"address"
|
||||
# validatedInput
|
||||
|
||||
let sstName = pvalidatorHashToTokenName #$ pmatch stakeValidatorCredential $
|
||||
\case
|
||||
PScriptCredential r -> pfield @"_0" # r
|
||||
_ -> perror
|
||||
let sstName = pvalidatorHashToTokenName stakeValidatorHash
|
||||
|
||||
sstClass <- pletC $ passetClass # sstSymbol # sstName
|
||||
sstClass <- pletC $ passetClass # puntag sstSymbol # sstName
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -302,15 +302,18 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
PGT -> ptraceError "More than one SST in one UTxO"
|
||||
-- 1
|
||||
PEQ ->
|
||||
let ownerCredential = pfield @"credential" # txOutF.address
|
||||
let ownerValidatoHash =
|
||||
pfromJust
|
||||
#$ pvalidatorHashFromAddress
|
||||
# txOutF.address
|
||||
|
||||
isOwnedByStakeValidator =
|
||||
ownerCredential #== stakeValidatorCredential
|
||||
ownerValidatoHash #== stakeValidatorHash
|
||||
|
||||
datum =
|
||||
ptrace "Resolve stake datum" $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
ptryFromOutputDatum @(PAsData PStakeDatum)
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in passert
|
||||
|
|
@ -342,7 +345,7 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
|
||||
authorizedBy <- pletC $ pauthorizedBy # authorizationContext txInfoF
|
||||
|
||||
PPair allHaveSameOwner allHaveSameDelegatee <-
|
||||
PPair allHaveSameOwner allHaveSameOrOwnedByDelegatee <-
|
||||
pmatchC $
|
||||
pfoldr
|
||||
# plam
|
||||
|
|
@ -355,11 +358,15 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
allHaveSameOwner
|
||||
#&& dF.owner
|
||||
#== firstStakeInputDatumF.owner
|
||||
allHaveSameDelegatee' =
|
||||
allHaveSameDelegatee
|
||||
#&& dF.delegatedTo
|
||||
#== firstStakeInputDatumF.delegatedTo
|
||||
in pcon $ PPair allHaveSameOwner' allHaveSameDelegatee'
|
||||
allHaveSameOrOwnedByDelegatee' =
|
||||
let delegated =
|
||||
dF.delegatedTo #== firstStakeInputDatumF.delegatedTo
|
||||
ownedByDelegatee =
|
||||
pdata (pdjust # dF.owner)
|
||||
#== firstStakeInputDatumF.delegatedTo
|
||||
in allHaveSameDelegatee
|
||||
#&& (delegated #|| ownedByDelegatee)
|
||||
in pcon $ PPair allHaveSameOwner' allHaveSameOrOwnedByDelegatee'
|
||||
)
|
||||
# pcon (PPair (pconstant True) (pconstant True))
|
||||
# restOfStakeInputDatums
|
||||
|
|
@ -370,7 +377,7 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
# firstStakeInputDatumF.owner
|
||||
|
||||
delegateSignsTransaction =
|
||||
allHaveSameDelegatee
|
||||
allHaveSameOrOwnedByDelegatee
|
||||
#&& pmaybeData
|
||||
# pconstant False
|
||||
# plam ((authorizedBy #) . pfromData)
|
||||
|
|
@ -407,13 +414,12 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
( \output ->
|
||||
let validateGT = plam $ \stakeDatum ->
|
||||
let expected =
|
||||
pto $
|
||||
pfromData $
|
||||
pfield @"stakedAmount" # stakeDatum
|
||||
pfromData $
|
||||
pfield @"stakedAmount" # stakeDatum
|
||||
|
||||
actual =
|
||||
passetClassValueOf
|
||||
# gstClass
|
||||
passetClassValueOfT
|
||||
# gtClass
|
||||
# (pfield @"value" # output)
|
||||
in pif
|
||||
(expected #== actual)
|
||||
|
|
@ -433,19 +439,20 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
plam $
|
||||
flip pletAll $ \txOutF ->
|
||||
let isProposalUTxO =
|
||||
passetClassValueOf
|
||||
passetClassValueOfT
|
||||
# pstClass
|
||||
# txOutF.value
|
||||
#== 1
|
||||
|
||||
proposalDatum =
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PProposalDatum)
|
||||
ptryFromOutputDatum @(PAsData PProposalDatum)
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in pif isProposalUTxO (pjust # proposalDatum) pnothing
|
||||
|
||||
let pstMinted =
|
||||
passetClassValueOf # pstClass # txInfoF.mint #== 1
|
||||
passetClassValueOfT # pstClass # txInfoF.mint #== 1
|
||||
|
||||
newProposalContext =
|
||||
pcon $
|
||||
|
|
@ -477,10 +484,13 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
pfmap
|
||||
# plam
|
||||
( \proposalDatum ->
|
||||
let id = pfield @"proposalId" # proposalDatum
|
||||
status = pfield @"status" # proposalDatum
|
||||
redeemer = getProposalRedeemer # inInfoF.outRef
|
||||
in pcon $ PSpendProposal id status redeemer
|
||||
let redeemer = getProposalRedeemer # inInfoF.outRef
|
||||
currentTime =
|
||||
passertPJust
|
||||
# "Should resolve proposal time"
|
||||
#$ pcurrentProposalTime
|
||||
# txInfoF.validRange
|
||||
in pcon $ PSpendProposal proposalDatum redeemer currentTime
|
||||
)
|
||||
#$ getProposalDatum
|
||||
# pfromData inInfoF.resolved
|
||||
|
|
@ -598,15 +608,15 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
Following arguments should be provided(in this order):
|
||||
1. stake ST symbol
|
||||
2. proposal ST assetclass
|
||||
3. governor ST assetclass
|
||||
3. governance token assetclass
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
stakeValidator ::
|
||||
ClosedTerm
|
||||
( PCurrencySymbol
|
||||
:--> PAssetClassData
|
||||
:--> PAssetClassData
|
||||
( PTagged StakeSTTag PCurrencySymbol
|
||||
:--> PTagged ProposalSTTag PAssetClassData
|
||||
:--> PTagged GTTag PAssetClassData
|
||||
:--> PValidator
|
||||
)
|
||||
stakeValidator =
|
||||
|
|
@ -622,5 +632,5 @@ stakeValidator =
|
|||
}
|
||||
)
|
||||
sstSymbol
|
||||
(ptoScottEncoding # pstClass)
|
||||
(ptoScottEncoding # gstClass)
|
||||
(ptoScottEncodingT # pstClass)
|
||||
(ptoScottEncodingT # gstClass)
|
||||
|
|
|
|||
|
|
@ -13,8 +13,10 @@ module Agora.Treasury (
|
|||
) where
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.SafeMoney (AuthorityTokenTag)
|
||||
import Plutarch.Api.V1.Value (PCurrencySymbol, PValue)
|
||||
import Plutarch.Api.V2 (PScriptPurpose (PSpending), PValidator)
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletFieldsC, pmatchC)
|
||||
|
||||
{- | Validator ensuring that transactions consuming the treasury
|
||||
|
|
@ -25,10 +27,10 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletFieldsC, pm
|
|||
Following arguments should be provided(in this order):
|
||||
1. authority token symbol
|
||||
|
||||
@since 0.1.0
|
||||
@since 1.0.0
|
||||
-}
|
||||
treasuryValidator ::
|
||||
ClosedTerm (PCurrencySymbol :--> PValidator)
|
||||
ClosedTerm (PTagged AuthorityTokenTag PCurrencySymbol :--> PValidator)
|
||||
treasuryValidator = plam $ \atSymbol _ _ ctx' -> unTermCont $ do
|
||||
-- plet required fields from script context.
|
||||
ctx <- pletFieldsC @["txInfo", "purpose"] ctx'
|
||||
|
|
|
|||
|
|
@ -8,101 +8,34 @@ Description: Plutarch utility functions that should be upstreamed or don't belon
|
|||
Plutarch utility functions that should be upstreamed or don't belong anywhere else.
|
||||
-}
|
||||
module Agora.Utils (
|
||||
validatorHashToTokenName,
|
||||
validatorHashToAddress,
|
||||
pltAsData,
|
||||
withBuiltinPairAsData,
|
||||
pvalidatorHashToTokenName,
|
||||
pscriptHashToTokenName,
|
||||
scriptHashToTokenName,
|
||||
plistEqualsBy,
|
||||
pstringIntercalate,
|
||||
punwords,
|
||||
pcurrentTimeDuration,
|
||||
pdelete,
|
||||
pdeleteBy,
|
||||
pmustDeleteBy,
|
||||
pisSingleton,
|
||||
pfromSingleton,
|
||||
pmapMaybe,
|
||||
PAlternative (..),
|
||||
ppureIf,
|
||||
pltBy,
|
||||
pinsertUniqueBy,
|
||||
ptryFromRedeemer,
|
||||
passert,
|
||||
pisNothing,
|
||||
pisDNothing,
|
||||
psymbolValueOf',
|
||||
ptoScottEncodingT,
|
||||
ptaggedSymbolValueOf,
|
||||
ptag,
|
||||
puntag,
|
||||
) where
|
||||
|
||||
import Plutarch.Api.V1 (
|
||||
KeyGuarantees (Unsorted),
|
||||
PPOSIXTime,
|
||||
PRedeemer,
|
||||
PValidatorHash,
|
||||
)
|
||||
import Plutarch.Api.V1.AssocMap (PMap, plookup)
|
||||
import Plutarch.Api.V2 (
|
||||
AmountGuarantees,
|
||||
KeyGuarantees,
|
||||
PCurrencySymbol,
|
||||
PMaybeData (PDNothing),
|
||||
PScriptHash,
|
||||
PScriptPurpose,
|
||||
PTokenName,
|
||||
PValue,
|
||||
)
|
||||
import Plutarch.Extra.Applicative (PApplicative (ppure))
|
||||
import Plutarch.Extra.Category (PCategory (pidentity))
|
||||
import Plutarch.Extra.Functor (PFunctor (PSubcategory, pfmap))
|
||||
import Plutarch.Extra.Maybe (pjust, pnothing)
|
||||
import Plutarch.Extra.Ord (PComparator, POrdering (PLT), pcompareBy, pequateBy)
|
||||
import Plutarch.Extra.Time (PCurrentTime (PCurrentTime))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import Plutarch.Extra.AssetClass (PAssetClass, PAssetClassData, ptoScottEncoding)
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import Plutarch.Extra.Value (psymbolValueOf)
|
||||
import Plutarch.Unsafe (punsafeDowncast)
|
||||
import PlutusLedgerApi.V2 (
|
||||
Address (Address),
|
||||
Credential (ScriptCredential),
|
||||
ScriptHash (ScriptHash),
|
||||
TokenName (TokenName),
|
||||
ValidatorHash (ValidatorHash),
|
||||
ValidatorHash,
|
||||
)
|
||||
|
||||
{- Functions which should (probably) not be upstreamed
|
||||
All of these functions are quite inefficient.
|
||||
-}
|
||||
|
||||
{- | Safely convert a 'ValidatorHash' into a 'TokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
validatorHashToTokenName :: ValidatorHash -> TokenName
|
||||
validatorHashToTokenName (ValidatorHash hash) = TokenName hash
|
||||
|
||||
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pvalidatorHashToTokenName :: forall (s :: S). Term s (PValidatorHash :--> PTokenName)
|
||||
pvalidatorHashToTokenName = phoistAcyclic $ plam punsafeCoerce
|
||||
|
||||
{- | Safely convert a 'PScriptHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
scriptHashToTokenName :: ScriptHash -> TokenName
|
||||
scriptHashToTokenName (ScriptHash hash) = TokenName hash
|
||||
|
||||
{- | Safely convert a 'PScriptHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pscriptHashToTokenName :: forall (s :: S). Term s PScriptHash -> Term s PTokenName
|
||||
pscriptHashToTokenName = punsafeCoerce
|
||||
|
||||
{- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
|
||||
|
||||
@since 0.1.0
|
||||
|
|
@ -110,62 +43,6 @@ pscriptHashToTokenName = punsafeCoerce
|
|||
validatorHashToAddress :: ValidatorHash -> Address
|
||||
validatorHashToAddress vh = Address (ScriptCredential vh) Nothing
|
||||
|
||||
{- | Compare two 'PAsData' value, return true if the first one is less than the second one.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pltAsData ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(POrd a, PIsData a) =>
|
||||
Term s (PAsData a :--> PAsData a :--> PBool)
|
||||
pltAsData = phoistAcyclic $
|
||||
plam $
|
||||
\(pfromData -> l) (pfromData -> r) -> l #< r
|
||||
|
||||
{- | Extract data stored in a 'PBuiltinPair' and call a function to process it.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
withBuiltinPairAsData ::
|
||||
forall (a :: PType) (b :: PType) (c :: PType) (s :: S).
|
||||
(PIsData a, PIsData b) =>
|
||||
(Term s a -> Term s b -> Term s c) ->
|
||||
Term
|
||||
s
|
||||
(PBuiltinPair (PAsData a) (PAsData b)) ->
|
||||
Term s c
|
||||
withBuiltinPairAsData f p =
|
||||
let a = pfromData $ pfstBuiltin # p
|
||||
b = pfromData $ psndBuiltin # p
|
||||
in f a b
|
||||
|
||||
-- | @since 1.0.0
|
||||
plistEqualsBy ::
|
||||
forall
|
||||
(list1 :: PType -> PType)
|
||||
(list2 :: PType -> PType)
|
||||
(a :: PType)
|
||||
(b :: PType)
|
||||
(s :: S).
|
||||
(PIsListLike list1 a, PIsListLike list2 b) =>
|
||||
Term s ((a :--> b :--> PBool) :--> list1 a :--> list2 b :--> PBool)
|
||||
plistEqualsBy = phoistAcyclic $
|
||||
plam $ \eq -> pfix #$ plam $ \self l1 l2 ->
|
||||
pelimList
|
||||
( \x xs ->
|
||||
pelimList
|
||||
( \y ys ->
|
||||
-- Avoid comparison if two lists have different length.
|
||||
self # xs # ys #&& eq # x # y
|
||||
)
|
||||
-- l2 is empty, but l1 is not.
|
||||
(pconstant False)
|
||||
l2
|
||||
)
|
||||
-- l1 is empty, so l2 should be empty as well.
|
||||
(pnull # l2)
|
||||
l1
|
||||
|
||||
-- | @since 1.0.0
|
||||
pstringIntercalate ::
|
||||
forall (s :: S).
|
||||
|
|
@ -183,225 +60,6 @@ punwords ::
|
|||
Term s PString
|
||||
punwords = pstringIntercalate " "
|
||||
|
||||
-- | @since 1.0.0
|
||||
pcurrentTimeDuration ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PCurrentTime
|
||||
:--> PPOSIXTime
|
||||
)
|
||||
pcurrentTimeDuration = phoistAcyclic $
|
||||
plam $
|
||||
flip pmatch $
|
||||
\(PCurrentTime lb ub) -> ub - lb
|
||||
|
||||
{- | / O(n) /. Remove the first occurance of a value from the given list.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pdelete ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PEq a, PIsListLike list a) =>
|
||||
Term s (a :--> list a :--> PMaybe (list a))
|
||||
pdelete = phoistAcyclic $ pdeleteBy # plam (#==)
|
||||
|
||||
-- | @since 1.0.0
|
||||
pdeleteBy ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s ((a :--> a :--> PBool) :--> a :--> list a :--> PMaybe (list a))
|
||||
pdeleteBy = phoistAcyclic $
|
||||
plam $ \f' x -> plet (f' # x) $ \f ->
|
||||
precList
|
||||
( \self h t ->
|
||||
pif
|
||||
(f # h)
|
||||
(pjust # t)
|
||||
(pfmap # (pcons # h) # (self # t))
|
||||
)
|
||||
(const pnothing)
|
||||
|
||||
-- | @since 1.0.0
|
||||
pmustDeleteBy ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s ((a :--> a :--> PBool) :--> a :--> list a :--> list a)
|
||||
pmustDeleteBy = phoistAcyclic $
|
||||
plam $ \f' x -> plet (f' # x) $ \f ->
|
||||
precList
|
||||
( \self h t ->
|
||||
pif
|
||||
(f # h)
|
||||
t
|
||||
(pcons # h #$ self # t)
|
||||
)
|
||||
(const $ ptraceError "Cannot delete element")
|
||||
|
||||
{- | / O(1) /.Return true if the given list has only one element.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pisSingleton ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s (list a :--> PBool)
|
||||
pisSingleton =
|
||||
phoistAcyclic $
|
||||
precList
|
||||
(\_ _ t -> pnull # t)
|
||||
(const $ pconstant False)
|
||||
|
||||
{- Throws an error if the given list contains zero or more than one elements.
|
||||
Otherwise returns the only element.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pfromSingleton ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s (list a :--> a)
|
||||
pfromSingleton =
|
||||
phoistAcyclic $
|
||||
precList
|
||||
( \_ h t ->
|
||||
pif
|
||||
(pnull # t)
|
||||
h
|
||||
(ptraceError "More than one element")
|
||||
)
|
||||
(const $ ptraceError "Empty list")
|
||||
|
||||
{- | A version of 'pmap' which can throw out elements and change the list type
|
||||
along the way.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pmapMaybe ::
|
||||
forall
|
||||
(listO :: PType -> PType)
|
||||
(b :: PType)
|
||||
(listI :: PType -> PType)
|
||||
(a :: PType)
|
||||
(s :: S).
|
||||
(PIsListLike listI a, PIsListLike listO b) =>
|
||||
Term s ((a :--> PMaybe b) :--> listI a :--> listO b)
|
||||
pmapMaybe = phoistAcyclic $
|
||||
plam $ \f ->
|
||||
precList
|
||||
( \self h t ->
|
||||
pmatch
|
||||
(f # h)
|
||||
( \case
|
||||
PJust x -> pcons # x
|
||||
PNothing -> pidentity
|
||||
)
|
||||
# (self # t)
|
||||
)
|
||||
(const pnil)
|
||||
|
||||
infixl 3 #<|>
|
||||
|
||||
-- | @since 1.0.0
|
||||
class (PApplicative f) => PAlternative (f :: PType -> PType) where
|
||||
(#<|>) ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(PSubcategory f a) =>
|
||||
Term s (f a :--> f a :--> f a)
|
||||
pempty ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(PSubcategory f a) =>
|
||||
Term s (f a)
|
||||
|
||||
-- | @since 1.0.0
|
||||
instance PAlternative PMaybe where
|
||||
(#<|>) = phoistAcyclic $
|
||||
plam $ \a b -> pmatch a $ \case
|
||||
PNothing -> b
|
||||
PJust _ -> a
|
||||
pempty = pnothing
|
||||
|
||||
-- | @since 1.0.0
|
||||
ppureIf ::
|
||||
forall
|
||||
(f :: PType -> PType)
|
||||
(a :: PType)
|
||||
(s :: S).
|
||||
(PAlternative f, PSubcategory f a) =>
|
||||
Term s (PBool :--> a :--> f a)
|
||||
ppureIf = phoistAcyclic $
|
||||
plam $ \cond x ->
|
||||
pif
|
||||
cond
|
||||
(ppure # x)
|
||||
pempty
|
||||
|
||||
{- | Less then check using a `PComparator`.
|
||||
|
||||
@ since 1.0.0
|
||||
-}
|
||||
pltBy ::
|
||||
forall (a :: PType) (s :: S).
|
||||
Term
|
||||
s
|
||||
( PComparator a
|
||||
:--> a
|
||||
:--> a
|
||||
:--> PBool
|
||||
)
|
||||
pltBy = phoistAcyclic $
|
||||
plam $ \c x y ->
|
||||
pcompareBy # c # x # y #== pcon PLT
|
||||
|
||||
-- | @since 1.0.0
|
||||
pinsertUniqueBy ::
|
||||
forall (list :: PType -> PType) (a :: PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s (PComparator a :--> a :--> list a :--> list a)
|
||||
pinsertUniqueBy = phoistAcyclic $
|
||||
plam $ \c x ->
|
||||
let lt = pltBy # c
|
||||
eq = pequateBy # c
|
||||
in precList
|
||||
( \self h t ->
|
||||
let ensureUniqueness =
|
||||
pif
|
||||
(eq # x # h)
|
||||
(ptraceError "inserted value already exists")
|
||||
next =
|
||||
pif
|
||||
(lt # x # h)
|
||||
(pcons # x #$ pcons # h # t)
|
||||
(pcons # h #$ self # t)
|
||||
in ensureUniqueness next
|
||||
)
|
||||
(const $ psingleton # x)
|
||||
|
||||
-- | @since 1.0.0
|
||||
ptryFromRedeemer ::
|
||||
forall (r :: PType) (s :: S).
|
||||
(PTryFrom PData r) =>
|
||||
Term
|
||||
s
|
||||
( PScriptPurpose
|
||||
:--> PMap 'Unsorted PScriptPurpose PRedeemer
|
||||
:--> PMaybe r
|
||||
)
|
||||
ptryFromRedeemer = phoistAcyclic $
|
||||
plam $ \p m ->
|
||||
pfmap
|
||||
# plam (flip ptryFrom fst . pto)
|
||||
# (plookup # p # m)
|
||||
|
||||
-- | @since 1.0.0
|
||||
passert ::
|
||||
forall (a :: PType) (s :: S).
|
||||
Term s PString ->
|
||||
Term s PBool ->
|
||||
Term s a ->
|
||||
Term s a
|
||||
passert msg cond x = pif cond x $ ptraceError msg
|
||||
|
||||
-- | @since 1.0.0
|
||||
pisNothing ::
|
||||
forall (a :: PType) (s :: S).
|
||||
|
|
@ -422,45 +80,38 @@ pisDNothing = phoistAcyclic $
|
|||
PDNothing _ -> pconstant True
|
||||
_ -> pconstant False
|
||||
|
||||
{- | Get the negative and positive amount of a particular 'CurrencySymbol', and
|
||||
return nothing if it doesn't exist in the value.
|
||||
-- | @since 1.0.0
|
||||
ptoScottEncodingT ::
|
||||
forall {k :: Type} (unit :: k) (s :: S).
|
||||
Term s (PTagged unit PAssetClassData :--> PTagged unit PAssetClass)
|
||||
ptoScottEncodingT = phoistAcyclic $
|
||||
plam $ \d ->
|
||||
punsafeDowncast $ ptoScottEncoding #$ pto d
|
||||
|
||||
{- | Get the sum of all values belonging to a particular tagged 'CurrencySymbol'.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
psymbolValueOf' ::
|
||||
ptaggedSymbolValueOf ::
|
||||
forall
|
||||
{k :: Type}
|
||||
(unit :: k)
|
||||
(keys :: KeyGuarantees)
|
||||
(amounts :: AmountGuarantees)
|
||||
(s :: S).
|
||||
Term
|
||||
s
|
||||
( PCurrencySymbol
|
||||
:--> PValue keys amounts
|
||||
:--> PMaybe
|
||||
( PPair
|
||||
-- Positive amount
|
||||
PInteger
|
||||
-- Negative amount
|
||||
PInteger
|
||||
)
|
||||
)
|
||||
psymbolValueOf' = phoistAcyclic $
|
||||
plam $ \sym value ->
|
||||
let tnMap = plookup # sym # pto value
|
||||
f =
|
||||
plam $
|
||||
( pfoldr
|
||||
# plam
|
||||
( \x r ->
|
||||
let q = pfromData $ psndBuiltin # x
|
||||
in pmatch r $ \(PPair p n) ->
|
||||
pif
|
||||
(0 #< q)
|
||||
(pcon $ PPair (p + q) n)
|
||||
(pcon $ PPair p (n + q))
|
||||
)
|
||||
# pcon (PPair 0 0)
|
||||
#
|
||||
)
|
||||
. pto
|
||||
in pfmap # f # tnMap
|
||||
Term s (PTagged unit PCurrencySymbol :--> (PValue keys amounts :--> PInteger))
|
||||
ptaggedSymbolValueOf = phoistAcyclic $ plam $ \tcs -> psymbolValueOf # pto tcs
|
||||
|
||||
-- | @since 1.0.0
|
||||
ptag ::
|
||||
forall {k :: Type} (tag :: k) (a :: PType) (s :: S).
|
||||
Term s a ->
|
||||
Term s (PTagged tag a)
|
||||
ptag = punsafeDowncast
|
||||
|
||||
-- | @since 1.0.0
|
||||
puntag ::
|
||||
forall {k :: Type} (tag :: k) (a :: PType) (s :: S).
|
||||
Term s (PTagged tag a) ->
|
||||
Term s a
|
||||
puntag = pto
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue