Merge branch 'main' into connor/mutate-governor
This commit is contained in:
方泓睿
GitHub
commit
6ad986c7a9
25 changed files with 1225 additions and 41 deletions
146
agora/Agora/Aeson/Orphans.hs
Normal file
146
agora/Agora/Aeson/Orphans.hs
Normal file
|
|
@ -0,0 +1,146 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Agora.Aeson.Orphans (AsBase16Bytes (..)) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Data.Coerce (Coercible, coerce)
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Codec.Serialise qualified as Codec
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Aeson.Types qualified as Aeson
|
||||
import Data.ByteString.Lazy qualified as Lazy
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.Encoding qualified as T
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Api qualified as Plutus
|
||||
import Plutus.V1.Ledger.Bytes qualified as Plutus
|
||||
import Plutus.V1.Ledger.Value qualified as Plutus
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype AsBase16Bytes a = AsBase16Bytes {unAsBase16Bytes :: a}
|
||||
newtype AsBase16Codec a = AsBase16Codec {unAsBase16Codec :: a}
|
||||
|
||||
deriving via
|
||||
(Plutus.CurrencySymbol, Plutus.TokenName)
|
||||
instance
|
||||
Aeson.ToJSON Plutus.AssetClass
|
||||
|
||||
deriving via
|
||||
(Plutus.CurrencySymbol, Plutus.TokenName)
|
||||
instance
|
||||
Aeson.FromJSON Plutus.AssetClass
|
||||
|
||||
deriving via
|
||||
AsBase16Bytes Plutus.TxId
|
||||
instance
|
||||
Aeson.FromJSON Plutus.TxId
|
||||
|
||||
deriving via
|
||||
AsBase16Bytes Plutus.TxId
|
||||
instance
|
||||
Aeson.ToJSON Plutus.TxId
|
||||
|
||||
deriving anyclass instance Aeson.FromJSON Plutus.TxOutRef
|
||||
deriving anyclass instance Aeson.ToJSON Plutus.TxOutRef
|
||||
|
||||
instance (Coercible a Plutus.LedgerBytes) => Aeson.ToJSON (AsBase16Bytes a) where
|
||||
toJSON =
|
||||
Aeson.String
|
||||
. Plutus.encodeByteString
|
||||
. Plutus.bytes
|
||||
. coerce @(AsBase16Bytes a) @Plutus.LedgerBytes
|
||||
|
||||
instance (Coercible Plutus.LedgerBytes a) => Aeson.FromJSON (AsBase16Bytes a) where
|
||||
parseJSON v =
|
||||
Aeson.parseJSON @T.Text v
|
||||
>>= either (Aeson.parserThrowError []) (pure . coerce @_ @(AsBase16Bytes a))
|
||||
. Plutus.fromHex
|
||||
. T.encodeUtf8
|
||||
|
||||
instance (Codec.Serialise a) => Aeson.ToJSON (AsBase16Codec a) where
|
||||
toJSON =
|
||||
Aeson.String
|
||||
. Plutus.encodeByteString
|
||||
. Lazy.toStrict
|
||||
. Codec.serialise @a
|
||||
. (.unAsBase16Codec)
|
||||
|
||||
instance (Codec.Serialise a) => Aeson.FromJSON (AsBase16Codec a) where
|
||||
parseJSON v =
|
||||
Aeson.parseJSON @T.Text v
|
||||
>>= either (Aeson.parserThrowError [] . show) (pure . AsBase16Codec)
|
||||
. Codec.deserialiseOrFail
|
||||
. Lazy.fromStrict
|
||||
. T.encodeUtf8
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.CurrencySymbol)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.CurrencySymbol)
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.CurrencySymbol)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.CurrencySymbol)
|
||||
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.TokenName)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.TokenName)
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.TokenName)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.TokenName)
|
||||
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.ValidatorHash)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.ValidatorHash)
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.ValidatorHash)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.ValidatorHash)
|
||||
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.Validator)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.Validator)
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.Validator)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.Validator)
|
||||
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.MintingPolicy)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.MintingPolicy)
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.MintingPolicy)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.MintingPolicy)
|
||||
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.Script)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.Script)
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.Script)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.Script)
|
||||
|
||||
deriving via
|
||||
Integer
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.POSIXTime)
|
||||
deriving via
|
||||
Integer
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.POSIXTime)
|
||||
|
|
@ -126,6 +126,7 @@ import Plutarch.TryFrom (ptryFrom)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Proposal.Time (ProposalStartingTime (..), ProposalTimingConfig (..))
|
||||
import Plutus.V1.Ledger.Api (
|
||||
CurrencySymbol (..),
|
||||
MintingPolicy,
|
||||
|
|
@ -576,6 +577,10 @@ governorValidator gov =
|
|||
.& #cosigners .= proposalInputDatumF.cosigners
|
||||
.& #thresholds .= proposalInputDatumF.thresholds
|
||||
.& #votes .= proposalInputDatumF.votes
|
||||
-- FIXME: copy from the governor datum
|
||||
.& #timingConfig .= pdata (pconstant tmpTimingConfig)
|
||||
-- FIXME: calculate from 'txInfoValidRange'
|
||||
.& #startingTime .= pdata (pconstant tmpProposalStartingTime)
|
||||
)
|
||||
|
||||
tcassert "Unexpected output proposal datum" $
|
||||
|
|
@ -727,6 +732,20 @@ governorValidator gov =
|
|||
let sym = governorSTSymbolFromGovernor gov
|
||||
in phoistAcyclic $ pconstant sym
|
||||
|
||||
-- TODO: remove this. This is temperary.
|
||||
tmpTimingConfig :: ProposalTimingConfig
|
||||
tmpTimingConfig =
|
||||
ProposalTimingConfig
|
||||
{ draftTime = 50
|
||||
, votingTime = 1000
|
||||
, lockingTime = 2000
|
||||
, executingTime = 3000
|
||||
}
|
||||
|
||||
-- TODO: remove this.
|
||||
tmpProposalStartingTime :: ProposalStartingTime
|
||||
tmpProposalStartingTime = ProposalStartingTime 0
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Get the 'CurrencySymbol' of GST.
|
||||
|
|
|
|||
|
|
@ -44,6 +44,8 @@ import PlutusTx qualified
|
|||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Utils (pkeysEqual, pnotNull)
|
||||
import Control.Applicative (Const)
|
||||
|
|
@ -186,6 +188,10 @@ data ProposalDatum = ProposalDatum
|
|||
-- ^ Thresholds copied over on initialization.
|
||||
, votes :: ProposalVotes
|
||||
-- ^ Vote tally on the proposal
|
||||
, timingConfig :: ProposalTimingConfig
|
||||
-- ^ Timing configuration copied over on initialization.
|
||||
, startingTime :: ProposalStartingTime
|
||||
-- ^ The time upon the creation of the proposal.
|
||||
}
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
|
|
@ -303,7 +309,7 @@ data PProposalStatus (s :: S)
|
|||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
(PlutusType, PIsData, PEq)
|
||||
via PIsDataReprInstances PProposalStatus
|
||||
|
||||
instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
|
||||
|
|
@ -354,6 +360,8 @@ newtype PProposalDatum (s :: S) = PProposalDatum
|
|||
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
|
||||
, "thresholds" ':= PProposalThresholds
|
||||
, "votes" ':= PProposalVotes
|
||||
, "timingConfig" ':= PProposalTimingConfig
|
||||
, "startingTime" ':= PProposalStartingTime
|
||||
]
|
||||
)
|
||||
}
|
||||
|
|
@ -361,7 +369,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
|
|||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
(PlutusType, PIsData, PDataFields, PEq)
|
||||
via (PIsDataReprInstances PProposalDatum)
|
||||
|
||||
-- TODO: Derive this.
|
||||
|
|
|
|||
|
|
@ -13,18 +13,25 @@ module Agora.Proposal.Scripts (
|
|||
import Agora.Proposal (
|
||||
PProposalDatum (PProposalDatum),
|
||||
PProposalRedeemer (..),
|
||||
PProposalVotes (PProposalVotes),
|
||||
Proposal (governorSTAssetClass, stakeSTAssetClass),
|
||||
ProposalStatus (VotingReady),
|
||||
)
|
||||
import Agora.Proposal.Time (currentProposalTime, isVotingPeriod)
|
||||
import Agora.Record (mkRecordConstr, (.&), (.=))
|
||||
import Agora.Stake (findStakeOwnedBy)
|
||||
import Agora.Stake (PProposalLock (..), PStakeDatum (..), findStakeOwnedBy)
|
||||
import Agora.Utils (
|
||||
anyOutput,
|
||||
findTxOutByTxOutRef,
|
||||
getMintingPolicySymbol,
|
||||
mustBePJust,
|
||||
mustFindDatum',
|
||||
pisJust,
|
||||
pisUniqBy,
|
||||
psymbolValueOf,
|
||||
ptokenSpent,
|
||||
ptxSignedBy,
|
||||
pupdate,
|
||||
pvalueSpent,
|
||||
tcassert,
|
||||
tclet,
|
||||
|
|
@ -39,6 +46,8 @@ import Plutarch.Api.V1 (
|
|||
PValidator,
|
||||
)
|
||||
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
|
||||
import Plutarch.Map.Extra (plookup)
|
||||
import Plutarch.SafeMoney (puntag)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
|
||||
{- | Policy for Proposals.
|
||||
|
|
@ -123,7 +132,17 @@ proposalValidator proposal =
|
|||
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- tclet $ pfromData ctx.txInfo
|
||||
PTxInfo txInfo' <- tcmatch txInfo
|
||||
txInfoF <- tcont $ pletFields @'["inputs", "mint", "datums", "signatories"] txInfo'
|
||||
txInfoF <-
|
||||
tcont $
|
||||
pletFields
|
||||
@'[ "inputs"
|
||||
, "outputs"
|
||||
, "mint"
|
||||
, "datums"
|
||||
, "signatories"
|
||||
, "validRange"
|
||||
]
|
||||
txInfo'
|
||||
PSpending ((pfield @"_0" #) -> txOutRef) <- tcmatch $ pfromData ctx.purpose
|
||||
|
||||
PJust txOut <- tcmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
|
||||
|
|
@ -143,6 +162,8 @@ proposalValidator proposal =
|
|||
, "cosigners"
|
||||
, "thresholds"
|
||||
, "votes"
|
||||
, "timingConfig"
|
||||
, "startingTime"
|
||||
]
|
||||
proposalDatum
|
||||
|
||||
|
|
@ -163,9 +184,136 @@ proposalValidator proposal =
|
|||
|
||||
tcassert "ST at inputs must be 1" (spentST #== 1)
|
||||
|
||||
currentTime <- tclet $ currentProposalTime # txInfoF.validRange
|
||||
|
||||
-- Filter out own output with own address and PST.
|
||||
-- Delay the evaluation cause in some cases there won't be any continuing output.
|
||||
ownOutputD <-
|
||||
tclet $
|
||||
pdelay $
|
||||
mustBePJust # "Own output should be present" #$ pfind
|
||||
# plam
|
||||
( \input -> unTermCont $ do
|
||||
inputF <- tcont $ pletFields @'["address", "value"] input
|
||||
pure $
|
||||
inputF.address #== ownAddress
|
||||
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
proposalOutD <-
|
||||
tclet $
|
||||
pdelay $
|
||||
mustFindDatum' @PProposalDatum
|
||||
# (pfield @"datumHash" # pforce ownOutputD)
|
||||
# txInfoF.datums
|
||||
|
||||
pure $
|
||||
pmatch proposalRedeemer $ \case
|
||||
PVote _r -> popaque (pconstant ())
|
||||
PVote r -> unTermCont $ do
|
||||
tcassert "Input proposal must be in VotingReady state" $
|
||||
proposalF.status #== pconstant VotingReady
|
||||
|
||||
tcassert "Proposal time should be wthin the voting period" $
|
||||
isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
|
||||
|
||||
-- Ensure the transaction is voting to a valid 'ResultTag'(outcome).
|
||||
PProposalVotes voteMap <- tcmatch proposalF.votes
|
||||
voteFor <- tclet $ pfromData $ pfield @"resultTag" # r
|
||||
|
||||
tcassert "Vote option should be valid" $
|
||||
pisJust #$ plookup # voteFor # voteMap
|
||||
|
||||
-- Find the input stake, the amount of new votes should be the 'stakedAmount'.
|
||||
let stakeInput =
|
||||
pfield @"resolved"
|
||||
#$ mustBePJust
|
||||
# "Stake input should be present"
|
||||
#$ pfind
|
||||
# plam
|
||||
( \(pfromData . (pfield @"value" #) . (pfield @"resolved" #) -> value) ->
|
||||
passetClassValueOf # value # stakeSTAssetClass #== 1
|
||||
)
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
stakeIn :: Term _ PStakeDatum
|
||||
stakeIn = mustFindDatum' # (pfield @"datumHash" # stakeInput) # txInfoF.datums
|
||||
|
||||
stakeInF <- tcont $ pletFields @'["stakedAmount", "lockedBy", "owner"] stakeIn
|
||||
|
||||
-- Ensure that no lock with the current proposal id has been put on the stake.
|
||||
tcassert "Same stake shouldn't vote on the same propsoal twice" $
|
||||
pnot #$ pany
|
||||
# plam
|
||||
( \((pfield @"proposalTag" #) . pfromData -> pid) ->
|
||||
pid #== proposalF.proposalId
|
||||
)
|
||||
# pfromData stakeInF.lockedBy
|
||||
|
||||
let -- Update the vote counter of the proposal, and leave other stuff as is.
|
||||
expectedNewVotes = pmatch (pfromData proposalF.votes) $ \(PProposalVotes m) ->
|
||||
pcon $
|
||||
PProposalVotes $
|
||||
pupdate
|
||||
# plam
|
||||
( \votes ->
|
||||
pcon $ PJust $ votes + (puntag stakeInF.stakedAmount)
|
||||
)
|
||||
# voteFor
|
||||
# m
|
||||
expectedProposalOut =
|
||||
mkRecordConstr
|
||||
PProposalDatum
|
||||
( #proposalId .= proposalF.proposalId
|
||||
.& #effects .= proposalF.effects
|
||||
.& #status .= proposalF.status
|
||||
.& #cosigners .= proposalF.cosigners
|
||||
.& #thresholds .= proposalF.thresholds
|
||||
.& #votes .= pdata expectedNewVotes
|
||||
.& #timingConfig .= proposalF.timingConfig
|
||||
.& #startingTime .= proposalF.startingTime
|
||||
)
|
||||
|
||||
tcassert "Output proposal should be valid" $ pforce proposalOutD #== expectedProposalOut
|
||||
|
||||
-- We validate the output stake datum here as well: We need the vote option
|
||||
-- to create a valid 'ProposalLock', however the vote option is encoded
|
||||
-- in the proposal redeemer, which is invisible for the stake validator.
|
||||
|
||||
let stakeOutput =
|
||||
mustBePJust # "Stake output should be present"
|
||||
#$ pfind
|
||||
# plam
|
||||
( \(pfromData . (pfield @"value" #) -> value) ->
|
||||
passetClassValueOf # value # stakeSTAssetClass #== 1
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
stakeOut :: Term _ PStakeDatum
|
||||
stakeOut = mustFindDatum' # (pfield @"datumHash" # stakeOutput) # txInfoF.datums
|
||||
|
||||
let newProposalLock =
|
||||
mkRecordConstr
|
||||
PProposalLock
|
||||
( #vote .= pdata voteFor
|
||||
.& #proposalTag .= proposalF.proposalId
|
||||
)
|
||||
-- Prepend the new lock to existing locks
|
||||
expectedProposalLocks =
|
||||
pcons
|
||||
# pdata newProposalLock
|
||||
# pfromData stakeInF.lockedBy
|
||||
expectedStakeOut =
|
||||
mkRecordConstr
|
||||
PStakeDatum
|
||||
( #stakedAmount .= stakeInF.stakedAmount
|
||||
.& #owner .= stakeInF.owner
|
||||
.& #lockedBy .= pdata expectedProposalLocks
|
||||
)
|
||||
|
||||
tcassert "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PCosign r -> unTermCont $ do
|
||||
newSigs <- tclet $ pfield @"newCosigners" # r
|
||||
|
|
@ -214,6 +362,8 @@ proposalValidator proposal =
|
|||
.& #cosigners .= pdata updatedSigs
|
||||
.& #thresholds .= proposalF.thresholds
|
||||
.& #votes .= proposalF.votes
|
||||
.& #timingConfig .= proposalF.timingConfig
|
||||
.& #startingTime .= proposalF.startingTime
|
||||
)
|
||||
)
|
||||
in foldr1
|
||||
|
|
|
|||
|
|
@ -39,7 +39,12 @@ import Plutarch.Api.V1 (
|
|||
PPOSIXTimeRange,
|
||||
PUpperBound (PUpperBound),
|
||||
)
|
||||
import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
|
||||
import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..))
|
||||
import Plutarch.Lift (
|
||||
DerivePConstantViaNewtype (..),
|
||||
PConstantDecl,
|
||||
PUnsafeLiftDecl (..),
|
||||
)
|
||||
import Plutarch.Numeric (AdditiveSemigroup ((+)))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import Plutus.V1.Ledger.Time (POSIXTime)
|
||||
|
|
@ -122,10 +127,24 @@ newtype PProposalTime (s :: S)
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalTime)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalTime where
|
||||
type PLifted PProposalTime = ProposalTime
|
||||
deriving via
|
||||
(DerivePConstantViaData ProposalTime PProposalTime)
|
||||
instance
|
||||
(PConstantDecl ProposalTime)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalStartingTime'.
|
||||
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalStartingTime PPOSIXTime)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalStartingTime where
|
||||
type PLifted PProposalStartingTime = ProposalStartingTime
|
||||
deriving via
|
||||
(DerivePConstantViaNewtype ProposalStartingTime PProposalStartingTime PPOSIXTime)
|
||||
instance
|
||||
(PConstantDecl ProposalStartingTime)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalTimingConfig'.
|
||||
newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
|
||||
{ getProposalTimingConfig ::
|
||||
|
|
@ -146,6 +165,13 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalTimingConfig)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalTimingConfig where
|
||||
type PLifted PProposalTimingConfig = ProposalTimingConfig
|
||||
deriving via
|
||||
(DerivePConstantViaData ProposalTimingConfig PProposalTimingConfig)
|
||||
instance
|
||||
(PConstantDecl ProposalTimingConfig)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- FIXME: Orphan instance, move this to plutarch-extra.
|
||||
|
|
|
|||
|
|
@ -8,6 +8,9 @@ Tags and extras for "Plutarch.SafeMoney".
|
|||
module Agora.SafeMoney (
|
||||
ADATag,
|
||||
GTTag,
|
||||
GovernorSTTag,
|
||||
StakeSTTag,
|
||||
ProposalSTTag,
|
||||
adaRef,
|
||||
) where
|
||||
|
||||
|
|
@ -18,7 +21,7 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
|||
import Plutarch.SafeMoney
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Example tags
|
||||
-- Tags
|
||||
|
||||
-- | Governance token.
|
||||
data GTTag
|
||||
|
|
@ -26,6 +29,15 @@ data GTTag
|
|||
-- | ADA.
|
||||
data ADATag
|
||||
|
||||
-- | Governor ST token.
|
||||
data GovernorSTTag
|
||||
|
||||
-- | Stake ST token.
|
||||
data StakeSTTag
|
||||
|
||||
-- | Proposal ST token.
|
||||
data ProposalSTTag
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Resolves ada tags.
|
||||
|
|
|
|||
63
agora/Agora/ScriptInfo.hs
Normal file
63
agora/Agora/ScriptInfo.hs
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
{- |
|
||||
Module : Agora.ScriptInfo
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Exportable script bundles for off-chain consumption.
|
||||
|
||||
Exportable script bundles for off-chain consumption.
|
||||
-}
|
||||
module Agora.ScriptInfo (
|
||||
-- * Types
|
||||
PolicyInfo (..),
|
||||
ValidatorInfo (..),
|
||||
|
||||
-- * Introduction functions
|
||||
mkValidatorInfo,
|
||||
mkPolicyInfo,
|
||||
) where
|
||||
|
||||
import Agora.Aeson.Orphans ()
|
||||
import Data.Aeson qualified as Aeson
|
||||
import GHC.Generics qualified as GHC
|
||||
import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMintingPolicy, mkValidator, validatorHash)
|
||||
import Plutus.V1.Ledger.Api (MintingPolicy, Validator, ValidatorHash)
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
|
||||
-- | Bundle containing a 'Validator' and its hash.
|
||||
data ValidatorInfo = ValidatorInfo
|
||||
{ script :: Validator
|
||||
-- ^ The validator script.
|
||||
, hash :: ValidatorHash
|
||||
-- ^ Hash of the validator.
|
||||
}
|
||||
deriving stock (Show, Eq, GHC.Generic)
|
||||
deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
|
||||
|
||||
-- | Create a 'ValidatorInfo' given a Plutarch term.
|
||||
mkValidatorInfo :: ClosedTerm PValidator -> ValidatorInfo
|
||||
mkValidatorInfo term =
|
||||
ValidatorInfo
|
||||
{ script = validator
|
||||
, hash = validatorHash validator
|
||||
}
|
||||
where
|
||||
validator = mkValidator term
|
||||
|
||||
-- | Bundle containing a 'MintingPolicy' and its symbol.
|
||||
data PolicyInfo = PolicyInfo
|
||||
{ policy :: MintingPolicy
|
||||
-- ^ The minting policy.
|
||||
, currencySymbol :: CurrencySymbol
|
||||
-- ^ The symbol given by the minting policy.
|
||||
}
|
||||
deriving stock (Show, Eq, GHC.Generic)
|
||||
deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
|
||||
|
||||
-- | Create a 'PolicyInfo' given a Plutarch term.
|
||||
mkPolicyInfo :: ClosedTerm PMintingPolicy -> PolicyInfo
|
||||
mkPolicyInfo term =
|
||||
PolicyInfo
|
||||
{ policy = policy
|
||||
, currencySymbol = mintingPolicySymbol policy
|
||||
}
|
||||
where
|
||||
policy = mkMintingPolicy term
|
||||
|
|
@ -191,7 +191,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum
|
|||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
(PlutusType, PIsData, PDataFields, PEq)
|
||||
via (PIsDataReprInstances PStakeDatum)
|
||||
|
||||
instance PTryFrom PData (PAsData PStakeDatum) where
|
||||
|
|
@ -241,7 +241,7 @@ newtype PProposalLock (s :: S) = PProposalLock
|
|||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
(PlutusType, PIsData, PDataFields, PEq)
|
||||
via (PIsDataReprInstances PProposalLock)
|
||||
|
||||
deriving via
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ Plutus Scripts for Stakes.
|
|||
-}
|
||||
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
|
||||
|
||||
import Agora.Record (mkRecordConstr, (.&), (.=))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake
|
||||
import Agora.Utils (
|
||||
|
|
@ -222,7 +223,7 @@ stakeValidator stake =
|
|||
-- TODO: Use PTryFrom
|
||||
let stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum <- tcont $ pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
stakeDatum <- tcont $ pletFields @'["owner", "stakedAmount", "lockedBy"] stakeDatum'
|
||||
|
||||
PSpending txOutRef <- tcmatch $ pfromData ctx.purpose
|
||||
|
||||
|
|
@ -291,7 +292,7 @@ stakeValidator stake =
|
|||
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PPermitVote _ -> unTermCont $ do
|
||||
PPermitVote l -> unTermCont $ do
|
||||
tcassert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
|
@ -301,18 +302,38 @@ stakeValidator stake =
|
|||
tcassert "Proposal ST spent" $
|
||||
spentProposalST #== 1
|
||||
|
||||
-- Update the stake datum, but only the 'lockedBy' field.
|
||||
|
||||
let -- We actually don't know whether the given lock is valid or not.
|
||||
-- This is checked in the proposal validator.
|
||||
newLock = pfield @"lock" # l
|
||||
-- Prepend the new lock to the existing locks.
|
||||
expectedLocks = pcons # newLock # stakeDatum.lockedBy
|
||||
|
||||
expectedDatum <-
|
||||
tclet $
|
||||
pdata $
|
||||
mkRecordConstr
|
||||
PStakeDatum
|
||||
( #stakedAmount .= stakeDatum.stakedAmount
|
||||
.& #owner .= stakeDatum.owner
|
||||
.& #lockedBy .= pdata expectedLocks
|
||||
)
|
||||
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
-- FIXME: no need to pass the whole txInfo to 'anyOutput'.
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' ->
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
_correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
|
||||
correctOutputDatum = pdata newStakeDatum' #== expectedDatum
|
||||
valueCorrect = pdata continuingValue #== pdata value
|
||||
in pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "datumCorrect" correctOutputDatum
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
|
|
|
|||
|
|
@ -72,6 +72,7 @@ deriving via
|
|||
do so in a valid manner.
|
||||
-}
|
||||
treasuryValidator ::
|
||||
-- | Governance Authority Token that can unlock this validator.
|
||||
CurrencySymbol ->
|
||||
ClosedTerm PValidator
|
||||
treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> unTermCont $ do
|
||||
|
|
|
|||
|
|
@ -40,6 +40,8 @@ module Agora.Utils (
|
|||
pmsortBy,
|
||||
pmsort,
|
||||
pnubSort,
|
||||
pupdate,
|
||||
pmapMaybe,
|
||||
|
||||
-- * Functions which should (probably) not be upstreamed
|
||||
anyOutput,
|
||||
|
|
@ -288,6 +290,42 @@ pmapUnionWith = phoistAcyclic $
|
|||
# ys
|
||||
pure $ pcon (PMap $ pconcat # ls # rs)
|
||||
|
||||
-- | A special version of `pmap` which allows list elements to be thrown out.
|
||||
pmapMaybe :: forall s a list. (PIsListLike list a) => Term s ((a :--> PMaybe a) :--> list a :--> list a)
|
||||
pmapMaybe = phoistAcyclic $
|
||||
pfix #$ plam $ \self f l -> pif (pnull # l) pnil $
|
||||
unTermCont $ do
|
||||
x <- tclet $ phead # l
|
||||
xs <- tclet $ ptail # l
|
||||
|
||||
pure $
|
||||
pmatch (f # x) $ \case
|
||||
PJust ux -> pcons # ux #$ self # f # xs
|
||||
_ -> self # f # xs
|
||||
|
||||
-- | / O(n) /. Update the value at a given key in a `PMap`, have the same functionalities as 'Data.Map.update'.
|
||||
pupdate :: forall s k v. (PIsData k, PIsData v) => Term s ((v :--> PMaybe v) :--> k :--> PMap k v :--> PMap k v)
|
||||
pupdate = phoistAcyclic $
|
||||
plam $ \f (pdata -> tk) (pto -> (ps :: Term _ (PBuiltinList _))) ->
|
||||
pcon $
|
||||
PMap $
|
||||
pmapMaybe
|
||||
# plam
|
||||
( \kv ->
|
||||
let k = pfstBuiltin # kv
|
||||
v = pfromData $ psndBuiltin # kv
|
||||
in pif
|
||||
(k #== tk)
|
||||
-- 'PBuiltinPair' doesn't have 'PFunctor', so:
|
||||
( pmatch (f # v) $
|
||||
\case
|
||||
PJust uv -> pcon $ PJust $ ppairDataBuiltin # k # pdata uv
|
||||
_ -> pcon PNothing
|
||||
)
|
||||
(pcon $ PJust kv)
|
||||
)
|
||||
# ps
|
||||
|
||||
-- | Add two 'PValue's together.
|
||||
paddValue :: forall s. Term s (PValue :--> PValue :--> PValue)
|
||||
paddValue = phoistAcyclic $
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue