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

add @since tags to everything

Browse source
This commit is contained in:
Emily Martins 2022-06-22 18:15:20 +02:00
parent 58c0896bb6
commit 77401ad0a7
19 changed files with 1213 additions and 445 deletions
Download patch file Download diff file Expand all files Collapse all files

6
CHANGELOG.md
View file

@ -2,4 +2,8 @@
This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).
## Unreleased
## 0.1.0 -- 2022-06-22
### Added
* First release

2
agora.cabal
View file

@ -1,6 +1,6 @@
cabal-version: 3.0
name: agora
version: 0.1
version: 0.1.0
extra-source-files: CHANGELOG.md
author: Emily Martins <emi@haskell.fyi>
license: Apache-2.0

36
agora/Agora/AuthorityToken.hs
View file

@ -2,6 +2,7 @@
Module : Agora.AuthorityToken
Maintainer : emi@haskell.fyi
Description: Tokens acting as redeemable proofs of DAO authority.
Tokens acting as redeemable proofs of DAO authority.
-}
module Agora.AuthorityToken (
@ -11,8 +12,7 @@ module Agora.AuthorityToken (
AuthorityToken (..),
) where
--------------------------------------------------------------------------------
import GHC.Generics qualified as GHC
import Plutarch.Api.V1 (
AmountGuarantees,
KeyGuarantees,
@ -38,21 +38,23 @@ import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
--------------------------------------------------------------------------------
import GHC.Generics qualified as GHC
--------------------------------------------------------------------------------
{- | An AuthorityToken represents a proof that a particular token
moved while this token was minted. In effect, this means that
the validator that locked such a token must have approved
said transaction. Said validator should be made aware of
*this* token's existence in order to prevent incorrect minting.
spent in the same transaction the AuthorityToken was minted.
In effect, this means that the validator that locked such a token
must have approved the transaction in which an AuthorityToken is minted.
Said validator should be made aware of an AuthorityToken token's existence
in order to prevent incorrect minting.
@since 0.1.0
-}
newtype AuthorityToken = AuthorityToken
{ authority :: AssetClass
-- ^ Token that must move in order for minting this to be valid.
}
deriving stock (GHC.Generic)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
--------------------------------------------------------------------------------
@ -64,6 +66,8 @@ newtype AuthorityToken = AuthorityToken
it was sent to, this is enough to prove validity.
In other words, check that all assets of a particular currency symbol
are tagged with a TokenName that matches where they live.
@since 0.1.0
-}
authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool)
authorityTokensValidIn = phoistAcyclic $
@ -94,7 +98,10 @@ authorityTokensValidIn = phoistAcyclic $
-- No GATs exist at this output!
pconstant True
-- | Assert that a single authority token has been burned.
{- | Assert that a single authority token has been burned.
@since 0.1.0
-}
singleAuthorityTokenBurned ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s PCurrencySymbol ->
@ -122,7 +129,10 @@ singleAuthorityTokenBurned gatCs txInfo mint = unTermCont $ do
# txInfoF.inputs
]
-- | Policy given 'AuthorityToken' params.
{- | Policy given 'AuthorityToken' params.
@since 0.1.0
-}
authorityTokenPolicy :: AuthorityToken -> ClosedTerm PMintingPolicy
authorityTokenPolicy params =
plam $ \_redeemer ctx' ->

4
agora/Agora/Effect.hs
View file

@ -13,13 +13,13 @@ import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC, ptryFromC)
import Plutarch.TryFrom ()
import PlutusLedgerApi.V1.Value (CurrencySymbol)
--------------------------------------------------------------------------------
{- | Helper "template" for creating effect validator.
In some situations, it may be the case that we need more control over how
an effect is implemented. In such situations, it's okay to not use this
helper.
@since 0.1.0
-}
makeEffect ::
forall (datum :: PType).

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

@ -18,39 +18,6 @@ module Agora.Effect.GovernorMutation (
mutateGovernorValidator,
) where
--------------------------------------------------------------------------------
import Control.Applicative (Const)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
--------------------------------------------------------------------------------
import Plutarch.Api.V1 (
PTxOutRef,
PValidator,
PValue,
)
import Plutarch.Api.V1.ScriptContext (ptryFindDatum)
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pvalueOf)
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
)
import Plutarch.Extra.TermCont (pguardC)
import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
import Plutarch.TryFrom (PTryFrom (..))
import Plutarch.Unsafe (punsafeCoerce)
--------------------------------------------------------------------------------
import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass (..))
import PlutusTx qualified
--------------------------------------------------------------------------------
import Agora.Effect (makeEffect)
import Agora.Governor (
Governor,
@ -67,10 +34,35 @@ import Agora.Utils (
mustBePDJust,
mustBePJust,
)
import Control.Applicative (Const)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (
PTxOutRef,
PValidator,
PValue,
)
import Plutarch.Api.V1.ScriptContext (ptryFindDatum)
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pvalueOf)
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
)
import Plutarch.Extra.TermCont (pguardC)
import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
import Plutarch.TryFrom (PTryFrom (..))
import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass (..))
import PlutusTx qualified
--------------------------------------------------------------------------------
-- | Haskell-level datum for the governor mutation effect script.
{- | Haskell-level datum for the governor mutation effect script.
@since 0.1.0
-}
data MutateGovernorDatum = MutateGovernorDatum
{ governorRef :: TxOutRef
-- ^ Referenced governor state UTXO should be updated by the effect.
@ -84,7 +76,10 @@ PlutusTx.makeIsDataIndexed ''MutateGovernorDatum [('MutateGovernorDatum, 0)]
--------------------------------------------------------------------------------
-- | Plutarch-level version of 'MutateGovernorDatum'.
{- | Plutarch-level version of 'MutateGovernorDatum'.
@since 0.1.0
-}
newtype PMutateGovernorDatum (s :: S)
= PMutateGovernorDatum
( Term
@ -95,17 +90,39 @@ newtype PMutateGovernorDatum (s :: S)
]
)
)
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData, PDataFields, PEq)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0
PEq
)
via (PIsDataReprInstances PMutateGovernorDatum)
-- | @since 0.1.0
instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernorDatum = MutateGovernorDatum
-- | @since 0.1.0
deriving via (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum) instance (PConstantDecl MutateGovernorDatum)
-- TODO: Derive this.
-- | @since 0.1.0
instance PTryFrom PData (PAsData PMutateGovernorDatum) where
type PTryFromExcess PData (PAsData PMutateGovernorDatum) = Const ()
ptryFrom' d k =
@ -135,6 +152,8 @@ instance PTryFrom PData (PAsData PMutateGovernorDatum) where
* It contains the GST.
* It has valid governor state datum.
* The datum is exactly the same as the 'newDatum'.
@since 0.1.0
-}
mutateGovernorValidator :: Governor -> ClosedTerm PValidator
mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov) $

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

@ -14,10 +14,20 @@ import Plutarch.Api.V1 (PValidator)
import Plutarch.TryFrom (PTryFrom (..))
import PlutusLedgerApi.V1.Value (CurrencySymbol)
-- | Dummy datum for NoOp effect.
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
deriving (PlutusType, PIsData) via (DerivePNewtype PNoOp PUnit)
{- | Dummy datum for NoOp effect.
@since 0.1.0
-}
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via (DerivePNewtype PNoOp PUnit)
-- | @since 0.1.0
instance PTryFrom PData (PAsData PNoOp) where
type PTryFromExcess PData (PAsData PNoOp) = Const ()
ptryFrom' _ cont =
@ -26,7 +36,10 @@ instance PTryFrom PData (PAsData PNoOp) where
-- It should always be reduced to Unit.
cont (pdata $ pcon $ PNoOp (pconstant ()), ())
-- | Dummy effect which can only burn its GAT.
{- | Dummy effect which can only burn its GAT.
@since 0.1.0
-}
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
noOpValidator curr = makeEffect curr $
\_ (_datum :: Term s PNoOp) _ _ -> popaque (pconstant ())

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

@ -13,12 +13,11 @@ module Agora.Effect.TreasuryWithdrawal (
treasuryWithdrawalValidator,
) where
import Agora.Effect (makeEffect)
import Agora.Utils (isPubKey)
import Control.Applicative (Const)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Agora.Effect (makeEffect)
import Agora.Utils (isPubKey)
import Plutarch.Api.V1 (
AmountGuarantees (Positive),
KeyGuarantees (Sorted),
@ -28,8 +27,6 @@ import Plutarch.Api.V1 (
PValue,
ptuple,
)
import Plutarch.Internal (punsafeCoerce)
import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef)
import "plutarch" Plutarch.Api.V1.Value (pnormalize)
import Plutarch.DataRepr (
@ -38,6 +35,7 @@ import Plutarch.DataRepr (
PIsDataReprInstances (..),
)
import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
import Plutarch.Internal (punsafeCoerce)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import Plutarch.TryFrom (PTryFrom (..))
import PlutusLedgerApi.V1.Credential (Credential)
@ -46,9 +44,11 @@ import PlutusTx qualified
{- | Datum that encodes behavior of Treasury Withdrawal effect.
Note: This Datum acts like a "predefined redeemer". Which is to say that
it encodes the properties a redeemer would, but is locked in-place until
spend.
Note: This Datum acts like a "predefined redeemer". Which is to say that
it encodes the properties a redeemer would, but is locked in-place until
spend.
@since 0.1.0
-}
data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
{ receivers :: [(Credential, Value)]
@ -56,13 +56,27 @@ data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
, treasuries :: [Credential]
-- ^ What Credentials is spending from legal.
}
deriving stock (Show, GHC.Generic)
deriving anyclass (Generic)
deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
-- | @since 0.1.0
PlutusTx.makeLift ''TreasuryWithdrawalDatum
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''TreasuryWithdrawalDatum [('TreasuryWithdrawalDatum, 0)]
-- | Haskell-level version of 'TreasuryWithdrawalDatum'.
{- | Haskell-level version of 'TreasuryWithdrawalDatum'.
@since 0.1.0
-}
newtype PTreasuryWithdrawalDatum (s :: S)
= PTreasuryWithdrawalDatum
( Term
@ -73,20 +87,37 @@ newtype PTreasuryWithdrawalDatum (s :: S)
]
)
)
deriving stock (GHC.Generic)
deriving anyclass (Generic, PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData, PDataFields)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
)
via PIsDataReprInstances PTreasuryWithdrawalDatum
-- | @since 0.1.0
instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum
-- | @since 0.1.0
deriving via
(DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
instance
(PConstantDecl TreasuryWithdrawalDatum)
-- | @since 0.1.0
instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum) where
type PTryFromExcess PData (PAsData PTreasuryWithdrawalDatum) = Const ()
ptryFrom' opq cont =
@ -101,12 +132,17 @@ instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum) where
The validator does not accept any Redeemer as all "parameters" are provided
via encoded Datum.
Note:
It should check...
NOTE: It should check...
1. Transaction outputs should contain all of what Datum specified
2. Left over assets should be redirected back to Treasury
It can be more flexiable over...
- The number of outputs themselves
@since 0.1.0
-}
treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $

113
agora/Agora/Governor.hs
View file

@ -23,15 +23,6 @@ module Agora.Governor (
governorDatumValid,
) where
--------------------------------------------------------------------------------
import Control.Applicative (Const)
import Data.Tagged (Tagged (..))
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
--------------------------------------------------------------------------------
import Agora.Proposal (
PProposalId (..),
PProposalThresholds (..),
@ -45,9 +36,10 @@ import Agora.Proposal.Time (
ProposalTimingConfig,
)
import Agora.SafeMoney (GTTag)
--------------------------------------------------------------------------------
import Control.Applicative (Const)
import Data.Tagged (Tagged (..))
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
@ -59,16 +51,16 @@ import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import Plutarch.SafeMoney (PDiscrete (..))
import Plutarch.TryFrom (PTryFrom (..))
import Plutarch.Unsafe (punsafeCoerce)
--------------------------------------------------------------------------------
import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass (..))
import PlutusTx qualified
--------------------------------------------------------------------------------
-- | Datum for the Governor script.
{- | Datum for the Governor script.
@since 0.1.0
-}
data GovernorDatum = GovernorDatum
{ proposalThresholds :: ProposalThresholds
-- ^ Gets copied over upon creation of a 'Agora.Proposal.ProposalDatum'.
@ -82,6 +74,7 @@ data GovernorDatum = GovernorDatum
}
deriving stock (Show, GHC.Generic)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
{- | Redeemer for Governor script. The governor has two primary
@ -91,6 +84,8 @@ PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
2. The gating of minting authority tokens.
Parameters of the governor can also be mutated by an effect.
@since 0.1.0
-}
data GovernorRedeemer
= -- | Checks that a proposal was created lawfully, and allows it.
@ -102,6 +97,7 @@ data GovernorRedeemer
MutateGovernor
deriving stock (Show, GHC.Generic)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed
''GovernorRedeemer
[ ('CreateProposal, 0)
@ -109,7 +105,10 @@ PlutusTx.makeIsDataIndexed
, ('MutateGovernor, 2)
]
-- | Parameters for creating Governor scripts.
{- | Parameters for creating Governor scripts.
@since 0.1.0
-}
data Governor = Governor
{ gstOutRef :: TxOutRef
-- ^ Referenced utxo will be spent to mint the GST.
@ -123,7 +122,10 @@ data Governor = Governor
--------------------------------------------------------------------------------
-- | Plutarch-level datum for the Governor script.
{- | Plutarch-level datum for the Governor script.
@since 0.1.0
-}
newtype PGovernorDatum (s :: S) = PGovernorDatum
{ getGovernorDatum ::
Term
@ -136,53 +138,104 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData, PDataFields, PEq)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0
PEq
)
via PIsDataReprInstances PGovernorDatum
-- | @since 0.1.0
instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = GovernorDatum
-- | @since 0.1.0
deriving via (DerivePConstantViaData GovernorDatum PGovernorDatum) instance (PConstantDecl GovernorDatum)
-- FIXME: derive this via 'PIsDataReprInstances'
-- Blocked by: PProposalThresholds
-- | @since 0.1.0
instance PTryFrom PData (PAsData PGovernorDatum) where
type PTryFromExcess PData (PAsData PGovernorDatum) = Const ()
ptryFrom' d k = k (punsafeCoerce d, ())
-- | Plutarch-level version of 'GovernorRedeemer'.
{- | Plutarch-level version of 'GovernorRedeemer'.
@since 0.1.0
-}
data PGovernorRedeemer (s :: S)
= PCreateProposal (Term s (PDataRecord '[]))
| PMintGATs (Term s (PDataRecord '[]))
| PMutateGovernor (Term s (PDataRecord '[]))
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via PIsDataReprInstances PGovernorRedeemer
-- | @since 0.1.0
instance PUnsafeLiftDecl PGovernorRedeemer where type PLifted PGovernorRedeemer = GovernorRedeemer
-- | @since 0.1.0
deriving via (DerivePConstantViaData GovernorRedeemer PGovernorRedeemer) instance (PConstantDecl GovernorRedeemer)
-- | @since 0.1.0
deriving via PAsData (PIsDataReprInstances PGovernorRedeemer) instance PTryFrom PData (PAsData PGovernorRedeemer)
--------------------------------------------------------------------------------
-- | Plutrach version of 'getNextProposalId'.
{- | Plutrach version of 'getNextProposalId'.
@since 0.1.0
-}
pgetNextProposalId :: Term s (PProposalId :--> PProposalId)
pgetNextProposalId = phoistAcyclic $ plam $ \(pto -> pid) -> pcon $ PProposalId $ pid + 1
-- | Get next proposal id.
{- | Get next proposal id.
@since 0.1.0
-}
getNextProposalId :: ProposalId -> ProposalId
getNextProposalId (ProposalId pid) = ProposalId $ pid + 1
--------------------------------------------------------------------------------
-- | Check whether a particular 'PGovernorDatum' is well-formed.
{- | Check whether a particular 'PGovernorDatum' is well-formed.
@since 0.1.0
-}
governorDatumValid :: Term s (PGovernorDatum :--> PBool)
governorDatumValid = phoistAcyclic $
plam $ \datum -> unTermCont $ do

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

@ -154,6 +154,8 @@ import PlutusLedgerApi.V1.Value (
NOTE: It's user's responsibility to make sure the token is sent to the corresponding governor validator.
We /can't/ really check this in the policy, otherwise we create a cyclic reference issue.
@since 0.1.0
-}
governorPolicy :: Governor -> ClosedTerm PMintingPolicy
governorPolicy gov =
@ -272,6 +274,8 @@ governorPolicy gov =
- Exactly one GAT is burnt in the transaction.
- Said GAT is tagged by the effect.
@since 0.1.0
-}
governorValidator :: Governor -> ClosedTerm PValidator
governorValidator gov =
@ -718,21 +722,30 @@ governorValidator gov =
--------------------------------------------------------------------------------
-- | Get the 'CurrencySymbol' of GST.
{- | Get the 'CurrencySymbol' of GST.
@since 0.1.0
-}
governorSTSymbolFromGovernor :: Governor -> CurrencySymbol
governorSTSymbolFromGovernor gov = mintingPolicySymbol policy
where
policy :: MintingPolicy
policy = mkMintingPolicy $ governorPolicy gov
-- | Get the 'AssetClass' of GST.
{- | Get the 'AssetClass' of GST.
@since 0.1.0
-}
governorSTAssetClassFromGovernor :: Governor -> AssetClass
governorSTAssetClassFromGovernor gov = AssetClass (symbol, "")
where
symbol :: CurrencySymbol
symbol = governorSTSymbolFromGovernor gov
-- | Get the 'CurrencySymbol' of the proposal state token.
{- | Get the 'CurrencySymbol' of the proposal state token.
@since 0.1.0
-}
proposalSTSymbolFromGovernor :: Governor -> CurrencySymbol
proposalSTSymbolFromGovernor gov = symbol
where
@ -740,13 +753,19 @@ proposalSTSymbolFromGovernor gov = symbol
policy = mkMintingPolicy $ proposalPolicy gstAC
symbol = mintingPolicySymbol policy
-- | Get the 'AssetClass' of the proposal state token.
{- | Get the 'AssetClass' of the proposal state token.
@since 0.1.0
-}
proposalSTAssetClassFromGovernor :: Governor -> AssetClass
proposalSTAssetClassFromGovernor gov = AssetClass (symbol, "")
where
symbol = proposalSTSymbolFromGovernor gov
-- | Get the 'CurrencySymbol' of the stake token/
{- | Get the 'CurrencySymbol' of the stake token/
@since 0.1.0
-}
stakeSTSymbolFromGovernor :: Governor -> CurrencySymbol
stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy
where
@ -756,6 +775,8 @@ stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy
Note that the token is tagged with the hash of the stake validator.
See 'Agora.Stake.Script.stakePolicy'.
@since 0.1.0
-}
stakeSTAssetClassFromGovernor :: Governor -> AssetClass
stakeSTAssetClassFromGovernor gov = AssetClass (symbol, tokenName)
@ -765,20 +786,29 @@ stakeSTAssetClassFromGovernor gov = AssetClass (symbol, tokenName)
-- Tag with the address where the token is being sent to.
tokenName = validatorHashToTokenName $ stakeValidatorHashFromGovernor gov
-- | Get the 'Stake' parameter, given the 'Governor' parameter.
{- | Get the 'Stake' parameter, given the 'Governor' parameter.
@since 0.1.0
-}
stakeFromGovernor :: Governor -> Stake
stakeFromGovernor gov =
Stake gov.gtClassRef $
proposalSTAssetClassFromGovernor gov
-- | Get the hash of 'Agora.Stake.Script.stakePolicy'.
{- | Get the hash of 'Agora.Stake.Script.stakePolicy'.
@since 0.1.0
-}
stakeValidatorHashFromGovernor :: Governor -> ValidatorHash
stakeValidatorHashFromGovernor gov = validatorHash validator
where
params = stakeFromGovernor gov
validator = mkValidator $ stakeValidator params
-- | Get the 'Proposal' parameter, given the 'Governor' parameter.
{- | Get the 'Proposal' parameter, given the 'Governor' parameter.
@since 0.1.0
-}
proposalFromGovernor :: Governor -> Proposal
proposalFromGovernor gov = Proposal gstAC sstAC mc
where
@ -786,24 +816,36 @@ proposalFromGovernor gov = Proposal gstAC sstAC mc
mc = gov.maximumCosigners
sstAC = stakeSTAssetClassFromGovernor gov
-- | Get the hash of 'Agora.Proposal.proposalPolicy'.
{- | Get the hash of 'Agora.Proposal.proposalPolicy'.
@since 0.1.0
-}
proposalValidatorHashFromGovernor :: Governor -> ValidatorHash
proposalValidatorHashFromGovernor gov = validatorHash validator
where
params = proposalFromGovernor gov
validator = mkValidator $ proposalValidator params
-- | Get the hash of 'Agora.Proposal.proposalValidator'.
{- | Get the hash of 'Agora.Proposal.proposalValidator'.
@since 0.1.0
-}
governorValidatorHash :: Governor -> ValidatorHash
governorValidatorHash gov = validatorHash validator
where
validator = mkValidator $ governorValidator gov
-- | Get the 'AuthorityToken' parameter given the 'Governor' parameter.
{- | Get the 'AuthorityToken' parameter given the 'Governor' parameter.
@since 0.1.0
-}
authorityTokenFromGovernor :: Governor -> AuthorityToken
authorityTokenFromGovernor gov = AuthorityToken $ governorSTAssetClassFromGovernor gov
-- | Get the 'CurrencySymbol' of the authority token.
{- | Get the 'CurrencySymbol' of the authority token.
@since 0.1.0
-}
authorityTokenSymbolFromGovernor :: Governor -> CurrencySymbol
authorityTokenSymbolFromGovernor gov = mintingPolicySymbol policy
where

65
agora/Agora/MultiSig.hs
View file

@ -14,6 +14,8 @@ module Agora.MultiSig (
MultiSig (..),
) where
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (
PPubKeyHash,
PTxInfo (..),
@ -28,33 +30,42 @@ import Plutarch.Lift (
PLifted,
PUnsafeLiftDecl,
)
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
import PlutusTx qualified
--------------------------------------------------------------------------------
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Prelude
--------------------------------------------------------------------------------
{- | A MultiSig represents a proof that a particular set of signatures
are present on a transaction.
@since 0.1.0
-}
data MultiSig = MultiSig
{ keys :: [PubKeyHash]
-- ^ List of PubKeyHashes that must be present in the list of signatories.
, minSigs :: Integer
}
deriving stock (GHC.Generic, Eq, Show)
deriving anyclass (Generic)
deriving stock
( -- | @since 0.1.0
GHC.Generic
, -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
PlutusTx.makeLift ''MultiSig
PlutusTx.unstableMakeIsData ''MultiSig
-- | Plutarch-level MultiSig
{- | Plutarch-level MultiSig
@since 0.1.0
-}
newtype PMultiSig (s :: S) = PMultiSig
{ getMultiSig ::
Term
@ -65,25 +76,49 @@ newtype PMultiSig (s :: S) = PMultiSig
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData, PDataFields)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
)
via (PIsDataReprInstances PMultiSig)
-- | @since 0.1.0
instance PUnsafeLiftDecl PMultiSig where type PLifted PMultiSig = MultiSig
-- | @since 0.1.0
deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstantDecl MultiSig)
--------------------------------------------------------------------------------
-- | Check if a Haskell-level MultiSig signs this transaction.
{- | Check if a Haskell-level MultiSig signs this transaction.
@since 0.1.0
-}
validatedByMultisig :: MultiSig -> Term s (PTxInfo :--> PBool)
validatedByMultisig params =
phoistAcyclic $
pvalidatedByMultisig # pconstant params
-- | Check if a Plutarch-level MultiSig signs this transaction.
{- | Check if a Plutarch-level MultiSig signs this transaction.
@since 0.1.0
-}
pvalidatedByMultisig :: Term s (PMultiSig :--> PTxInfo :--> PBool)
pvalidatedByMultisig =
phoistAcyclic $

382
agora/Agora/Proposal.hs
View file

@ -36,23 +36,14 @@ module Agora.Proposal (
pretractVotes,
) where
--------------------------------------------------------------------------------
import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
import Agora.SafeMoney (GTTag)
import Agora.Utils (mustBePJust)
import Control.Applicative (Const)
import Control.Arrow (first)
import Data.Tagged (Tagged)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
--------------------------------------------------------------------------------
import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
import PlutusLedgerApi.V1.Value (AssetClass)
import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap
--------------------------------------------------------------------------------
import Plutarch.Api.V1 (
KeyGuarantees (Unsorted),
PDatumHash,
@ -73,12 +64,10 @@ import Plutarch.Lift (
import Plutarch.SafeMoney (PDiscrete)
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
import Plutarch.Unsafe (punsafeCoerce)
--------------------------------------------------------------------------------
import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
import Agora.SafeMoney (GTTag)
import Agora.Utils (mustBePJust)
import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
import PlutusLedgerApi.V1.Value (AssetClass)
import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap
--------------------------------------------------------------------------------
-- Haskell-land
@ -88,21 +77,55 @@ import Agora.Utils (mustBePJust)
The 100th proposal will be @'ProposalId' 99@. This counter lives
in the 'Agora.Governor.Governor'. See 'Agora.Governor.nextProposalId', and
'Agora.Governor.pgetNextProposalId'.
@since 0.1.0
-}
newtype ProposalId = ProposalId {proposalTag :: Integer}
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
deriving stock (Eq, Show, GHC.Generic)
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
, -- | @since 0.1.0
PlutusTx.UnsafeFromData
)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
{- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
@
"No" ~ 'ResultTag' 0
"Yes" ~ 'ResultTag' 1
@
@
"No" ~ 'ResultTag' 0
"Yes" ~ 'ResultTag' 1
@
@since 0.1.0
-}
newtype ResultTag = ResultTag {getResultTag :: Integer}
deriving stock (Eq, Show, Ord, GHC.Generic)
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
Ord
, -- | @since 0.1.0
GHC.Generic
)
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
, -- | @since 0.1.0
PlutusTx.UnsafeFromData
)
{- | The "status" of the proposal. This is only useful for state transitions that
need to happen as a result of a transaction as opposed to time-based "periods".
@ -111,6 +134,8 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
If the proposal is 'VotingReady', for instance, that doesn't necessarily
mean that voting is possible, as this also requires the timing to be right.
@since 0.1.0
-}
data ProposalStatus
= -- | A draft proposal represents a proposal that has yet to be realized.
@ -144,13 +169,23 @@ data ProposalStatus
--
-- TODO: The owner of the proposal may choose to reclaim their proposal.
Finished
deriving stock (Eq, Show, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Locked, 2), ('Finished, 3)]
{- | The threshold values for various state transitions to happen.
This data is stored centrally (in the 'Agora.Governor.Governor') and copied over
to 'Proposal's when they are created.
@since 0.1.0
-}
data ProposalThresholds = ProposalThresholds
{ execute :: Tagged GTTag Integer
@ -164,8 +199,16 @@ data ProposalThresholds = ProposalThresholds
-- ^ How much GT required to allow voting to happen.
-- (i.e. to move into 'VotingReady')
}
deriving stock (Eq, Show, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)]
{- | Map which encodes the total tally for each result.
@ -178,18 +221,40 @@ PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)]
Then 'ProposalVotes' needs be of the shape:
@[('ResultTag' 0, n), ('ResultTag' 1, m)]@
@since 0.1.0
-}
newtype ProposalVotes = ProposalVotes
{ getProposalVotes :: AssocMap.Map ResultTag Integer
}
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
deriving stock (Eq, Show, GHC.Generic)
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
, -- | @since 0.1.0
PlutusTx.UnsafeFromData
)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | Create a 'ProposalVotes' that has the same shape as the 'effects' field.
{- | Create a 'ProposalVotes' that has the same shape as the 'effects' field.
@since 0.1.0
-}
emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)
-- | Haskell-level datum for Proposal scripts.
{- | Haskell-level datum for Proposal scripts.
@since 0.1.0
-}
data ProposalDatum = ProposalDatum
{ proposalId :: ProposalId
-- ^ Identification of the proposal.
@ -211,11 +276,21 @@ data ProposalDatum = ProposalDatum
, startingTime :: ProposalStartingTime
-- ^ The time upon the creation of the proposal.
}
deriving stock (Eq, Show, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
-- | Haskell-level redeemer for Proposal scripts.
{- | Haskell-level redeemer for Proposal scripts.
@since 0.1.0
-}
data ProposalRedeemer
= -- | Cast one or more votes towards a particular 'ResultTag'.
Vote ResultTag
@ -253,8 +328,16 @@ data ProposalRedeemer
-- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible
-- to transition into 'Finished' status, because it has expired (and failed).
AdvanceProposal
deriving stock (Eq, Show, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed
''ProposalRedeemer
[ ('Vote, 0)
@ -263,23 +346,49 @@ PlutusTx.makeIsDataIndexed
, ('AdvanceProposal, 3)
]
-- | Parameters that identify the Proposal validator script.
{- | Parameters that identify the Proposal validator script.
@since 0.1.0
-}
data Proposal = Proposal
{ governorSTAssetClass :: AssetClass
, stakeSTAssetClass :: AssetClass
, maximumCosigners :: Integer
-- ^ Arbitrary limit for maximum amount of cosigners on a proposal.
}
deriving stock (Show, Eq, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Eq
, -- | @since 0.1.0
GHC.Generic
)
--------------------------------------------------------------------------------
-- Plutarch-land
-- | Plutarch-level version of 'ResultTag'.
newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PResultTag PInteger)
{- | Plutarch-level version of 'ResultTag'.
@since 0.1.0
-}
newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.1.0
POrd
)
via (DerivePNewtype PResultTag PInteger)
-- | @since 0.1.0
instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag
-- | @since 0.1.0
deriving via
(DerivePConstantViaNewtype ResultTag PResultTag PInteger)
instance
@ -287,6 +396,8 @@ deriving via
-- FIXME: This instance and the one below, for 'PProposalId', should be derived.
-- Soon this will be possible through 'DerivePNewtype'.
-- | @since 0.1.0
instance PTryFrom PData (PAsData PResultTag) where
type PTryFromExcess PData (PAsData PResultTag) = PTryFromExcess PData (PAsData PInteger)
ptryFrom' d k =
@ -300,10 +411,24 @@ instance PTryFrom PData (PAsData PResultTag) where
-- Since 'PResultTag' is a simple newtype, their shape is the same.
k . first punsafeCoerce
-- | Plutarch-level version of 'PProposalId'.
newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalId PInteger)
{- | Plutarch-level version of 'PProposalId'.
@since 0.1.0
-}
newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.1.0
POrd
)
via (DerivePNewtype PProposalId PInteger)
-- | @since 0.1.0
instance PTryFrom PData (PAsData PProposalId) where
type PTryFromExcess PData (PAsData PProposalId) = PTryFromExcess PData (PAsData PInteger)
ptryFrom' d k =
@ -317,13 +442,19 @@ instance PTryFrom PData (PAsData PProposalId) where
-- Since 'PProposalId' is a simple newtype, their shape is the same.
k . first punsafeCoerce
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
-- | @since 0.1.0
deriving via
(DerivePConstantViaNewtype ProposalId PProposalId PInteger)
instance
(PConstantDecl ProposalId)
-- | Plutarch-level version of 'ProposalStatus'.
{- | Plutarch-level version of 'ProposalStatus'.
@since 0.1.0
-}
data PProposalStatus (s :: S)
= -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'.
-- e.g. like Tilde used 'pmatchEnum'.
@ -331,17 +462,38 @@ data PProposalStatus (s :: S)
| PVotingReady (Term s (PDataRecord '[]))
| PLocked (Term s (PDataRecord '[]))
| PFinished (Term s (PDataRecord '[]))
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData, PEq)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
)
via PIsDataReprInstances PProposalStatus
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
-- | @since 0.1.0
deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus)
-- | Plutarch-level version of 'ProposalThresholds'.
{- | Plutarch-level version of 'ProposalThresholds'.
@since 0.1.0
-}
newtype PProposalThresholds (s :: S) = PProposalThresholds
{ getProposalThresholds ::
Term
@ -353,22 +505,52 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData, PDataFields)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
)
via (PIsDataReprInstances PProposalThresholds)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
-- | @since 0.1.0
deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstantDecl ProposalThresholds)
-- | Plutarch-level version of 'ProposalVotes'.
{- | Plutarch-level version of 'ProposalVotes'.
@since 0.1.0
-}
newtype PProposalVotes (s :: S)
= PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger))
deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
-- | Retract votes given the option and the amount of votes.
{- | Retract votes given the option and the amount of votes.
@since 0.1.0
-}
pretractVotes :: Term s (PResultTag :--> PInteger :--> PProposalVotes :--> PProposalVotes)
pretractVotes = phoistAcyclic $
plam $ \rt count votes ->
@ -386,13 +568,19 @@ pretractVotes = phoistAcyclic $
# rt
# voteMap
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes
-- | @since 0.1.0
deriving via
(DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap 'Unsorted PResultTag PInteger))
instance
(PConstantDecl ProposalVotes)
-- | Plutarch-level version of 'emptyVotesFor'.
{- | Plutarch-level version of 'emptyVotesFor'.
@since 0.1.0
-}
pemptyVotesFor :: forall s a. (PIsData a) => Term s (PMap 'Unsorted PResultTag a :--> PProposalVotes)
pemptyVotesFor =
phoistAcyclic $
@ -402,7 +590,10 @@ pemptyVotesFor =
PProposalVotes $ PM.pmap # plam (const $ pconstant 0) # m
)
-- | Plutarch-level version of 'ProposalDatum'.
{- | Plutarch-level version of 'ProposalDatum'.
@since 0.1.0
-}
newtype PProposalDatum (s :: S) = PProposalDatum
{ getProposalDatum ::
Term
@ -419,36 +610,76 @@ newtype PProposalDatum (s :: S) = PProposalDatum
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData, PDataFields, PEq)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0
PEq
)
via (PIsDataReprInstances PProposalDatum)
-- TODO: Derive this.
-- | @since 0.1.0
instance PTryFrom PData (PAsData PProposalDatum) where
type PTryFromExcess PData (PAsData PProposalDatum) = Const ()
ptryFrom' d k =
k (punsafeCoerce d, ())
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
-- | @since 0.1.0
deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
-- | Plutarch-level version of 'ProposalRedeemer'.
{- | Plutarch-level version of 'ProposalRedeemer'.
@since 0.1.0
-}
data PProposalRedeemer (s :: S)
= PVote (Term s (PDataRecord '["resultTag" ':= PResultTag]))
| PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)]))
| PUnlock (Term s (PDataRecord '["resultTag" ':= PResultTag]))
| PAdvanceProposal (Term s (PDataRecord '[]))
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via PIsDataReprInstances PProposalRedeemer
-- See below.
-- | @since 0.1.0
instance PTryFrom PData (PAsData PProposalRedeemer) where
type PTryFromExcess PData (PAsData PProposalRedeemer) = Const ()
ptryFrom' d k =
@ -460,7 +691,10 @@ instance PTryFrom PData (PAsData PProposalRedeemer) where
-- instance
-- PTryFrom PData (PAsData PProposalRedeemer)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
-- | @since 0.1.0
deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer)
--------------------------------------------------------------------------------
@ -468,6 +702,8 @@ deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instanc
{- | Check for various invariants a proposal must uphold.
This can be used to check both upon creation and
upon any following state transitions in the proposal.
@since 0.1.0
-}
proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool)
proposalDatumValid proposal =
@ -495,6 +731,8 @@ proposalDatumValid proposal =
The winner should be unambiguous, meaning that if two options have the same highest votes,
the "neutral" option will be the winner.
@since 0.1.0
-}
pwinner ::
Term
@ -540,7 +778,10 @@ pwinner = phoistAcyclic $
winnerResultTag
neutral
-- | Find the winning outcome (and the corresponding vote count) given the votes.
{- | Find the winning outcome (and the corresponding vote count) given the votes.
@since 0.1.0
-}
phighestVotes ::
Term
s
@ -566,7 +807,10 @@ phighestVotes = phoistAcyclic $
in pif (lastVotes #< thisVotes) this last
in pfoldr # f # (phead # l) # l
-- | Find the "neutral" option (a dummy outcome with no effect) given the effects.
{- | Find the "neutral" option (a dummy outcome with no effect) given the effects.
@since 0.1.0
-}
pneutralOption ::
Term
s

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

@ -85,6 +85,8 @@ import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
=== For burning:
- This policy cannot be burned.
@since 0.1.0
-}
proposalPolicy ::
-- | The assetclass of GST, see 'Agora.Governor.Scripts.governorPolicy'.
@ -119,29 +121,31 @@ proposalPolicy (AssetClass (govCs, govTn)) =
{- | The validator for Proposals.
The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
== What this validator does
== What this validator does
=== Voting/unlocking
=== Voting/unlocking
When voting and unlocking, the proposal must witness a state transition
occuring in the relevant Stake. This transition must place a lock on
the stake that is tagged with the right 'Agora.Proposal.ResultTag', and 'Agora.Proposal.ProposalId'.
When voting and unlocking, the proposal must witness a state transition
occuring in the relevant Stake. This transition must place a lock on
the stake that is tagged with the right 'Agora.Proposal.ResultTag', and 'Agora.Proposal.ProposalId'.
=== Periods
=== Periods
Most redeemers are time-sensitive.
Most redeemers are time-sensitive.
A list of all time-sensitive redeemers and their requirements:
A list of all time-sensitive redeemers and their requirements:
- 'Agora.Proposal.Vote' can only be used when both the status is in 'Agora.Proposal.VotingReady',
- 'Agora.Proposal.Vote' can only be used when both the status is in 'Agora.Proposal.VotingReady',
and 'Agora.Proposal.Time.isVotingPeriod' is true.
- 'Agora.Proposal.Cosign' can only be used when both the status is in 'Agora.Proposal.Draft',
- 'Agora.Proposal.Cosign' can only be used when both the status is in 'Agora.Proposal.Draft',
and 'Agora.Proposal.Time.isDraftPeriod' is true.
- 'Agora.Proposal.AdvanceProposal' can only be used when the status can be advanced
- 'Agora.Proposal.AdvanceProposal' can only be used when the status can be advanced
(see 'Agora.Proposal.AdvanceProposal' docs).
- 'Agora.Proposal.Unlock' is always valid.
- 'Agora.Proposal.Unlock' is always valid.
@since 0.1.0
-}
proposalValidator :: Proposal -> ClosedTerm PValidator
proposalValidator proposal =

149
agora/Agora/Proposal/Time.hs
View file

@ -58,7 +58,10 @@ import Prelude hiding ((+))
--------------------------------------------------------------------------------
-- | Represents the starting time of the proposal.
{- | Represents the starting time of the proposal.
@since 0.1.0
-}
newtype ProposalStartingTime = ProposalStartingTime
{ getProposalStartingTime :: POSIXTime
}
@ -67,7 +70,9 @@ newtype ProposalStartingTime = ProposalStartingTime
{- | Configuration of proposal timings.
See: https://github.com/Liqwid-Labs/agora/blob/master/docs/tech-design/proposals.md#when-may-interactions-occur
See: https://liqwid.notion.site/Proposals-589853145a994057aa77f397079f75e4#d25ea378768d4c76b52dd4c1b6bc0fcd
@since 0.1.0
-}
data ProposalTimingConfig = ProposalTimingConfig
{ draftTime :: POSIXTime
@ -79,14 +84,38 @@ data ProposalTimingConfig = ProposalTimingConfig
, executingTime :: POSIXTime
-- ^ "E": the length of the execution period.
}
deriving stock (Eq, Show, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)]
-- | Represents the maximum width of a 'PlutusLedgerApi.V1.Time.POSIXTimeRange'.
newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
deriving stock (Eq, Show, Ord, GHC.Generic)
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
Ord
, -- | @since 0.1.0
GHC.Generic
)
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
, -- | @since 0.1.0
PlutusTx.UnsafeFromData
)
--------------------------------------------------------------------------------
@ -114,26 +143,56 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
Note: 'PProposalTime' doesn't need a Haskell-level equivalent because it
is only used in scripts, and does not go in datums. It is also scott-encoded
which is more efficient in usage.
@since 0.1.0
-}
data PProposalTime (s :: S) = PProposalTime
{ lowerBound :: Term s PPOSIXTime
, upperBound :: Term s PPOSIXTime
}
deriving stock (GHC.Generic)
deriving anyclass (Generic, PlutusType, HasDatatypeInfo, PEq)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
HasDatatypeInfo
, -- | @since 0.1.0
PEq
)
-- | Plutarch-level version of 'ProposalStartingTime'.
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalStartingTime PPOSIXTime)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.1.0
POrd
)
via (DerivePNewtype PProposalStartingTime PPOSIXTime)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalStartingTime where
type PLifted PProposalStartingTime = ProposalStartingTime
-- | @since 0.1.0
deriving via
(DerivePConstantViaNewtype ProposalStartingTime PProposalStartingTime PPOSIXTime)
instance
(PConstantDecl ProposalStartingTime)
-- | Plutarch-level version of 'ProposalTimingConfig'.
{- | Plutarch-level version of 'ProposalTimingConfig'.
@since 0.1.0
-}
newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
{ getProposalTimingConfig ::
Term
@ -146,15 +205,33 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData, PDataFields)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
)
via (PIsDataReprInstances PProposalTimingConfig)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalTimingConfig where
type PLifted PProposalTimingConfig = ProposalTimingConfig
-- | @since 0.1.0
deriving via
(DerivePConstantViaData ProposalTimingConfig PProposalTimingConfig)
instance
@ -163,9 +240,22 @@ deriving via
-- | Plutarch-level version of 'MaxTimeRangeWidth'.
newtype PMaxTimeRangeWidth (s :: S)
= PMaxTimeRangeWidth (Term s PPOSIXTime)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.1.0
POrd
)
via (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime)
-- | @since 0.1.0
instance PUnsafeLiftDecl PMaxTimeRangeWidth where type PLifted PMaxTimeRangeWidth = MaxTimeRangeWidth
-- | @since 0.1.0
deriving via
(DerivePConstantViaNewtype MaxTimeRangeWidth PMaxTimeRangeWidth PPOSIXTime)
instance
@ -174,12 +264,16 @@ deriving via
--------------------------------------------------------------------------------
-- FIXME: Orphan instance, move this to plutarch-extra.
-- | @since 0.1.0
instance AdditiveSemigroup (Term s PPOSIXTime) where
(punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
{- | Get the starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
For every proposal, this is only meant to run once upon creation. Given time range should be
tight enough, meaning that the width of the time range should be less than the maximum value.
@since 0.1.0
-}
createProposalStartingTime :: forall (s :: S). Term s (PMaxTimeRangeWidth :--> PPOSIXTimeRange :--> PProposalStartingTime)
createProposalStartingTime = phoistAcyclic $
@ -203,6 +297,8 @@ createProposalStartingTime = phoistAcyclic $
If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is
an infinity) then we error out.
@since 0.1.0
-}
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
currentProposalTime = phoistAcyclic $
@ -232,7 +328,10 @@ currentProposalTime = phoistAcyclic $
)
}
-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
{- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
@since 0.1.0
-}
proposalTimeWithin ::
Term
s
@ -251,7 +350,10 @@ proposalTimeWithin = phoistAcyclic $
, ut #<= h
]
-- | True if the 'PProposalTime' is in the draft period.
{- | True if the 'PProposalTime' is in the draft period.
@since 0.1.0
-}
isDraftPeriod ::
forall (s :: S).
Term
@ -265,7 +367,10 @@ isDraftPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
proposalTimeWithin # s # (s + (pfield @"draftTime" # config))
-- | True if the 'PProposalTime' is in the voting period.
{- | True if the 'PProposalTime' is in the voting period.
@since 0.1.0
-}
isVotingPeriod ::
forall (s :: S).
Term
@ -280,7 +385,10 @@ isVotingPeriod = phoistAcyclic $
pletFields @'["draftTime", "votingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime)
-- | True if the 'PProposalTime' is in the locking period.
{- | True if the 'PProposalTime' is in the locking period.
@since 0.1.0
-}
isLockingPeriod ::
forall (s :: S).
Term
@ -295,7 +403,10 @@ isLockingPeriod = phoistAcyclic $
pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
-- | True if the 'PProposalTime' is in the execution period.
{- | True if the 'PProposalTime' is in the execution period.
@since 0.1.0
-}
isExecutionPeriod ::
forall (s :: S).
Term

38
agora/Agora/SafeMoney.hs
View file

@ -1,7 +1,7 @@
{- |
Module : Agora.SafeMoney
Maintainer : emi@haskell.fyi
Description: Tags and bonuses for Plutarch.SafeMoney.
Description: Tags and extras for "Plutarch.SafeMoney".
Tags and extras for "Plutarch.SafeMoney".
-}
@ -14,32 +14,42 @@ module Agora.SafeMoney (
adaRef,
) where
--------------------------------------------------------------------------------
import Data.Tagged (Tagged (Tagged))
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
import Data.Tagged (Tagged (Tagged))
{- | Governance token.
--------------------------------------------------------------------------------
-- Tags
-- | Governance token.
@since 0.1.0
-}
data GTTag
-- | ADA.
{- | ADA.
@since 0.1.0
-}
data ADATag
-- | Governor ST token.
{- | Governor ST token.
@since 0.1.0
-}
data GovernorSTTag
-- | Stake ST token.
{- | Stake ST token.
@since 0.1.0
-}
data StakeSTTag
-- | Proposal ST token.
{- | Proposal ST token.
@since 0.1.0
-}
data ProposalSTTag
--------------------------------------------------------------------------------
{- | Resolves ada tags.
-- | Resolves ada tags.
@since 0.1.0
-}
adaRef :: Tagged ADATag AssetClass
adaRef = Tagged (AssetClass ("", ""))

52
agora/Agora/ScriptInfo.hs
View file

@ -22,17 +22,35 @@ import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMinti
import PlutusLedgerApi.V1 (MintingPolicy, Validator, ValidatorHash)
import PlutusLedgerApi.V1.Value (CurrencySymbol)
-- | Bundle containing a 'Validator' and its hash.
{- | Bundle containing a 'Validator' and its hash.
@since 0.1.0
-}
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)
deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Eq
, -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Aeson.ToJSON
, -- | @since 0.1.0
Aeson.FromJSON
)
-- | Create a 'ValidatorInfo' given a Plutarch term.
{- | Create a 'ValidatorInfo' given a Plutarch term.
@since 0.1.0
-}
mkValidatorInfo :: ClosedTerm PValidator -> ValidatorInfo
mkValidatorInfo term =
ValidatorInfo
@ -42,17 +60,35 @@ mkValidatorInfo term =
where
validator = mkValidator term
-- | Bundle containing a 'MintingPolicy' and its symbol.
{- | Bundle containing a 'MintingPolicy' and its symbol.
@since 0.1.0
-}
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)
deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Eq
, -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Aeson.ToJSON
, -- | @since 0.1.0
Aeson.FromJSON
)
-- | Create a 'PolicyInfo' given a Plutarch term.
{- | Create a 'PolicyInfo' given a Plutarch term.
@since 0.1.0
-}
mkPolicyInfo :: ClosedTerm PMintingPolicy -> PolicyInfo
mkPolicyInfo term =
PolicyInfo

129
agora/Agora/Stake.hs
View file

@ -72,13 +72,19 @@ import Agora.SafeMoney (GTTag)
--------------------------------------------------------------------------------
-- | Parameters for creating Stake scripts.
{- | Parameters for creating Stake scripts.
@since 0.1.0
-}
data Stake = Stake
{ gtClassRef :: Tagged GTTag AssetClass
-- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
, proposalSTClass :: AssetClass
}
deriving stock (GHC.Generic)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
{- | A lock placed on a Stake datum in order to prevent
depositing and withdrawing when votes are in place.
@ -105,6 +111,8 @@ data Stake = Stake
│ Stake Policy │◄─┘ └►│ Proposal Policy │
└──────────────┘ └─────────────────┘
@
@since 0.1.0
-}
data ProposalLock = ProposalLock
{ vote :: ResultTag
@ -114,11 +122,19 @@ data ProposalLock = ProposalLock
-- ^ Identifies the proposal. See 'ProposalId' for further
-- comments on its significance.
}
deriving stock (Show, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
PlutusTx.makeIsDataIndexed ''ProposalLock [('ProposalLock, 0)]
-- | Haskell-level redeemer for Stake scripts.
{- | Haskell-level redeemer for Stake scripts.
@since 0.1.0
-}
data StakeRedeemer
= -- | Deposit or withdraw a discrete amount of the staked governance token.
-- Stake must be unlocked.
@ -151,7 +167,10 @@ PlutusTx.makeIsDataIndexed
, ('WitnessStake, 4)
]
-- | Haskell-level datum for Stake scripts.
{- | Haskell-level datum for Stake scripts.
@since 0.1.0
-}
data StakeDatum = StakeDatum
{ stakedAmount :: Tagged GTTag Integer
-- ^ Tracks the amount of governance token staked in the datum.
@ -171,7 +190,10 @@ PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
--------------------------------------------------------------------------------
-- | Plutarch-level datum for Stake scripts.
{- | Plutarch-level datum for Stake scripts.
@since 0.1.0
-}
newtype PStakeDatum (s :: S) = PStakeDatum
{ getStakeDatum ::
Term
@ -183,11 +205,28 @@ newtype PStakeDatum (s :: S) = PStakeDatum
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData, PDataFields, PEq)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0
PEq
)
via (PIsDataReprInstances PStakeDatum)
instance PTryFrom PData (PAsData PStakeDatum) where
@ -198,7 +237,10 @@ instance PTryFrom PData (PAsData PStakeDatum) where
instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstantDecl StakeDatum)
-- | Plutarch-level redeemer for Stake scripts.
{- | Plutarch-level redeemer for Stake scripts.
@since 0.1.0
-}
data PStakeRedeemer (s :: S)
= -- | Deposit or withdraw a discrete amount of the staked governance token.
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
@ -207,11 +249,24 @@ data PStakeRedeemer (s :: S)
| PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock]))
| PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)]))
| PWitnessStake (Term s (PDataRecord '[]))
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via PIsDataReprInstances PStakeRedeemer
deriving via
@ -222,7 +277,10 @@ deriving via
instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstantDecl StakeRedeemer)
-- | Plutarch-level version of 'ProposalLock'.
{- | Plutarch-level version of 'ProposalLock'.
@since 0.1.0
-}
newtype PProposalLock (s :: S) = PProposalLock
{ getProposalLock ::
Term
@ -250,7 +308,10 @@ deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PCons
--------------------------------------------------------------------------------
-- | Check whether a Stake is locked. If it is locked, various actions are unavailable.
{- | Check whether a Stake is locked. If it is locked, various actions are unavailable.
@since 0.1.0
-}
stakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
stakeLocked = phoistAcyclic $
plam $ \stakeDatum ->
@ -258,7 +319,10 @@ stakeLocked = phoistAcyclic $
locks = pfield @"lockedBy" # stakeDatum
in pnotNull # locks
-- | Find a stake owned by a particular PK.
{- | Find a stake owned by a particular PK.
@since 0.1.0
-}
findStakeOwnedBy ::
Term
s
@ -281,6 +345,10 @@ findStakeOwnedBy = phoistAcyclic $
PDJust ((pfield @"_0" #) -> dh) ->
ptryFindDatum @(PAsData PStakeDatum) # dh # datums
{- | Check if a StakeDatum is owned by a particular public key.
@since 0.1.0
-}
stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
stakeDatumOwnedBy =
phoistAcyclic $
@ -288,7 +356,10 @@ stakeDatumOwnedBy =
pletFields @'["owner"] (pto stakeDatum) $ \stakeDatumF ->
stakeDatumF.owner #== pdata pk
-- | Does the input have a `Stake` owned by a particular PK?
{- | Does the input have a `Stake` owned by a particular PK?
@since 0.1.0
-}
isInputStakeOwnedBy ::
Term
_
@ -317,16 +388,32 @@ isInputStakeOwnedBy =
{- | Represent the usage of a stake on a particular proposal.
A stake can be used to either create or vote on a proposal.
@since 0.1.0
-}
data PStakeUsage (s :: S)
= PVotedFor (Term s PResultTag)
| PCreated
| PDidNothing
deriving stock (GHC.Generic)
deriving anyclass (Generic, PlutusType, HasDatatypeInfo, PEq)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
HasDatatypeInfo
, -- | @since 0.1.0
PEq
)
{- | / O(n) /.Return the usage of a stake on a particular proposal,
given the 'lockedBy' field of a stake and the target proposal.
@since 0.1.0
-}
pgetStakeUsage ::
Term

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

@ -57,6 +57,8 @@ import Prelude hiding (Num (..))
- Check that exactly one state thread is burned.
- Check that datum at state thread is valid and not locked.
@since 0.1.0
-}
stakePolicy ::
-- | The (governance) token that a Stake can store.
@ -153,53 +155,55 @@ stakePolicy gtClassRef =
{- | Validator intended for Stake UTXOs to be locked by.
== What this Validator does:
== What this Validator does:
=== 'DepositWithdraw'
=== 'DepositWithdraw'
Deposit or withdraw some GT to the stake.
Deposit or withdraw some GT to the stake.
- Tx must be signed by the owner.
- The 'stakedAmount' field must be updated.
- The stake must not be locked.
- The new UTXO must have the previous value plus the difference
- Tx must be signed by the owner.
- The 'stakedAmount' field must be updated.
- The stake must not be locked.
- The new UTXO must have the previous value plus the difference
as stated by the redeemer.
=== 'PermitVote'
=== 'PermitVote'
Allow a 'ProposalLock' to be put on the stake in order to vote
on a proposal.
Allow a 'ProposalLock' to be put on the stake in order to vote
on a proposal.
- A proposal token must be spent alongside the stake.
- A proposal token must be spent alongside the stake.
* Its total votes must be correctly updated to include this stake's
contribution.
- Tx must be signed by the owner.
- Tx must be signed by the owner.
=== 'RetractVotes'
=== 'RetractVotes'
Remove a 'ProposalLock' set when voting on a proposal.
Remove a 'ProposalLock' set when voting on a proposal.
- A proposal token must be spent alongside the stake.
- Tx must be signed by the owner.
- A proposal token must be spent alongside the stake.
- Tx must be signed by the owner.
=== 'Destroy'
=== 'Destroy'
Destroy the stake in order to reclaim the min ADA.
Destroy the stake in order to reclaim the min ADA.
- The stake must not be locked.
- Tx must be signed by the owner.
- The stake must not be locked.
- Tx must be signed by the owner.
=== 'WitnessStake'
=== 'WitnessStake'
Allow this Stake to be included in a transaction without making
any changes to it. In the future,
this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
Allow this Stake to be included in a transaction without making
any changes to it. In the future,
this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
- Tx must be signed by the owner __or__ a proposal ST token must be spent
- Tx must be signed by the owner __or__ a proposal ST token must be spent
alongside the stake.
- The datum and value must remain unchanged.
- The datum and value must remain unchanged.
@since 0.1.0
-}
stakeValidator :: Stake -> ClosedTerm PValidator
stakeValidator stake =

43
agora/Agora/Treasury.hs
View file

@ -12,7 +12,7 @@ module Agora.Treasury (module Agora.Treasury) where
import Agora.AuthorityToken (singleAuthorityTokenBurned)
import GHC.Generics qualified as GHC
import Generics.SOP
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (PValidator)
import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
import "plutarch" Plutarch.Api.V1.Value (PValue)
@ -26,14 +26,23 @@ import Plutarch.TryFrom ()
import PlutusLedgerApi.V1.Value (CurrencySymbol)
import PlutusTx qualified
--------------------------------------------------------------------------------
{- | Redeemer for Treasury actions.
-- | Redeemer for Treasury actions.
@since 0.1.0
-}
data TreasuryRedeemer
= -- | Allow transaction to pass by delegating to GAT burn.
SpendTreasuryGAT
deriving stock (Eq, Show, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed
''TreasuryRedeemer
[ ('SpendTreasuryGAT, 0)
@ -43,24 +52,42 @@ PlutusTx.makeIsDataIndexed
{- | Plutarch level type representing valid redeemers of the
treasury.
@since 0.1.0
-}
newtype PTreasuryRedeemer (s :: S)
= -- | Alters treasury parameters, subject to the burning of a
-- governance authority token.
PSpendTreasuryGAT (Term s (PDataRecord '[]))
deriving stock (GHC.Generic)
deriving anyclass (Generic, PIsDataRepr)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
PIsDataRepr
)
deriving
(PlutusType, PIsData)
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via PIsDataReprInstances PTreasuryRedeemer
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PTreasuryRedeemer)
instance
PTryFrom PData (PAsData PTreasuryRedeemer)
-- | @since 0.1.0
instance PUnsafeLiftDecl PTreasuryRedeemer where
type PLifted PTreasuryRedeemer = TreasuryRedeemer
-- | @since 0.1.0
deriving via
(DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer)
instance
@ -70,6 +97,8 @@ deriving via
{- | Validator ensuring that transactions consuming the treasury
do so in a valid manner.
@since 0.1.0
-}
treasuryValidator ::
-- | Governance Authority Token that can unlock this validator.

75
agora/Agora/Utils.hs
View file

@ -21,18 +21,6 @@ module Agora.Utils (
isPubKey,
) where
--------------------------------------------------------------------------------
import PlutusLedgerApi.V1 (
Address (..),
Credential (..),
CurrencySymbol,
TokenName (..),
ValidatorHash (..),
)
--------------------------------------------------------------------------------
import Plutarch.Api.V1 (
AmountGuarantees,
KeyGuarantees,
@ -56,12 +44,22 @@ import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (psymbolValueOf)
import Plutarch.Builtin (pforgetData)
import Plutarch.Extra.List (plookupTuple)
import Plutarch.Extra.TermCont (pletC, pmatchC)
import PlutusLedgerApi.V1 (
Address (..),
Credential (..),
CurrencySymbol,
TokenName (..),
ValidatorHash (..),
)
{- Functions which should (probably) not be upstreamed
All of these functions are quite inefficient.
-}
-- | Get script hash from an Address.
{- | Get script hash from an Address.
@since 0.1.0
-}
scriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash)
scriptHashFromAddress = phoistAcyclic $
plam $ \addr ->
@ -69,12 +67,18 @@ scriptHashFromAddress = phoistAcyclic $
PScriptCredential ((pfield @"_0" #) -> h) -> pcon $ PJust h
_ -> pcon PNothing
-- | Return true if the given address is a script address.
{- | Return true if the given address is a script address.
@since 0.1.0
-}
isScriptAddress :: Term s (PAddress :--> PBool)
isScriptAddress = phoistAcyclic $
plam $ \addr -> pnot #$ isPubKey #$ pfromData $ pfield @"credential" # addr
-- | Return true if the given credential is a pub-key-hash.
{- | Return true if the given credential is a pub-key-hash.
@since 0.1.0
-}
isPubKey :: Term s (PCredential :--> PBool)
isPubKey = phoistAcyclic $
plam $ \cred ->
@ -82,7 +86,10 @@ isPubKey = phoistAcyclic $
PScriptCredential _ -> pconstant False
_ -> pconstant True
-- | Find all TxOuts sent to an Address
{- | Find all TxOuts sent to an Address
@since 0.1.0
-}
findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut))
findOutputsToAddress = phoistAcyclic $
plam $ \outputs address' -> unTermCont $ do
@ -91,7 +98,10 @@ findOutputsToAddress = phoistAcyclic $
pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address)
# outputs
-- | Find the data corresponding to a TxOut, if there is one
{- | Find the data corresponding to a TxOut, if there is one
@since 0.1.0
-}
findTxOutDatum :: Term s (PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PTxOut :--> PMaybe PDatum)
findTxOutDatum = phoistAcyclic $
plam $ \datums out -> unTermCont $ do
@ -102,19 +112,30 @@ findTxOutDatum = phoistAcyclic $
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
tokens for extra safety.
@since 0.1.0
-}
validatorHashToTokenName :: ValidatorHash -> TokenName
validatorHashToTokenName (ValidatorHash hash) = TokenName hash
-- | Plutarch level 'validatorHashToTokenName'.
{- | Plutarch level 'validatorHashToTokenName'.
@since 0.1.0
-}
pvalidatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName
pvalidatorHashToTokenName vh = pcon (PTokenName (pto vh))
-- | Get the CurrencySymbol of a PMintingPolicy.
{- | Get the CurrencySymbol of a PMintingPolicy.
@since 0.1.0
-}
getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v
-- | The entire value only contains one token of the given currency symbol.
{- | The entire value only contains one token of the given currency symbol.
@since 0.1.0
-}
hasOnlyOneTokenOfCurrencySymbol ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s (PCurrencySymbol :--> PValue keys amounts :--> PBool)
@ -123,7 +144,10 @@ hasOnlyOneTokenOfCurrencySymbol = phoistAcyclic $
psymbolValueOf # cs # vs #== 1
#&& (plength #$ pto $ pto $ pto vs) #== 1
-- | Find datum given a maybe datum hash
{- | Find datum given a maybe datum hash
@since 0.1.0
-}
mustFindDatum' ::
forall (datum :: PType).
(PIsData datum, PTryFrom PData (PAsData datum)) =>
@ -143,6 +167,8 @@ mustFindDatum' = phoistAcyclic $
{- | Extract the value stored in a PMaybe container.
If there's no value, throw an error with the given message.
@since 0.1.0
-}
mustBePJust :: forall a s. Term s (PString :--> PMaybe a :--> a)
mustBePJust = phoistAcyclic $
@ -152,6 +178,8 @@ mustBePJust = phoistAcyclic $
{- | Extract the value stored in a PMaybeData container.
If there's no value, throw an error with the given message.
@since 0.1.0
-}
mustBePDJust :: forall a s. (PIsData a) => Term s (PString :--> PMaybeData a :--> a)
mustBePDJust = phoistAcyclic $
@ -159,6 +187,9 @@ mustBePDJust = phoistAcyclic $
PDJust ((pfield @"_0" #) -> v) -> v
_ -> ptraceError emsg
-- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
{- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
@since 0.1.0
-}
validatorHashToAddress :: ValidatorHash -> Address
validatorHashToAddress vh = Address (ScriptCredential vh) Nothing