Merge branch 'master' of github.com:Liqwid-Labs/agora into jhodgdev/treasury-tests
This commit is contained in:
Jack Hodgkinson
commit
d59967f6ed
27 changed files with 1379 additions and 548 deletions
71
CONTRIBUTING.md
Normal file
71
CONTRIBUTING.md
Normal file
|
|
@ -0,0 +1,71 @@
|
|||
# Contributing
|
||||
|
||||
This document is intended for those whom wish to contribute to Agora, in the form of submitting issues or writing pull requests (PR). Thank you! The Agora core team is delighted to have community members contribute to our project.
|
||||
|
||||
Before making any form of contribution, it is advised that one familiarises themselves with the [existing documentation](./docs). This will enable the contributor to submit better, more informed issues and will potentially aid a developer in writing PRs.
|
||||
|
||||
## Agora core team
|
||||
|
||||
This document will make reference to the _Agora core team_. These are the people who work on Agora professionally and will be responsible for maintaining the project in its open source life. They include:
|
||||
|
||||
- [Emily Martins](https://github.com/emiflake)
|
||||
- [Jack Hodgkinson](https://github.com/jhodgdev)
|
||||
|
||||
## Issues
|
||||
|
||||
An _issue_ is a post on the Agora [Issues page](https://github.com/Liqwid-Labs/agora/issues). An issue may pertain to:
|
||||
|
||||
- A bug.
|
||||
- A desired feature.
|
||||
- A question one has that is not covered within documentation.
|
||||
|
||||
Before submitting an issue, please check that the same issue has not already been provided by another contributor. Such an issue could be _open_ (unresolved) or _closed_ (considered resolved). If it is open, please comment with your perspective on the issue. If it is closed, please read-through what has been posted on the issue page. If you believe the issue is still unresolved, feel free to re-open it along with a post explaining your reasons for doing so.
|
||||
|
||||
If your issue has _not_ been submitted hitherto, please submit a new issue. To assist the Agora community please provide _as much_ detail as you feel is relevant. For bugs, _please_ include instructions on how to reproduce the issue and provide any terminal outputs. Please remember to tag your issue with GitHub's labelling system.
|
||||
|
||||
Top-tier issues include a _minimal reproducible example_. This should take the form of a public GitHub repository containing _only the code required to reproduce the issue_. Alongside a link to such a repository, please detail steps on how a maintainer may recreate the issue on their system.
|
||||
|
||||
If you wish to work to resolve the issue, the Agora team would invite you to submit a PR.
|
||||
|
||||
## Pull requests
|
||||
|
||||
Only those within the core Agora team may contribute work to the project directly. If you wish to work on the project, you must [fork](https://docs.github.com/en/get-started/quickstart/fork-a-repo) the repository and submit your changes to your fork. Instructions for getting started with the project may be found in the [README](./README.md). Once the work on your fork is completed, you may submit a PR [here](https://github.com/Liqwid-Labs/agora/pulls).
|
||||
|
||||
Before submitting a PR, please write an issue pertaining to the problem that your PR would solve e.g. a bug in the codebase or a missing feature. Read this document's section on _Issues_ and pay particular heed to the paragraph asking contributors to _look for pre-existing issues_. The prior experiences of existing contributors could save you a significant amount of time and effort. It is possible that a number of issues could be solved by your PR. Please reference any issues that would be ameliorated by your PR - including your own issue, if you have written one - clearly. Please label your PR using GitHub's tagging feature. Please state plainly:
|
||||
|
||||
- What your PR achieves.
|
||||
- How your PR works.
|
||||
- What your PR changes.
|
||||
- Any aspects of your work that you believe merit especially careful review.
|
||||
|
||||
Contributors should expect that if their work is insufficiently documented (either on GitHub or within the codebase) that their PR will not be reviewed by core Agora team members. Contributors should expect that an Agora maintainer may offer constructive feedback and request changes to be made, prior to the PR being incorporated into the project.
|
||||
|
||||
### Technical requirements
|
||||
|
||||
Agora utilises [Plutarch](https://github.com/plutonomicon/plutarch) and your work must be written with Plutarch, when appropriate. Plutarch can prove _complicated_ but the documentation is extensive. We would encourage you to dive deeply into the documentation, whilst stating that Plutarch's [Tricks.md](https://github.com/Plutonomicon/plutarch/blob/master/docs/Tricks.md) could prove particularly helpful.
|
||||
|
||||
### Stylistic guidelines
|
||||
|
||||
All work must comply with the [MLabs style guide](https://github.com/mlabs-haskell/styleguide/).
|
||||
|
||||
### Continuous integration
|
||||
|
||||
For your PR to be merged it must pass three automated checks:
|
||||
|
||||
1. A [`fourmolu`](https://github.com/fourmolu/fourmolu) formatting check.
|
||||
2. A [`hlint`](https://github.com/ndmitchell/hlint) linting check.
|
||||
3. A Cabal build check.
|
||||
|
||||
Our custom `fourmolu` rules may be found in the [base of the repository](./fourmolu.yaml). You can ensure that your work will pass CI by:
|
||||
|
||||
1. Running `make format` from the included `Makefile`.
|
||||
2. Running `make lint` from the included `Makefile` and applying any recommendations.
|
||||
3. Ensuring that `cabal build` terminates successfully on your machine in the provided Nix environment.
|
||||
|
||||
## Documentation
|
||||
|
||||
It is worth noting that the codebase is not the only aspect of the project that it is worth contributing to. In the event that one finds the docs unsatisfactory, the Agora team would welcome receiving any issues describing your reservations or PRs pertaining to documentation.
|
||||
|
||||
## Conclusion
|
||||
|
||||
Many thanks for reading. The Agora core team is delighted to be able to share the project with the Cardano community and we are thrilled by the prospect of collaborating with you all on improving our work.
|
||||
1
Makefile
1
Makefile
|
|
@ -12,6 +12,7 @@ usage:
|
|||
@echo " haddock -- Generate Haddock docs for project"
|
||||
|
||||
hoogle:
|
||||
pkill hoogle || true
|
||||
hoogle generate --local=haddock --database=hoo/local.hoo
|
||||
hoogle server --local -p 8081 >> /dev/null &
|
||||
hoogle server --local --database=hoo/local.hoo -p 8082 >> /dev/null &
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
# Agora
|
||||
# Agora :classical_building:
|
||||
|
||||
|
||||
Agora is a set of Plutus scripts that compose together to form a governance system.
|
||||
|
||||
|
|
@ -24,6 +25,10 @@ Open a development shell with `nix develop` and build the project with `cabal bu
|
|||
|
||||
Documentation for Agora may be found in [docs](./docs).
|
||||
|
||||
### Using Agora for your protocol
|
||||
|
||||
If you are a protocol wanting to use Agora, read [Using Agora](./docs/using-agora.md).
|
||||
|
||||
## Road-map
|
||||
|
||||
### v1
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import Test.Tasty (defaultMain, testGroup)
|
|||
import Spec.Model.MultiSig qualified as MultiSig
|
||||
import Spec.Stake qualified as Stake
|
||||
|
||||
-- | The Agora test suite
|
||||
-- | The Agora test suite.
|
||||
main :: IO ()
|
||||
main =
|
||||
defaultMain $
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ import Apropos (
|
|||
import Apropos.Gen (Gen, choice, int, linear, list)
|
||||
import Apropos.LogicalModel (Enumerable)
|
||||
import Apropos.LogicalModel.Enumerable (Enumerable (enumerated))
|
||||
import Apropos.Script (HasScriptRunner (expect, runScriptTestsWhere, script))
|
||||
import Apropos.Script (ScriptModel (expect, runScriptTestsWhere, script))
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.Hedgehog (fromGroup)
|
||||
|
||||
|
|
@ -157,7 +157,7 @@ instance HasParameterisedGenerator MultiSigProp MultiSigModel where
|
|||
-- Return the generated model.
|
||||
pure (MultiSigModel msig ctx)
|
||||
|
||||
instance HasScriptRunner MultiSigProp MultiSigModel where
|
||||
instance ScriptModel MultiSigProp MultiSigModel where
|
||||
-- When the script runs, we want the model to meet the minimum signatures.
|
||||
expect :: (MultiSigModel :+ MultiSigProp) -> Formula MultiSigProp
|
||||
expect Apropos = Var MeetsMinSigs
|
||||
|
|
@ -171,7 +171,7 @@ instance HasScriptRunner MultiSigProp MultiSigModel where
|
|||
(pcon PUnit)
|
||||
perror
|
||||
|
||||
-- | Consistency tests for the 'HasParameterisedGenerator' instance of 'MultiSigModel'
|
||||
-- | Consistency tests for the 'HasParameterisedGenerator' instance of 'MultiSigModel'.
|
||||
genTests :: TestTree
|
||||
genTests =
|
||||
testGroup "genTests" $
|
||||
|
|
@ -182,7 +182,7 @@ genTests =
|
|||
Yes
|
||||
]
|
||||
|
||||
-- | Tests for the 'HasScriptRunner' instance of 'MultiSigModel'
|
||||
-- | Tests for the 'ScriptModel' instance of 'MultiSigModel'.
|
||||
plutarchTests :: TestTree
|
||||
plutarchTests =
|
||||
testGroup "plutarchTests" $
|
||||
|
|
|
|||
|
|
@ -21,7 +21,6 @@ module Spec.Sample.Stake (
|
|||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch.Api.V1 (
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
|
|
@ -47,20 +46,30 @@ import Plutus.V1.Ledger.Api (
|
|||
import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
|
||||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Scripts (Validator)
|
||||
import Plutus.V1.Ledger.Value (TokenName (TokenName))
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName))
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.SafeMoney
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake
|
||||
import Plutarch.SafeMoney
|
||||
import Spec.Util (datumPair, toDatumHash)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | 'Stake' parameters for 'LQ'.
|
||||
stake :: Stake LQ
|
||||
stake = Stake
|
||||
stake :: Stake
|
||||
stake =
|
||||
Stake
|
||||
{ gtClassRef =
|
||||
Tagged
|
||||
( AssetClass
|
||||
( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
|
||||
, "LQ"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
-- | 'Stake' policy instance.
|
||||
policy :: MintingPolicy
|
||||
|
|
@ -86,7 +95,7 @@ stakeCreation :: ScriptContext
|
|||
stakeCreation =
|
||||
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
|
||||
datum :: Datum
|
||||
datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer)
|
||||
datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
|
|
@ -114,7 +123,7 @@ stakeCreation =
|
|||
stakeCreationWrongDatum :: ScriptContext
|
||||
stakeCreationWrongDatum =
|
||||
let datum :: Datum
|
||||
datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer) -- Too much GT
|
||||
datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
|
||||
, scriptContextPurpose = Minting policySymbol
|
||||
|
|
@ -135,9 +144,9 @@ stakeCreationUnsigned =
|
|||
|
||||
-- | Config for creating a ScriptContext that deposits or withdraws.
|
||||
data DepositWithdrawExample = DepositWithdrawExample
|
||||
{ startAmount :: Integer
|
||||
{ startAmount :: Tagged GTTag Integer
|
||||
-- ^ The amount of GT stored before the transaction.
|
||||
, delta :: Integer
|
||||
, delta :: Tagged GTTag Integer
|
||||
-- ^ The amount of GT deposited or withdrawn from the Stake.
|
||||
}
|
||||
|
||||
|
|
@ -146,7 +155,7 @@ stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
|
|||
stakeDepositWithdraw config =
|
||||
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
|
||||
stakeBefore :: StakeDatum
|
||||
stakeBefore = StakeDatum config.startAmount signer
|
||||
stakeBefore = StakeDatum config.startAmount signer []
|
||||
|
||||
stakeAfter :: StakeDatum
|
||||
stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}
|
||||
|
|
@ -160,10 +169,7 @@ stakeDepositWithdraw config =
|
|||
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
|
||||
, txOutValue =
|
||||
st
|
||||
<> Value.singleton
|
||||
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
|
||||
"LQ"
|
||||
stakeBefore.stakedAmount
|
||||
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
|
||||
, txOutDatumHash = Just (toDatumHash stakeAfter)
|
||||
}
|
||||
]
|
||||
|
|
@ -172,10 +178,7 @@ stakeDepositWithdraw config =
|
|||
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
|
||||
, txOutValue =
|
||||
st
|
||||
<> Value.singleton
|
||||
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
|
||||
"LQ"
|
||||
stakeAfter.stakedAmount
|
||||
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
|
||||
, txOutDatumHash = Just (toDatumHash stakeAfter)
|
||||
}
|
||||
]
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{- |
|
||||
Module : Spec.Stake
|
||||
Maintainer : emi@haskell.fyi
|
||||
|
|
@ -27,7 +29,7 @@ import Spec.Util (policyFailsWith, policySucceedsWith, toDatum, validatorFailsWi
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Stake tests
|
||||
-- | Stake tests.
|
||||
tests :: [TestTree]
|
||||
tests =
|
||||
[ testGroup
|
||||
|
|
@ -50,20 +52,20 @@ tests =
|
|||
, validatorSucceedsWith
|
||||
"stakeDepositWithdraw deposit"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer)
|
||||
(toDatum $ StakeDatum 100_000 signer [])
|
||||
(toDatum $ DepositWithdraw 100_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
|
||||
, validatorSucceedsWith
|
||||
"stakeDepositWithdraw withdraw"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer)
|
||||
(toDatum $ DepositWithdraw (negate 100_000))
|
||||
(toDatum $ StakeDatum 100_000 signer [])
|
||||
(toDatum $ DepositWithdraw $ negate 100_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
|
||||
, validatorFailsWith
|
||||
"stakeDepositWithdraw negative GT"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer)
|
||||
(toDatum $ DepositWithdraw (negate 1_000_000))
|
||||
(toDatum $ StakeDatum 100_000 signer [])
|
||||
(toDatum $ DepositWithdraw 1_000_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
|
||||
]
|
||||
]
|
||||
|
|
|
|||
11
agora.cabal
11
agora.cabal
|
|
@ -95,6 +95,9 @@ common deps
|
|||
, data-default-class
|
||||
, generics-sop
|
||||
, plutarch
|
||||
, plutarch-extra
|
||||
, plutarch-numeric
|
||||
, plutarch-safemoney
|
||||
, plutus-core
|
||||
, plutus-ledger-api
|
||||
, plutus-tx
|
||||
|
|
@ -107,6 +110,7 @@ common deps
|
|||
|
||||
common test-deps
|
||||
build-depends:
|
||||
, apropos
|
||||
, apropos-tx
|
||||
, QuickCheck
|
||||
, quickcheck-instances
|
||||
|
|
@ -120,16 +124,15 @@ library
|
|||
Agora.AuthorityToken
|
||||
Agora.MultiSig
|
||||
Agora.SafeMoney
|
||||
Agora.SafeMoney.QQ
|
||||
Agora.Stake
|
||||
Agora.Effect
|
||||
Agora.Treasury
|
||||
Agora.Voting
|
||||
Agora.Governor
|
||||
Agora.Proposal
|
||||
|
||||
other-modules:
|
||||
Agora.Utils
|
||||
Agora.Utils.Value
|
||||
Plutarch.Api.V1.These
|
||||
Plutarch.These
|
||||
|
||||
hs-source-dirs: agora
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ Tokens acting as redeemable proofs of DAO authority.
|
|||
module Agora.AuthorityToken (
|
||||
authorityTokenPolicy,
|
||||
authorityTokensValidIn,
|
||||
singleAuthorityTokenBurned,
|
||||
AuthorityToken (..),
|
||||
) where
|
||||
|
||||
|
|
@ -15,14 +16,14 @@ import Plutarch.Api.V1 (
|
|||
PAddress (..),
|
||||
PCredential (..),
|
||||
PCurrencySymbol (..),
|
||||
PMap (..),
|
||||
PScriptContext (..),
|
||||
PScriptPurpose (..),
|
||||
PTxInInfo (..),
|
||||
PTxInfo (..),
|
||||
PTxOut (..),
|
||||
PValue (..),
|
||||
)
|
||||
import Plutarch.Api.V1.AssocMap (PMap (PMap))
|
||||
import Plutarch.Api.V1.Value (PValue (PValue))
|
||||
import Plutarch.Builtin (pforgetData)
|
||||
import Plutarch.List (pfoldr')
|
||||
import Plutarch.Monadic qualified as P
|
||||
|
|
@ -32,7 +33,15 @@ import Prelude
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Utils (allOutputs, passert, passetClassValueOf, passetClassValueOf', plookup)
|
||||
import Agora.Utils (
|
||||
allInputs,
|
||||
allOutputs,
|
||||
passert,
|
||||
passetClassValueOf,
|
||||
passetClassValueOf',
|
||||
plookup,
|
||||
psymbolValueOf,
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -85,6 +94,27 @@ authorityTokensValidIn = phoistAcyclic $
|
|||
-- No GATs exist at this output!
|
||||
pconstant True
|
||||
|
||||
-- | Assert that a single authority token has been burned.
|
||||
singleAuthorityTokenBurned ::
|
||||
forall (s :: S).
|
||||
Term s PCurrencySymbol ->
|
||||
Term s (PAsData PTxInfo) ->
|
||||
Term s PValue ->
|
||||
Term s PBool
|
||||
singleAuthorityTokenBurned gatCs txInfo mint = P.do
|
||||
let gatAmountMinted :: Term _ PInteger
|
||||
gatAmountMinted = psymbolValueOf # gatCs # mint
|
||||
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "GAT not burned." $ gatAmountMinted #== -1
|
||||
, ptraceIfFalse "All inputs only have valid GATs" $
|
||||
allInputs @PUnit # pfromData txInfo #$ plam $ \txOut _value _address _datum ->
|
||||
authorityTokensValidIn
|
||||
# gatCs
|
||||
# txOut
|
||||
]
|
||||
|
||||
-- | Policy given 'AuthorityToken' params.
|
||||
authorityTokenPolicy ::
|
||||
AuthorityToken ->
|
||||
|
|
|
|||
65
agora/Agora/Effect.hs
Normal file
65
agora/Agora/Effect.hs
Normal file
|
|
@ -0,0 +1,65 @@
|
|||
{- |
|
||||
Module : Agora.Effect
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Helpers for constructing effects
|
||||
|
||||
Helpers for constructing effects.
|
||||
-}
|
||||
module Agora.Effect (
|
||||
makeEffect,
|
||||
noopEffect,
|
||||
) where
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.Utils (passert)
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutus.V1.Ledger.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.
|
||||
-}
|
||||
makeEffect ::
|
||||
forall (datum :: PType).
|
||||
PIsData datum =>
|
||||
CurrencySymbol ->
|
||||
(forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
|
||||
ClosedTerm PValidator
|
||||
makeEffect gatCs' f =
|
||||
plam $ \datum _redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
|
||||
-- TODO: Use PTryFrom
|
||||
let datum' :: Term _ datum
|
||||
datum' = pfromData $ punsafeCoerce datum
|
||||
|
||||
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
|
||||
txOutRef' <- plet (pfield @"_0" # txOutRef)
|
||||
|
||||
txInfo <- pletFields @'["mint"] txInfo'
|
||||
let mint :: Term _ PValue
|
||||
mint = txInfo.mint
|
||||
|
||||
gatCs <- plet $ pconstant gatCs'
|
||||
|
||||
passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
|
||||
|
||||
f gatCs datum' txOutRef' txInfo'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Dummy effect which can only burn its GAT.
|
||||
noopEffect :: CurrencySymbol -> ClosedTerm PValidator
|
||||
noopEffect =
|
||||
( `makeEffect`
|
||||
\_gatCs (_datum :: Term _ PUnit) _txOutRef _txInfo -> P.do
|
||||
popaque (pconstant ())
|
||||
)
|
||||
62
agora/Agora/Governor.hs
Normal file
62
agora/Agora/Governor.hs
Normal file
|
|
@ -0,0 +1,62 @@
|
|||
{- |
|
||||
Module : Agora.Governor
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Governor entity scripts acting as authority of entire system.
|
||||
|
||||
Governor entity scripts acting as authority of entire system.
|
||||
-}
|
||||
module Agora.Governor (
|
||||
-- * Haskell-land
|
||||
GovernorDatum (..),
|
||||
GovernorRedeemer (..),
|
||||
Governor (..),
|
||||
|
||||
-- * Plutarch-land
|
||||
|
||||
-- * Scripts
|
||||
governorPolicy,
|
||||
governorValidator,
|
||||
) where
|
||||
|
||||
import Agora.Proposal (ProposalTag, ProposalThresholds)
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Api.V1 (PMintingPolicy, PValidator)
|
||||
|
||||
-- | Datum for the Governor script.
|
||||
data GovernorDatum = GovernorDatum
|
||||
{ proposalThresholds :: ProposalThresholds
|
||||
-- ^ Gets copied over upon creation of a 'Agora.Proposal.ProposalDatum'.
|
||||
, nextProposalTag :: ProposalTag
|
||||
-- ^ What tag the next proposal will get upon creating.
|
||||
}
|
||||
|
||||
{- | Redeemer for Governor script. The governor has two primary
|
||||
responsibilities:
|
||||
|
||||
1. The gating of Proposal creation.
|
||||
2. The gating of minting authority tokens.
|
||||
-}
|
||||
data GovernorRedeemer
|
||||
= -- | Checks that a proposal was created lawfully, and allows it.
|
||||
CreateProposal
|
||||
| -- | Checks that a SINGLE proposal finished correctly,
|
||||
-- and allows minting GATs for each effect script.
|
||||
MintGATs
|
||||
|
||||
-- | Parameters for creating Governor scripts.
|
||||
data Governor
|
||||
= Governor
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Policy for Governors.
|
||||
governorPolicy :: Governor -> ClosedTerm PMintingPolicy
|
||||
governorPolicy _ =
|
||||
plam $ \_redeemer _ctx' -> P.do
|
||||
popaque (pconstant ())
|
||||
|
||||
-- | Validator for Governors.
|
||||
governorValidator :: Governor -> ClosedTerm PValidator
|
||||
governorValidator _ =
|
||||
plam $ \_datum _redeemer _ctx' -> P.do
|
||||
popaque (pconstant ())
|
||||
|
|
@ -77,13 +77,13 @@ deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstant Mul
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Check if a Haskell-level MultiSig signs this transaction
|
||||
-- | Check if a Haskell-level MultiSig signs this transaction.
|
||||
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.
|
||||
pvalidatedByMultisig :: Term s (PMultiSig :--> PTxInfo :--> PBool)
|
||||
pvalidatedByMultisig =
|
||||
phoistAcyclic $
|
||||
|
|
|
|||
282
agora/Agora/Proposal.hs
Normal file
282
agora/Agora/Proposal.hs
Normal file
|
|
@ -0,0 +1,282 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.Proposal
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Proposal scripts encoding effects that operate on the system.
|
||||
|
||||
Proposal scripts encoding effects that operate on the system.
|
||||
-}
|
||||
module Agora.Proposal (
|
||||
-- * Haskell-land
|
||||
Proposal (..),
|
||||
ProposalDatum (..),
|
||||
ProposalStatus (..),
|
||||
ProposalThresholds (..),
|
||||
ProposalVotes (..),
|
||||
ProposalTag (..),
|
||||
ResultTag (..),
|
||||
|
||||
-- * Plutarch-land
|
||||
PProposalDatum (..),
|
||||
PProposalStatus (..),
|
||||
PProposalThresholds (..),
|
||||
PProposalVotes (..),
|
||||
PProposalTag (..),
|
||||
PResultTag (..),
|
||||
|
||||
-- * Scripts
|
||||
proposalValidator,
|
||||
proposalPolicy,
|
||||
) where
|
||||
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Plutarch.Api.V1 (
|
||||
PDatumHash,
|
||||
PMap,
|
||||
PMintingPolicy,
|
||||
PPubKeyHash,
|
||||
PValidator,
|
||||
PValidatorHash,
|
||||
)
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
|
||||
import PlutusTx qualified
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..))
|
||||
import Plutarch.SafeMoney (PDiscrete, Tagged)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Haskell-land
|
||||
|
||||
{- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
|
||||
|
||||
@
|
||||
"No" ~ 'ResultTag' 0
|
||||
"Yes" ~ 'ResultTag' 1
|
||||
@
|
||||
-}
|
||||
newtype ResultTag = ResultTag {getResultTag :: Integer}
|
||||
deriving stock (Eq, Show, Ord)
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
|
||||
{- | The "status" of the proposal. This is only useful for state transitions,
|
||||
as opposed to time-based "phases".
|
||||
|
||||
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.
|
||||
-}
|
||||
data ProposalStatus
|
||||
= -- | A draft proposal represents a proposal that has yet to be realized.
|
||||
--
|
||||
-- In effect, this means one which didn't have enough LQ to be a full
|
||||
-- proposal, and needs cosigners to enable that to happen. This is
|
||||
-- similar to a "temperature check", but only useful if multiple people
|
||||
-- want to pool governance tokens together. If the proposal doesn't get to
|
||||
-- 'VotingReady' on time, the proposal will __never__ be able to get
|
||||
-- voted on.
|
||||
Draft
|
||||
| -- | The proposal has/had enough GT cosigned in order to be a fully fledged
|
||||
-- proposal.
|
||||
--
|
||||
-- This means that once the timing requirements align,
|
||||
-- proposal will be able to be voted on.
|
||||
VotingReady
|
||||
| -- | The proposal has finished.
|
||||
--
|
||||
-- This can mean it's been voted on and completed, but it can also mean
|
||||
-- the proposal failed due to time constraints or didn't
|
||||
-- get to 'VotingReady' first.
|
||||
--
|
||||
-- TODO: The owner of the proposal may choose to reclaim their proposal.
|
||||
Finished
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Finished, 2)]
|
||||
|
||||
{- | 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.
|
||||
-}
|
||||
data ProposalThresholds = ProposalThresholds
|
||||
{ execute :: Tagged GTTag Integer
|
||||
-- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass.
|
||||
, draft :: Tagged GTTag Integer
|
||||
-- ^ How much GT required to "create" a proposal.
|
||||
, vote :: Tagged GTTag Integer
|
||||
-- ^ How much GT required to allow voting to happen.
|
||||
-- (i.e. to move into 'VotingReady')
|
||||
}
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)]
|
||||
|
||||
{- | Map which encodes the total tally for each result.
|
||||
It's important that the "shape" is consistent with the shape of 'effects'.
|
||||
|
||||
e.g. if the 'effects' field looks like the following:
|
||||
|
||||
@[('ResultTag' 0, []), ('ResultTag' 1, [(vh, dh)])]@
|
||||
|
||||
Then 'ProposalVotes' needs be of the shape:
|
||||
|
||||
@[('ResultTag' 0, n), ('ResultTag' 1, m)]@
|
||||
-}
|
||||
newtype ProposalVotes = ProposalVotes
|
||||
{ getProposalVotes :: AssocMap.Map ResultTag Integer
|
||||
}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
-- | Haskell-level datum for Proposal scripts.
|
||||
data ProposalDatum = ProposalDatum
|
||||
{ -- TODO: could we encode this more efficiently?
|
||||
-- This is shaped this way for future proofing.
|
||||
-- See https://github.com/Liqwid-Labs/agora/issues/39
|
||||
effects :: [(ResultTag, [(ValidatorHash, DatumHash)])]
|
||||
-- ^ Effect lookup table. First by result, then by effect hash.
|
||||
, status :: ProposalStatus
|
||||
-- ^ The status the proposal is in.
|
||||
, cosigners :: [PubKeyHash]
|
||||
-- ^ Who created the proposal initially, and who cosigned it later.
|
||||
, thresholds :: ProposalThresholds
|
||||
-- ^ Thresholds copied over on initialization.
|
||||
, votes :: ProposalVotes
|
||||
-- ^ Vote tally on the proposal
|
||||
}
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
|
||||
|
||||
{- | Identifies a Proposal, issued upon creation of a proposal.
|
||||
In practice, this number starts at zero, and increments by one
|
||||
for each proposal. The 100th proposal will be @'ProposalTag' 99@.
|
||||
This counter lives in the 'Governor', see 'nextProposalTag'.
|
||||
-}
|
||||
newtype ProposalTag = ProposalTag {proposalTag :: Integer}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
-- | Parameters that identify the Proposal validator script.
|
||||
data Proposal = Proposal
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Plutarch-land
|
||||
|
||||
-- | Plutarch-level version of 'ResultTag'.
|
||||
newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PResultTag PInteger)
|
||||
|
||||
instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag
|
||||
deriving via
|
||||
(DerivePConstantViaNewtype ResultTag PResultTag PInteger)
|
||||
instance
|
||||
(PConstant ResultTag)
|
||||
|
||||
-- | Plutarch-level version of 'PProposalTag'.
|
||||
newtype PProposalTag (s :: S) = PProposalTag (Term s PInteger)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTag PInteger)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalTag where type PLifted PProposalTag = ProposalTag
|
||||
deriving via
|
||||
(DerivePConstantViaNewtype ProposalTag PProposalTag PInteger)
|
||||
instance
|
||||
(PConstant ProposalTag)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalStatus'.
|
||||
data PProposalStatus (s :: S)
|
||||
= -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'.
|
||||
-- e.g. like Tilde used 'pmatchEnum'.
|
||||
PDraft (Term s (PDataRecord '[]))
|
||||
| PVotingReady (Term s (PDataRecord '[]))
|
||||
| PFinished (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PProposalStatus
|
||||
|
||||
instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
|
||||
deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstant ProposalStatus)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalThresholds'.
|
||||
newtype PProposalThresholds (s :: S) = PProposalThresholds
|
||||
{ getProposalThresholds ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "execute" ':= PDiscrete GTTag
|
||||
, "draft" ':= PDiscrete GTTag
|
||||
, "vote" ':= PDiscrete GTTag
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalThresholds)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
|
||||
deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstant ProposalThresholds)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalVotes'.
|
||||
newtype PProposalVotes (s :: S)
|
||||
= PProposalVotes (Term s (PMap PResultTag PInteger))
|
||||
deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap PResultTag PInteger))
|
||||
|
||||
instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes
|
||||
deriving via
|
||||
(DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap PResultTag PInteger))
|
||||
instance
|
||||
(PConstant ProposalVotes)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalDatum'.
|
||||
newtype PProposalDatum (s :: S) = PProposalDatum
|
||||
{ getProposalDatum ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
|
||||
, "status" ':= PProposalStatus
|
||||
, "cosigners" ':= PBuiltinList PPubKeyHash
|
||||
, "thresholds" ':= PProposalThresholds
|
||||
, "votes" ':= PProposalVotes
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalDatum)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
|
||||
deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Policy for Proposals.
|
||||
proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
|
||||
proposalPolicy _ =
|
||||
plam $ \_redeemer _ctx' -> P.do
|
||||
popaque (pconstant ())
|
||||
|
||||
-- | Validator for Proposals.
|
||||
proposalValidator :: Proposal -> ClosedTerm PValidator
|
||||
proposalValidator _ =
|
||||
plam $ \_datum _redeemer _ctx' -> P.do
|
||||
popaque (pconstant ())
|
||||
|
|
@ -1,128 +1,33 @@
|
|||
{- |
|
||||
Module : Agora.SafeMoney
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Phantom-type protected types for handling money in Plutus.
|
||||
Description: Tags and bonuses for Plutarch.SafeMoney.
|
||||
|
||||
Phantom-type protected types for handling money in Plutus.
|
||||
Tags and extras for "Plutarch.SafeMoney".
|
||||
-}
|
||||
module Agora.SafeMoney (
|
||||
-- * Types
|
||||
MoneyClass,
|
||||
PDiscrete,
|
||||
|
||||
-- * Utility functions
|
||||
paddDiscrete,
|
||||
pgeqDiscrete,
|
||||
pzeroDiscrete,
|
||||
|
||||
-- * Conversions
|
||||
pdiscreteValue,
|
||||
pvalueDiscrete,
|
||||
|
||||
-- * Example MoneyClasses
|
||||
LQ,
|
||||
ADA,
|
||||
ADATag,
|
||||
GTTag,
|
||||
adaRef,
|
||||
) where
|
||||
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.String
|
||||
import GHC.TypeLits (
|
||||
KnownSymbol,
|
||||
Nat,
|
||||
Symbol,
|
||||
symbolVal,
|
||||
)
|
||||
import Prelude
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
|
||||
import Plutarch.SafeMoney
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Example tags
|
||||
|
||||
-- | Governance token.
|
||||
data GTTag
|
||||
|
||||
-- | ADA.
|
||||
data ADATag
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch.Api.V1 (PValue)
|
||||
import Plutarch.Builtin ()
|
||||
import Plutarch.Internal ()
|
||||
import Plutarch.Monadic qualified as P
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Utils (passetClassValueOf, psingletonValue)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Type-level unique identifier for an 'Plutus.V1.Ledger.Value.AssetClass'
|
||||
type MoneyClass =
|
||||
( -- AssetClass
|
||||
Symbol
|
||||
, -- TokenName
|
||||
Symbol
|
||||
, -- Decimal places
|
||||
Nat
|
||||
)
|
||||
|
||||
-- | A 'PDiscrete' amount of currency tagged on the type level with the 'MoneyClass' it belongs to
|
||||
newtype PDiscrete (mc :: MoneyClass) (s :: S)
|
||||
= PDiscrete (Term s PInteger)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete mc) PInteger)
|
||||
|
||||
-- | Check if one 'PDiscrete' is greater than another.
|
||||
pgeqDiscrete :: forall (mc :: MoneyClass) (s :: S). Term s (PDiscrete mc :--> PDiscrete mc :--> PBool)
|
||||
pgeqDiscrete = phoistAcyclic $
|
||||
plam $ \x y -> P.do
|
||||
PDiscrete x' <- pmatch x
|
||||
PDiscrete y' <- pmatch y
|
||||
y' #<= x'
|
||||
|
||||
-- | Returns a zero-value 'PDiscrete' unit for any 'MoneyClass'.
|
||||
pzeroDiscrete :: forall (mc :: MoneyClass) (s :: S). Term s (PDiscrete mc)
|
||||
pzeroDiscrete = phoistAcyclic $ pcon (PDiscrete 0)
|
||||
|
||||
-- | Add two 'PDiscrete' values of the same 'MoneyClass'.
|
||||
paddDiscrete :: Term s (PDiscrete mc :--> PDiscrete mc :--> PDiscrete mc)
|
||||
paddDiscrete = phoistAcyclic $
|
||||
-- In the future, this should use plutarch-numeric
|
||||
plam $ \x y -> P.do
|
||||
PDiscrete x' <- pmatch x
|
||||
PDiscrete y' <- pmatch y
|
||||
pcon (PDiscrete $ x' + y')
|
||||
|
||||
-- | The MoneyClass of LQ.
|
||||
type LQ :: MoneyClass
|
||||
type LQ = '("da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24", "LQ", 6)
|
||||
|
||||
-- | The MoneyClass of ADA.
|
||||
type ADA :: MoneyClass
|
||||
type ADA = '("", "", 6)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Downcast a `PValue` to a `PDiscrete` unit.
|
||||
pvalueDiscrete ::
|
||||
forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s.
|
||||
( KnownSymbol ac
|
||||
, KnownSymbol n
|
||||
, moneyClass ~ '(ac, n, scale)
|
||||
) =>
|
||||
Term s (PValue :--> PDiscrete moneyClass)
|
||||
pvalueDiscrete = phoistAcyclic $
|
||||
plam $ \f ->
|
||||
pcon . PDiscrete $
|
||||
passetClassValueOf # pconstant (fromString $ symbolVal $ Proxy @ac)
|
||||
# pconstant (fromString $ symbolVal $ Proxy @n)
|
||||
# f
|
||||
|
||||
{- | Get a `PValue` from a `PDiscrete`.
|
||||
__NOTE__: `pdiscreteValue` after `pvalueDiscrete` is not a round-trip.
|
||||
It filters for a particular 'MoneyClass'.
|
||||
-}
|
||||
pdiscreteValue ::
|
||||
forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s.
|
||||
( KnownSymbol ac
|
||||
, KnownSymbol n
|
||||
, moneyClass ~ '(ac, n, scale)
|
||||
) =>
|
||||
Term s (PDiscrete moneyClass :--> PValue)
|
||||
pdiscreteValue = phoistAcyclic $
|
||||
plam $ \f -> pmatch f $ \case
|
||||
PDiscrete p ->
|
||||
psingletonValue
|
||||
# pconstant (fromString $ symbolVal $ Proxy @ac)
|
||||
# pconstant (fromString $ symbolVal $ Proxy @n)
|
||||
# p
|
||||
-- | Resolves ada tags.
|
||||
adaRef :: Tagged ADATag AssetClass
|
||||
adaRef = Tagged (AssetClass ("", ""))
|
||||
|
|
|
|||
|
|
@ -1,96 +0,0 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.SafeMoney.QQ
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Quasiquoter for SafeMoney types.
|
||||
|
||||
Quasiquoter for SafeMoney types.
|
||||
-}
|
||||
module Agora.SafeMoney.QQ (discrete) where
|
||||
|
||||
import GHC.Real (Ratio ((:%)))
|
||||
import Language.Haskell.TH qualified as TH (Type)
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))
|
||||
import Language.Haskell.TH.Syntax (
|
||||
Dec (TySynD),
|
||||
Exp (AppE, AppTypeE, LitE, VarE),
|
||||
Info (TyConI),
|
||||
Lit (IntegerL),
|
||||
Pat,
|
||||
Q,
|
||||
TyLit (NumTyLit, StrTyLit),
|
||||
Type (AppT, ConT, LitT, PromotedTupleT),
|
||||
lookupTypeName,
|
||||
reify,
|
||||
)
|
||||
import Text.ParserCombinators.ReadP (readP_to_S, skipSpaces)
|
||||
import Text.Read (lexP, readPrec_to_P)
|
||||
import Text.Read.Lex (Lexeme (Ident, Number), Number, numberToFixed, numberToRational)
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
|
||||
import Agora.SafeMoney (MoneyClass, PDiscrete)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Generate 'PDiscrete' values tagged by a particular MoneyClass
|
||||
|
||||
@
|
||||
[discrete| 123.456 'Agora.SafeMoney.ADA' |] :: 'Term' s ('PDiscrete' 'Agora.SafeMoney.ADA')
|
||||
@
|
||||
-}
|
||||
discrete :: QuasiQuoter
|
||||
discrete = QuasiQuoter discreteExp errorDiscretePat errorDiscreteType errorDiscreteDiscretelaration
|
||||
|
||||
discreteConstant :: forall (moneyClass :: MoneyClass) s. Integer -> Term s (PDiscrete moneyClass)
|
||||
discreteConstant n = punsafeCoerce (pconstant n :: Term s PInteger)
|
||||
|
||||
fixedToInteger :: Integer -> (Integer, Integer) -> Integer
|
||||
fixedToInteger places (i, f) = i * 10 ^ places + f
|
||||
|
||||
safeIntegerUpcast :: Integer -> Number -> Either String Integer
|
||||
safeIntegerUpcast places num =
|
||||
case (numberToFixed places num, numberToRational num * 10 ^ places) of
|
||||
(Just (i, f), _n :% 1) ->
|
||||
Right $ fixedToInteger places (i, f)
|
||||
(Just (i, f), _n :% _d) ->
|
||||
Left $ "Using more than the available decimal places (" <> show places <> "). Would round to " <> show i <> "." <> show f
|
||||
_ -> Left "Some error occurred while getting number"
|
||||
|
||||
discreteExp :: String -> Q Exp
|
||||
discreteExp s = case parseDiscreteRatioExp s of
|
||||
Nothing ->
|
||||
fail $ "Input malformed. Got: " <> s
|
||||
Just (num, mc) -> do
|
||||
mcName <-
|
||||
lookupTypeName mc >>= \case
|
||||
Nothing -> fail $ "MoneyClass with the name " <> show mc <> " is not in scope."
|
||||
Just v -> pure v
|
||||
reified <- reify mcName
|
||||
case reified of
|
||||
TyConI (TySynD tyName [] (AppT (AppT (AppT (PromotedTupleT 3) (LitT (StrTyLit _))) (LitT _)) (LitT (NumTyLit n)))) ->
|
||||
case safeIntegerUpcast n num of
|
||||
Right i ->
|
||||
pure $ AppE (AppTypeE (VarE 'discreteConstant) (ConT tyName)) (LitE (IntegerL i))
|
||||
Left e -> fail e
|
||||
ty' -> fail $ "Could not reify type, got: " <> show ty'
|
||||
|
||||
parseDiscreteRatioExp :: String -> Maybe (Number, String)
|
||||
parseDiscreteRatioExp s =
|
||||
let p = skipSpaces *> ((,) <$> readPrec_to_P lexP 0 <* skipSpaces <*> readPrec_to_P lexP 0) <* skipSpaces
|
||||
in case readP_to_S p s of
|
||||
[((Number n, Ident i), "")] -> Just (n, i)
|
||||
_ -> Nothing
|
||||
|
||||
errorDiscretePat :: String -> Q Pat
|
||||
errorDiscretePat _ = fail "Cannot use 'discrete' in a pattern context."
|
||||
|
||||
errorDiscreteType :: String -> Q TH.Type
|
||||
errorDiscreteType _ = fail "Cannot use 'discrete' in a type context."
|
||||
|
||||
errorDiscreteDiscretelaration :: String -> Q [Dec]
|
||||
errorDiscreteDiscretelaration _ = fail "Cannot use 'discrete' in a declaration context."
|
||||
|
|
@ -12,6 +12,8 @@ module Agora.Stake (
|
|||
PStakeRedeemer (..),
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (..),
|
||||
ProposalLock (..),
|
||||
PProposalLock (..),
|
||||
Stake (..),
|
||||
stakePolicy,
|
||||
stakeValidator,
|
||||
|
|
@ -20,15 +22,9 @@ module Agora.Stake (
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.String (IsString (fromString))
|
||||
import GHC.Generics qualified as GHC
|
||||
import GHC.TypeLits (
|
||||
KnownSymbol,
|
||||
symbolVal,
|
||||
)
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Prelude
|
||||
import Prelude hiding (Num (..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -49,23 +45,19 @@ import Plutarch.Api.V1 (
|
|||
mkMintingPolicy,
|
||||
)
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (..))
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.SafeMoney (
|
||||
MoneyClass,
|
||||
PDiscrete,
|
||||
paddDiscrete,
|
||||
pdiscreteValue,
|
||||
pgeqDiscrete,
|
||||
pzeroDiscrete,
|
||||
)
|
||||
import Agora.Proposal (PProposalTag, PResultTag, ProposalTag (..), ResultTag (..))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Utils (
|
||||
anyInput,
|
||||
anyOutput,
|
||||
|
|
@ -75,67 +67,174 @@ import Agora.Utils (
|
|||
pgeqByClass,
|
||||
pgeqByClass',
|
||||
pgeqBySymbol,
|
||||
pnotNull,
|
||||
psingletonValue,
|
||||
psymbolValueOf,
|
||||
ptxSignedBy,
|
||||
pvalueSpent,
|
||||
)
|
||||
import Plutarch.Numeric
|
||||
import Plutarch.SafeMoney (
|
||||
PDiscrete,
|
||||
Tagged (..),
|
||||
pdiscreteValue,
|
||||
untag,
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Parameters for creating Stake scripts.
|
||||
data Stake (gt :: MoneyClass) = Stake
|
||||
newtype Stake = Stake
|
||||
{ gtClassRef :: Tagged GTTag AssetClass
|
||||
-- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
|
||||
}
|
||||
|
||||
-- | Plutarch-level redeemer for Stake scripts.
|
||||
data PStakeRedeemer (gt :: MoneyClass) (s :: S)
|
||||
= -- | Deposit or withdraw a discrete amount of the staked governance token.
|
||||
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete gt]))
|
||||
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
|
||||
PDestroy (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances (PStakeRedeemer gt)
|
||||
{- | A lock placed on a Stake datum in order to prevent
|
||||
depositing and withdrawing when votes are in place.
|
||||
|
||||
-- FIXME: 'StakeRedeemer' and 'StakeDatum' are stripped of their
|
||||
-- typesafe `PDiscrete` equivalent due to issues with `makeIsDataIndexed`
|
||||
-- when using the kind @gt :: MoneyClass@. This ought to be fixed with
|
||||
-- a future patch in Plutarch upstream. For now, we will deal with lower
|
||||
-- type safety off-chain.
|
||||
NOTE: Due to retracting votes always being possible,
|
||||
this lock will only lock with contention on the proposal.
|
||||
|
||||
FIXME: Contention on Proposals could create contention
|
||||
on voting which in turn creates contention on stakers.
|
||||
|
||||
Vaguely this is the dependency graph for this locking
|
||||
interaction. Both the stake validator and the proposal
|
||||
validator are only able to check for one another through
|
||||
the datum belonging to the ST:
|
||||
|
||||
@
|
||||
┌─────────────────┐ ┌────────────────────┐
|
||||
│ Stake Validator ├─┐ │ Proposal Validator │
|
||||
└────────┬────────┘ │ └──────┬─────┬───────┘
|
||||
│ │ │ │
|
||||
│ ┌─┼────────┘ │
|
||||
▼ │ │ ▼
|
||||
┌──────────────┐ │ │ ┌─────────────────┐
|
||||
│ Stake Policy │◄─┘ └►│ Proposal Policy │
|
||||
└──────────────┘ └─────────────────┘
|
||||
@
|
||||
-}
|
||||
data ProposalLock = ProposalLock
|
||||
{ vote :: ResultTag
|
||||
-- ^ What was voted on. This allows retracting votes to
|
||||
-- undo their vote.
|
||||
, proposalTag :: ProposalTag
|
||||
-- ^ Identifies the proposal. See 'ProposalTag' for further
|
||||
-- comments on its significance.
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalLock [('ProposalLock, 0)]
|
||||
|
||||
-- | Haskell-level redeemer for Stake scripts.
|
||||
data StakeRedeemer
|
||||
= -- | Deposit or withdraw a discrete amount of the staked governance token.
|
||||
DepositWithdraw Integer
|
||||
-- Stake must be unlocked.
|
||||
DepositWithdraw (Tagged GTTag Integer)
|
||||
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
|
||||
-- Stake must be unlocked.
|
||||
Destroy
|
||||
| -- | Permit a Vote to be added onto a 'Proposal'.
|
||||
-- This also adds a lock to the 'lockedBy' field. See 'ProposalLock'.
|
||||
-- This needs to be done in sync with casting a vote, otherwise
|
||||
-- it's possible for a lock to be permanently placed on the stake,
|
||||
-- and then the funds are lost.
|
||||
PermitVote ProposalLock
|
||||
| -- | Retract a vote, removing it from the 'lockedBy' field. See 'ProposalLock'.
|
||||
-- This action checks for permission of the 'Proposal'. Finished proposals are
|
||||
-- always allowed to have votes retracted and won't affect the Proposal datum,
|
||||
-- allowing 'Stake's to be unlocked.
|
||||
RetractVotes [ProposalLock]
|
||||
deriving stock (Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)]
|
||||
PlutusTx.makeIsDataIndexed
|
||||
''StakeRedeemer
|
||||
[ ('DepositWithdraw, 0)
|
||||
, ('Destroy, 1)
|
||||
, ('PermitVote, 2)
|
||||
, ('RetractVotes, 3)
|
||||
]
|
||||
|
||||
-- | Haskell-level datum for Stake scripts.
|
||||
data StakeDatum = StakeDatum
|
||||
{ stakedAmount :: Tagged GTTag Integer
|
||||
-- ^ Tracks the amount of governance token staked in the datum.
|
||||
-- This also acts as the voting weight for 'Proposal's.
|
||||
, owner :: PubKeyHash
|
||||
-- ^ The hash of the public key this stake belongs to.
|
||||
--
|
||||
-- TODO Support for MultiSig/Scripts is tracked here:
|
||||
-- https://github.com/Liqwid-Labs/agora/issues/45
|
||||
, lockedBy :: [ProposalLock]
|
||||
-- ^ The current proposals locking this stake. This field must be empty
|
||||
-- for the stake to be usable for deposits and withdrawals.
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Plutarch-level datum for Stake scripts.
|
||||
newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum
|
||||
newtype PStakeDatum (s :: S) = PStakeDatum
|
||||
{ getStakeDatum ::
|
||||
Term s (PDataRecord '["stakedAmount" ':= PDiscrete gt, "owner" ':= PPubKeyHash])
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "stakedAmount" ':= PDiscrete GTTag
|
||||
, "owner" ':= PPubKeyHash
|
||||
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances (PStakeDatum gt))
|
||||
via (PIsDataReprInstances PStakeDatum)
|
||||
|
||||
-- | Haskell-level datum for Stake scripts.
|
||||
data StakeDatum = StakeDatum
|
||||
{ -- FIXME: This needs to be gt
|
||||
stakedAmount :: Integer
|
||||
, owner :: PubKeyHash
|
||||
instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
|
||||
deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum)
|
||||
|
||||
-- | Plutarch-level redeemer for Stake scripts.
|
||||
data PStakeRedeemer (s :: S)
|
||||
= -- | Deposit or withdraw a discrete amount of the staked governance token.
|
||||
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
|
||||
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
|
||||
PDestroy (Term s (PDataRecord '[]))
|
||||
| PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock]))
|
||||
| PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList PProposalLock]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PStakeRedeemer
|
||||
|
||||
instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
|
||||
deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer)
|
||||
|
||||
newtype PProposalLock (s :: S) = PProposalLock
|
||||
{ getProposalLock ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "vote" ':= PResultTag
|
||||
, "proposalTag" ':= PProposalTag
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalLock)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
|
||||
instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock
|
||||
deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
{- What this Policy does
|
||||
|
|
@ -153,15 +252,8 @@ PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Policy for Stake state threads.
|
||||
stakePolicy ::
|
||||
forall (gt :: MoneyClass) ac n scale s.
|
||||
( KnownSymbol ac
|
||||
, KnownSymbol n
|
||||
, gt ~ '(ac, n, scale)
|
||||
) =>
|
||||
Stake gt ->
|
||||
Term s PMintingPolicy
|
||||
stakePolicy _stake =
|
||||
stakePolicy :: Stake -> ClosedTerm PMintingPolicy
|
||||
stakePolicy stake =
|
||||
plam $ \_redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
|
|
@ -180,7 +272,7 @@ stakePolicy _stake =
|
|||
mintedST #== -1
|
||||
|
||||
passert "An unlocked input existed containing an ST" $
|
||||
anyInput @(PStakeDatum gt) # pfromData txInfo'
|
||||
anyInput @PStakeDatum # pfromData txInfo'
|
||||
#$ plam
|
||||
$ \value _ stakeDatum' -> P.do
|
||||
let hasST = psymbolValueOf # ownSymbol # value #== 1
|
||||
|
|
@ -197,7 +289,7 @@ stakePolicy _stake =
|
|||
mintedST #== 1
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @(PStakeDatum gt) # pfromData txInfo'
|
||||
anyOutput @PStakeDatum # pfromData txInfo'
|
||||
#$ plam
|
||||
$ \value address stakeDatum' -> P.do
|
||||
let cred = pfield @"credential" # address
|
||||
|
|
@ -220,7 +312,7 @@ stakePolicy _stake =
|
|||
# 1
|
||||
let expectedValue =
|
||||
paddValue
|
||||
# (pdiscreteValue # stakeDatum.stakedAmount)
|
||||
# (pdiscreteValue stake.gtClassRef # stakeDatum.stakedAmount)
|
||||
# stValue
|
||||
let ownerSignsTransaction =
|
||||
ptxSignedBy
|
||||
|
|
@ -234,12 +326,7 @@ stakePolicy _stake =
|
|||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass'
|
||||
( AssetClass
|
||||
( fromString . symbolVal $ Proxy @ac
|
||||
, fromString . symbolVal $ Proxy @n
|
||||
)
|
||||
)
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqByClass
|
||||
|
|
@ -258,24 +345,17 @@ stakePolicy _stake =
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Validator intended for Stake UTXOs to live in.
|
||||
stakeValidator ::
|
||||
forall (gt :: MoneyClass) ac n scale s.
|
||||
( KnownSymbol ac
|
||||
, KnownSymbol n
|
||||
, gt ~ '(ac, n, scale)
|
||||
) =>
|
||||
Stake gt ->
|
||||
Term s PValidator
|
||||
stakeValidator :: Stake -> ClosedTerm PValidator
|
||||
stakeValidator stake =
|
||||
plam $ \datum redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'
|
||||
|
||||
-- Coercion is safe in that if coercion fails we crash hard.
|
||||
let stakeRedeemer :: Term _ (PStakeRedeemer gt)
|
||||
-- TODO: Use PTryFrom
|
||||
let stakeRedeemer :: Term _ PStakeRedeemer
|
||||
stakeRedeemer = pfromData $ punsafeCoerce redeemer
|
||||
stakeDatum' :: Term _ (PStakeDatum gt)
|
||||
stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
|
||||
|
|
@ -284,33 +364,53 @@ stakeValidator stake =
|
|||
PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfo'
|
||||
ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo
|
||||
let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
|
||||
|
||||
-- Whether the owner signs this transaction or not.
|
||||
ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner
|
||||
|
||||
stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake)
|
||||
mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfo.mint
|
||||
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfo'
|
||||
|
||||
-- Is the stake currently locked?
|
||||
stakeIsLocked <- plet $ stakeLocked # stakeDatum'
|
||||
|
||||
pmatch stakeRedeemer $ \case
|
||||
PDestroy _ -> P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
passert "Should burn ST" $
|
||||
mintedST #== -1
|
||||
passert "Stake unlocked" $
|
||||
pnot #$ stakeLocked # stakeDatum'
|
||||
passert "Stake unlocked" $ pnot # stakeIsLocked
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PRetractVotes _ -> P.do
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
-- TODO: check proposal constraints
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PPermitVote _ -> P.do
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
-- TODO: check proposal constraints
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PDepositWithdraw r -> P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
passert "Stake unlocked" $
|
||||
pnot #$ stakeLocked # stakeDatum'
|
||||
pnot #$ stakeIsLocked
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @(PStakeDatum gt) # txInfo'
|
||||
anyOutput @PStakeDatum # txInfo'
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum'
|
||||
|
|
@ -320,12 +420,12 @@ stakeValidator stake =
|
|||
foldr1
|
||||
(#&&)
|
||||
[ stakeDatum.owner #== newStakeDatum.owner
|
||||
, (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount
|
||||
, (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount
|
||||
, -- We can't magically conjure GT anyway (no input to spend!)
|
||||
-- do we need to check this, really?
|
||||
pgeqDiscrete # (pfromData newStakeDatum.stakedAmount) # pzeroDiscrete
|
||||
zero #<= pfromData newStakeDatum.stakedAmount
|
||||
]
|
||||
let expectedValue = paddValue # continuingValue # (pdiscreteValue # delta)
|
||||
let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta)
|
||||
|
||||
-- TODO: Same as above. This is quite inefficient now, as it does two lookups
|
||||
-- instead of a more efficient single pass,
|
||||
|
|
@ -334,12 +434,7 @@ stakeValidator stake =
|
|||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass'
|
||||
( AssetClass
|
||||
( fromString . symbolVal $ Proxy @ac
|
||||
, fromString . symbolVal $ Proxy @n
|
||||
)
|
||||
)
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqBySymbol
|
||||
|
|
@ -360,8 +455,9 @@ stakeValidator stake =
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Check whether a Stake is locked. If it is locked, various actions are unavailable.
|
||||
stakeLocked :: forall (gt :: MoneyClass) s. Term s (PStakeDatum gt :--> PBool)
|
||||
stakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
|
||||
stakeLocked = phoistAcyclic $
|
||||
plam $ \_stakeDatum ->
|
||||
-- TODO: when we extend this to support proposals, this will need to do something
|
||||
pcon PFalse
|
||||
plam $ \stakeDatum ->
|
||||
let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
|
||||
locks = pfield @"lockedBy" # stakeDatum
|
||||
in pnotNull # locks
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ module Agora.Treasury (module Agora.Treasury) where
|
|||
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP
|
||||
import Plutarch.Api.V1.Contexts (PScriptContext, PScriptPurpose (PMinting))
|
||||
import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
|
||||
import Plutarch.Api.V1.Value (PCurrencySymbol, PValue)
|
||||
import Plutarch.DataRepr (
|
||||
PDataFields,
|
||||
|
|
@ -21,23 +21,25 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.AuthorityToken (authorityTokensValidIn)
|
||||
import Agora.Utils (allInputs, passert, psymbolValueOf)
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.Utils (passert)
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Api.V1 (PValidator)
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
|
||||
{- | Validator ensuring that transactions consuming the treasury
|
||||
do so in a valid manner.
|
||||
-}
|
||||
treasuryV ::
|
||||
forall {s :: S}.
|
||||
treasuryValidator ::
|
||||
CurrencySymbol ->
|
||||
Term
|
||||
s
|
||||
( PAsData PTreasuryDatum
|
||||
:--> PAsData PTreasuryRedeemer
|
||||
:--> PAsData PScriptContext
|
||||
:--> PUnit
|
||||
)
|
||||
treasuryV cs = plam $ \_d r ctx' -> P.do
|
||||
ClosedTerm PValidator
|
||||
treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
|
||||
-- TODO: Use PTryFrom
|
||||
let treasuryRedeemer :: Term _ (PAsData PTreasuryRedeemer)
|
||||
treasuryRedeemer = punsafeCoerce redeemer
|
||||
_treasuryDatum' :: Term _ (PAsData PTreasuryDatum)
|
||||
_treasuryDatum' = punsafeCoerce datum
|
||||
|
||||
-- plet required fields from script context.
|
||||
ctx <- pletFields @["txInfo", "purpose"] ctx'
|
||||
|
||||
|
|
@ -45,25 +47,19 @@ treasuryV cs = plam $ \_d r ctx' -> P.do
|
|||
PMinting _ <- pmatch ctx.purpose
|
||||
|
||||
-- Ensure redeemer type is valid.
|
||||
PAlterTreasuryParams _ <- pmatch $ pfromData r
|
||||
PAlterTreasuryParams _ <- pmatch $ pfromData treasuryRedeemer
|
||||
|
||||
-- Get the minted value from txInfo.
|
||||
txInfo' <- plet ctx.txInfo
|
||||
txInfo <- pletFields @'["mint"] txInfo'
|
||||
let mint :: Term s PValue
|
||||
let mint :: Term _ PValue
|
||||
mint = txInfo.mint
|
||||
gatAmountMinted :: Term s PInteger
|
||||
gatAmountMinted = psymbolValueOf # pconstant cs # mint
|
||||
|
||||
passert "GAT not burned." $ gatAmountMinted #== -1
|
||||
gatCs <- plet $ pconstant gatCs'
|
||||
|
||||
passert "All inputs only have valid GATs" $
|
||||
allInputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
|
||||
authorityTokensValidIn
|
||||
# pconstant cs
|
||||
# txOut
|
||||
passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
|
||||
|
||||
pconstant ()
|
||||
popaque $ pconstant ()
|
||||
|
||||
{- | Plutarch level type representing datum of the treasury.
|
||||
Contains:
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ module Agora.Utils (
|
|||
pfindTxInByTxOutRef,
|
||||
psingletonValue,
|
||||
pfindMap,
|
||||
pnotNull,
|
||||
|
||||
-- * Functions which should (probably) not be upstreamed
|
||||
anyOutput,
|
||||
|
|
@ -44,7 +45,6 @@ import Plutarch.Api.V1 (
|
|||
PCurrencySymbol,
|
||||
PDatum,
|
||||
PDatumHash,
|
||||
PMap (PMap),
|
||||
PMaybeData (PDJust),
|
||||
PPubKeyHash,
|
||||
PTokenName,
|
||||
|
|
@ -53,8 +53,9 @@ import Plutarch.Api.V1 (
|
|||
PTxInfo (PTxInfo),
|
||||
PTxOut (PTxOut),
|
||||
PTxOutRef,
|
||||
PValue (PValue),
|
||||
)
|
||||
import Plutarch.Api.V1.AssocMap (PMap (PMap))
|
||||
import Plutarch.Api.V1.Value (PValue (PValue))
|
||||
import Plutarch.Builtin (ppairDataBuiltin)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Monadic qualified as P
|
||||
|
|
@ -183,21 +184,21 @@ passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger)
|
|||
passetClassValueOf' (AssetClass (sym, token)) =
|
||||
passetClassValueOf # pconstant sym # pconstant token
|
||||
|
||||
-- | Return '>=' on two values comparing by only a particular AssetClass
|
||||
-- | Return '>=' on two values comparing by only a particular AssetClass.
|
||||
pgeqByClass :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool)
|
||||
pgeqByClass =
|
||||
phoistAcyclic $
|
||||
plam $ \cs tn a b ->
|
||||
passetClassValueOf # cs # tn # b #<= passetClassValueOf # cs # tn # a
|
||||
|
||||
-- | Return '>=' on two values comparing by only a particular CurrencySymbol
|
||||
-- | Return '>=' on two values comparing by only a particular CurrencySymbol.
|
||||
pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool)
|
||||
pgeqBySymbol =
|
||||
phoistAcyclic $
|
||||
plam $ \cs a b ->
|
||||
psymbolValueOf # cs # b #<= psymbolValueOf # cs # a
|
||||
|
||||
-- | Return '>=' on two values comparing by only a particular Haskell-level AssetClass
|
||||
-- | Return '>=' on two values comparing by only a particular Haskell-level AssetClass.
|
||||
pgeqByClass' :: AssetClass -> Term s (PValue :--> PValue :--> PBool)
|
||||
pgeqByClass' ac =
|
||||
phoistAcyclic $
|
||||
|
|
@ -233,7 +234,7 @@ pmapUnionWith = phoistAcyclic $
|
|||
# ys
|
||||
pcon (PMap $ pconcat # ls # rs)
|
||||
|
||||
-- | Add two 'PValue's together
|
||||
-- | Add two 'PValue's together.
|
||||
paddValue :: forall s. Term s (PValue :--> PValue :--> PValue)
|
||||
paddValue = phoistAcyclic $
|
||||
plam $ \a' b' -> P.do
|
||||
|
|
@ -281,6 +282,10 @@ pfindTxInByTxOutRef = phoistAcyclic $
|
|||
)
|
||||
#$ (pfield @"inputs" # txInfo)
|
||||
|
||||
-- | True if a list is not empty.
|
||||
pnotNull :: forall list a. PIsListLike list a => Term _ (list a :--> PBool)
|
||||
pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
{- Functions which should (probably) not be upstreamed
|
||||
All of these functions are quite inefficient.
|
||||
|
|
|
|||
|
|
@ -1,11 +0,0 @@
|
|||
{- |
|
||||
Module : Agora.Voting
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Types for votes and vote counting
|
||||
-}
|
||||
module Agora.Voting (
|
||||
Vote (..),
|
||||
) where
|
||||
|
||||
-- | Type representing direction of vote.
|
||||
data Vote = InFavorOf | OpposedTo
|
||||
|
|
@ -11,7 +11,8 @@ module PPrelude (
|
|||
module Plutarch,
|
||||
) where
|
||||
|
||||
-- These are not exported by Plutarch.Prelude, for some reason. Maybe we can 'fix' this upstream?
|
||||
import Plutarch (ClosedTerm, compile)
|
||||
-- NOTE: These are not exported by Plutarch.Prelude, for some reason.
|
||||
-- Maybe we can 'fix' this upstream?
|
||||
import Plutarch (ClosedTerm, POpaque, compile)
|
||||
import Plutarch.Prelude
|
||||
import Prelude
|
||||
|
|
|
|||
|
|
@ -1,62 +0,0 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Plutarch.Api.V1.These (PTheseData (..)) where
|
||||
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP
|
||||
import Plutarch.DataRepr (PIsDataReprInstances (PIsDataReprInstances))
|
||||
import Plutarch.Lift (
|
||||
PConstantRepr,
|
||||
PConstanted,
|
||||
PLifted,
|
||||
PUnsafeLiftDecl,
|
||||
pconstantFromRepr,
|
||||
pconstantToRepr,
|
||||
)
|
||||
import Plutus.V1.Ledger.Api qualified as Plutus
|
||||
import PlutusTx.These qualified as PlutusThese
|
||||
|
||||
data PTheseData (a :: PType) (b :: PType) (s :: S)
|
||||
= PDThis (Term s (PDataRecord '["_0" ':= a]))
|
||||
| PDThat (Term s (PDataRecord '["_0" ':= b]))
|
||||
| PDThese (Term s (PDataRecord '["_0" ':= a, "_1" ':= b]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic, PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances (PTheseData a b)
|
||||
|
||||
instance
|
||||
( Plutus.ToData (PLifted a)
|
||||
, Plutus.ToData (PLifted b)
|
||||
, Plutus.FromData (PLifted a)
|
||||
, Plutus.FromData (PLifted b)
|
||||
, PLift a
|
||||
, PLift b
|
||||
) =>
|
||||
PUnsafeLiftDecl (PTheseData a b)
|
||||
where
|
||||
type PLifted (PTheseData a b) = PlutusThese.These (PLifted a) (PLifted b)
|
||||
|
||||
{- TODO: Make PTheseData an instance of PConstant:
|
||||
https://github.com/Plutonomicon/plutarch/pull/355
|
||||
-}
|
||||
|
||||
instance
|
||||
( PLifted (PConstanted a) ~ a
|
||||
, Plutus.ToData b
|
||||
, Plutus.FromData b
|
||||
, Plutus.ToData a
|
||||
, Plutus.FromData a
|
||||
, PConstant a
|
||||
, PLifted (PConstanted b) ~ b
|
||||
, Plutus.FromData b
|
||||
, Plutus.ToData b
|
||||
, PConstant b
|
||||
) =>
|
||||
PConstant (PlutusThese.These a b)
|
||||
where
|
||||
type PConstantRepr (PlutusThese.These a b) = [(Plutus.Data, Plutus.Data)]
|
||||
type PConstanted (PlutusThese.These a b) = PTheseData (PConstanted a) (PConstanted b)
|
||||
pconstantToRepr _t = undefined
|
||||
pconstantFromRepr _t = undefined
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
module Plutarch.These (PThese (..)) where
|
||||
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP
|
||||
|
||||
-- | Plutus These type with Scott-encoded representation.
|
||||
data PThese (a :: PType) (b :: PType) (s :: S)
|
||||
= PThis (Term s a)
|
||||
| PThat (Term s b)
|
||||
| PThese (Term s a) (Term s b)
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic, PlutusType)
|
||||
6
docs/diagrams/UsingAgora.dot
Normal file
6
docs/diagrams/UsingAgora.dot
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
digraph {
|
||||
rankdir=LR
|
||||
Users -> Proposals [label="vote on"]
|
||||
Proposals -> Effects [label="have one or many"]
|
||||
Effects -> Components [label="alter"]
|
||||
}
|
||||
57
docs/diagrams/UsingAgora.svg
Normal file
57
docs/diagrams/UsingAgora.svg
Normal file
|
|
@ -0,0 +1,57 @@
|
|||
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
|
||||
<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"
|
||||
"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
|
||||
<!-- Generated by graphviz version 2.49.3 (0)
|
||||
-->
|
||||
<!-- Pages: 1 -->
|
||||
<svg width="742pt" height="44pt"
|
||||
viewBox="0.00 0.00 742.06 44.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
|
||||
<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 40)">
|
||||
<polygon fill="white" stroke="transparent" points="-4,4 -4,-40 738.06,-40 738.06,4 -4,4"/>
|
||||
<!-- Users -->
|
||||
<g id="node1" class="node">
|
||||
<title>Users</title>
|
||||
<ellipse fill="none" stroke="black" cx="38.35" cy="-18" rx="38.19" ry="18"/>
|
||||
<text text-anchor="middle" x="38.35" y="-14.3" font-family="Times,serif" font-size="14.00">Users</text>
|
||||
</g>
|
||||
<!-- Proposals -->
|
||||
<g id="node2" class="node">
|
||||
<title>Proposals</title>
|
||||
<ellipse fill="none" stroke="black" cx="221.59" cy="-18" rx="55.79" ry="18"/>
|
||||
<text text-anchor="middle" x="221.59" y="-14.3" font-family="Times,serif" font-size="14.00">Proposals</text>
|
||||
</g>
|
||||
<!-- Users->Proposals -->
|
||||
<g id="edge1" class="edge">
|
||||
<title>Users->Proposals</title>
|
||||
<path fill="none" stroke="black" d="M76.9,-18C99.51,-18 128.92,-18 155.24,-18"/>
|
||||
<polygon fill="black" stroke="black" points="155.54,-21.5 165.54,-18 155.54,-14.5 155.54,-21.5"/>
|
||||
<text text-anchor="middle" x="121.19" y="-21.8" font-family="Times,serif" font-size="14.00">vote on</text>
|
||||
</g>
|
||||
<!-- Effects -->
|
||||
<g id="node3" class="node">
|
||||
<title>Effects</title>
|
||||
<ellipse fill="none" stroke="black" cx="483.38" cy="-18" rx="42.79" ry="18"/>
|
||||
<text text-anchor="middle" x="483.38" y="-14.3" font-family="Times,serif" font-size="14.00">Effects</text>
|
||||
</g>
|
||||
<!-- Proposals->Effects -->
|
||||
<g id="edge2" class="edge">
|
||||
<title>Proposals->Effects</title>
|
||||
<path fill="none" stroke="black" d="M277.68,-18C322.64,-18 385.72,-18 429.94,-18"/>
|
||||
<polygon fill="black" stroke="black" points="430.19,-21.5 440.19,-18 430.19,-14.5 430.19,-21.5"/>
|
||||
<text text-anchor="middle" x="358.98" y="-21.8" font-family="Times,serif" font-size="14.00">have one or many</text>
|
||||
</g>
|
||||
<!-- Components -->
|
||||
<g id="node4" class="node">
|
||||
<title>Components</title>
|
||||
<ellipse fill="none" stroke="black" cx="665.17" cy="-18" rx="68.79" ry="18"/>
|
||||
<text text-anchor="middle" x="665.17" y="-14.3" font-family="Times,serif" font-size="14.00">Components</text>
|
||||
</g>
|
||||
<!-- Effects->Components -->
|
||||
<g id="edge3" class="edge">
|
||||
<title>Effects->Components</title>
|
||||
<path fill="none" stroke="black" d="M526.53,-18C544.29,-18 565.55,-18 585.99,-18"/>
|
||||
<polygon fill="black" stroke="black" points="586.25,-21.5 596.25,-18 586.25,-14.5 586.25,-21.5"/>
|
||||
<text text-anchor="middle" x="561.28" y="-21.8" font-family="Times,serif" font-size="14.00">alter</text>
|
||||
</g>
|
||||
</g>
|
||||
</svg>
|
||||
|
After Width: | Height: | Size: 2.7 KiB |
46
docs/using-agora.md
Normal file
46
docs/using-agora.md
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
# Using Agora
|
||||
|
||||
## Motivation
|
||||
|
||||
If you are building a project on Cardano that involves decentralized interaction between users you may want to create a DAO ([Decentralized Autonomous Organization](https://www.wikiwand.com/en/Decentralized_autonomous_organization)).
|
||||
|
||||
A DAO will allow users to come to a consensus on a variety of matters relevant to your project. These could include: managing of treasury assets, changing of protocol parameters, replacing of scripts, deprecation of the protocol in favour of a new version, emergency actions to protect users, and so forth. In order to do this on-chain, users will have to be able to express their opinion contractually, and only those with a vested interest ought to be able to interact with relevant proposals. This should ensure that voters have the best interests of the protocol at-heart. Governance systems can take varied forms, and not all of them will be suitable for your project.
|
||||
|
||||
Building such a system is a complex process and requires a lot of care; ensuring fairness (with regard to user interactions), efficiency (with regard to contention and throughput) and simplicity (with regard to script size and transaction costs). Agora is a curated set of scripts, types and design patterns that are designed from the ground-up to solve this problem in a way that is flexible enough to suit essentially any protocol.
|
||||
|
||||
### A quick note on terms
|
||||
|
||||
This article will include common English words that have specific meanings in Agora. To help you disambiguate, here are some definitions:
|
||||
|
||||
- proposal: A collection of changes to the protocol, which are voted on as a block.
|
||||
- effect: An on-chain representation of a proposed change to the protocol. A 'proposal' will hold references to one or many 'effects'. If an effect's proposal is passed by the community, effects are granted special 'authority tokens' which permit them to enact their encoded changes to the relevant protocol components.
|
||||
|
||||
|
||||
|
||||
## Agora and your protocol
|
||||
|
||||
Agora’s staking model relies on the existence of a governance token. In a sense, this governance token _parameterizes_ the entire system. Agora staking pools will lock users' governance tokens in order to permit them to vote. Agora's components are free-standing and don't _require_ a protocol acting in a particular way in order to function. One could for instance technically create a DAO that works with ADA as its governance token. The tokenomics of your governance token will of course influence the way voting power is distributed, due to the nature of token-based voting.
|
||||
|
||||
In order to set-up your protocol’s DAO actions, all affected components of your protocol will need to interpret the burning of an _authority token_ as a licence to alter _any_ aspect of that component.
|
||||
|
||||
To put this in slightly more concrete terms: for any datum which holds a subset of your protocol's parameters, there _should_ exist a redeemer for that datum and validation for this datum/redeemer pair should do _no more_ than verify that one of these authority tokens has been burned. Without this flexibility, the effects of Agora's proposals would be markedly less powerful.
|
||||
|
||||
### Writing effects
|
||||
|
||||
One writes a proposal effect, as one would write any Plutus script with the caveat that the effect script will only be permitted to run _once_.
|
||||
|
||||
Consider an example NFT project, wherein the minting of each NFT is a community action. For this scenario, one would require a template `MintNFT` effect, which mints its corresponding NFT upon the passing of the relevant proposal. The proposal being passed will issue an authority token to the effect. Each NFT's policy will verify that such an authority token was burned upon minting, which demonstrates that the minting of the NFT was indeed authorized by the DAO.
|
||||
|
||||
Making your protocol's components aware of authority tokens, and implementing relevant effects are the only two chores of using Agora in practice. The former is the only one that involves adapting your own scripts. Effect scripts can be written after your protocol and its governance have deployed, provided that the authority tokens are respected by the components.
|
||||
|
||||
## What Agora leaves up to you
|
||||
|
||||
Agora’s concern is the on-chain components and scripts. Any front-ends are the concern of the protocol's developers. In the best case, our documentation and program design will inspire you in developing a front-end solution. There is scope for Agora containing some off-chain functionality in-future. This would allow the user to create and experiment with transactions.
|
||||
|
||||
It’s worth noting that, while the actual functionality of the _front-ends_ is not a concern, creating standards for off-chain metadata _is_. For example, metadata tagging proposal descriptions, tags, dates. These are all important features that Agora aims to standardize, in hopes of facilitating interoperability between various instances of Agora. This effort is similar to [CIP-25](https://cips.cardano.org/cips/cip25/), which aims to standardize metadata for NFTs.
|
||||
|
||||
You're welcome to write any new effects you require for your protocol. If you believe any effects you write are sufficiently general and could serve as a benefit to our community, we would encourage you to up-stream them. Guidelines for doing so may be found in our [contribution guide](/CONTRIBUTING.md). Agora provides a number of effects out-of-the-box and intends to add more with time.
|
||||
|
||||
## What to do if something is missing
|
||||
|
||||
In the event Agora does not provide for one of your use cases, feel free to raise an issue and we can begin a discussion on implementing the desired functionality. Our [contribution guide](/CONTRIBUTING.md) has guidelines for registering issues.
|
||||
481
flake.lock
generated
481
flake.lock
generated
|
|
@ -32,6 +32,22 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"HTTP_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1451647621,
|
||||
"narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=",
|
||||
"owner": "phadej",
|
||||
"repo": "HTTP",
|
||||
"rev": "9bc0996d412fef1787449d841277ef663ad9a915",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "phadej",
|
||||
"repo": "HTTP",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"Shrinker": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -48,7 +64,7 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"apropos-tx": {
|
||||
"apropos": {
|
||||
"inputs": {
|
||||
"flake-compat": "flake-compat",
|
||||
"flake-compat-ci": "flake-compat-ci",
|
||||
|
|
@ -57,21 +73,47 @@
|
|||
"plutarch",
|
||||
"haskell-nix",
|
||||
"nixpkgs-unstable"
|
||||
],
|
||||
"plutus": "plutus"
|
||||
]
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1646436508,
|
||||
"narHash": "sha256-4QevdgeSSHfOyJEqdiNx6SovGpLZv1vw9i6r0XbpQ3U=",
|
||||
"lastModified": 1648746740,
|
||||
"narHash": "sha256-C2gQrd5hFvQ+BsjAJs6V0iP9PRzd9dZMKtpk7kOjhwc=",
|
||||
"owner": "mlabs-haskell",
|
||||
"repo": "apropos-tx",
|
||||
"rev": "5b74ba897a6f02718c163bf588a08c5e3e9de204",
|
||||
"repo": "apropos",
|
||||
"rev": "3734bb3baa297ed990725a5ef14efcbb6a1c1c23",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "mlabs-haskell",
|
||||
"repo": "apropos",
|
||||
"rev": "3734bb3baa297ed990725a5ef14efcbb6a1c1c23",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"apropos-tx": {
|
||||
"inputs": {
|
||||
"flake-compat": "flake-compat_2",
|
||||
"flake-compat-ci": "flake-compat-ci_2",
|
||||
"haskell-nix": "haskell-nix_2",
|
||||
"nixpkgs": [
|
||||
"plutarch",
|
||||
"haskell-nix",
|
||||
"nixpkgs-unstable"
|
||||
],
|
||||
"plutus": "plutus"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1648805998,
|
||||
"narHash": "sha256-TWEiUifHkhgCHqe70aNn9j6LdFFWv2nMbSWV8hR59oE=",
|
||||
"owner": "jhodgdev",
|
||||
"repo": "apropos-tx",
|
||||
"rev": "5b74ba897a6f02718c163bf588a08c5e3e9de204",
|
||||
"rev": "4eca3fac23c339caee04ea6176e641a4b3857a25",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "jhodgdev",
|
||||
"repo": "apropos-tx",
|
||||
"rev": "4eca3fac23c339caee04ea6176e641a4b3857a25",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
|
|
@ -126,6 +168,23 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-32_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1603716527,
|
||||
"narHash": "sha256-sDbrmur9Zfp4mPKohCD8IDZfXJ0Tjxpmr2R+kg5PpSY=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "94aaa8e4720081f9c75497e2735b90f6a819b08e",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "3.2",
|
||||
"repo": "cabal",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-34": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -160,6 +219,23 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-34_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1622475795,
|
||||
"narHash": "sha256-chwTL304Cav+7p38d9mcb+egABWmxo2Aq+xgVBgEb/U=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "b086c1995cdd616fc8d91f46a21e905cc50a1049",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "3.4",
|
||||
"repo": "cabal",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-36": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -308,6 +384,22 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cardano-shell_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1608537748,
|
||||
"narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "cardano-shell",
|
||||
"rev": "9392c75087cb9a3d453998f4230930dea3a95725",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "cardano-shell",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cryptonite": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -371,6 +463,21 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flake-compat-ci_3": {
|
||||
"locked": {
|
||||
"lastModified": 1641672839,
|
||||
"narHash": "sha256-Bdwv+DKeEMlRNPDpZxSz0sSrqQBvdKO5fZ8LmvrgCOU=",
|
||||
"owner": "hercules-ci",
|
||||
"repo": "flake-compat-ci",
|
||||
"rev": "e832114bc18376c0f3fa13c19bf5ff253cc6570a",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "hercules-ci",
|
||||
"repo": "flake-compat-ci",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flake-compat_2": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -388,6 +495,22 @@
|
|||
}
|
||||
},
|
||||
"flake-compat_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1641205782,
|
||||
"narHash": "sha256-4jY7RCWUoZ9cKD8co0/4tFARpWB+57+r1bLLvXNJliY=",
|
||||
"owner": "edolstra",
|
||||
"repo": "flake-compat",
|
||||
"rev": "b7547d3eed6f32d06102ead8991ec52ab0a4f1a7",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "edolstra",
|
||||
"repo": "flake-compat",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flake-compat_4": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1606424373,
|
||||
|
|
@ -404,7 +527,7 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flake-compat_4": {
|
||||
"flake-compat_5": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1606424373,
|
||||
|
|
@ -450,6 +573,21 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flake-utils_3": {
|
||||
"locked": {
|
||||
"lastModified": 1623875721,
|
||||
"narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "f7e004a55b120c02ecb6219596820fcd32ca8772",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flat": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -518,6 +656,23 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"ghc-8.6.5-iohk_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1600920045,
|
||||
"narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "ghc",
|
||||
"rev": "95713a6ecce4551240da7c96b6176f980af75cae",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"ref": "release/8.6.5-iohk",
|
||||
"repo": "ghc",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"gitignore-nix": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -569,11 +724,11 @@
|
|||
"hackage-nix": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1644369434,
|
||||
"narHash": "sha256-WqU6f1OhSM0UHXFW8Mhhvhz0tcij+NQVtmb6sW4RiFw=",
|
||||
"lastModified": 1637291070,
|
||||
"narHash": "sha256-hTX2Xo36i9MR6PNwA/89C8daKjxmx5ZS5lwR2Cbp8Yo=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "hackage.nix",
|
||||
"rev": "644a0d702abf84cdec62f4e620ff1034000e6146",
|
||||
"rev": "6ea4ad5f4a5e2303cd64974329ba90ccc410a012",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -599,6 +754,22 @@
|
|||
}
|
||||
},
|
||||
"hackage_2": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1639357972,
|
||||
"narHash": "sha256-NvVn00YOYZMqDUSiBbghJk/rm/nJItBEUJulWRGTgvk=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "hackage.nix",
|
||||
"rev": "54adf6e47e20831d9c49a2b62e12f7f218fd7752",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "hackage.nix",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"hackage_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1642554756,
|
||||
|
|
@ -617,16 +788,16 @@
|
|||
"haskell-language-server": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1643835246,
|
||||
"narHash": "sha256-5LQHcQmi3mUGRgJu+X/m3jeM3kdkYjLD+KwgnxBlbeU=",
|
||||
"lastModified": 1638136578,
|
||||
"narHash": "sha256-Reo9BQ12O+OX7tuRfaDPZPBpJW4jnxZetm63BxYncoM=",
|
||||
"owner": "haskell",
|
||||
"repo": "haskell-language-server",
|
||||
"rev": "024ddc8b3904f8b8e8fe67ba6b9ebd8a4bd7ce76",
|
||||
"rev": "745ef26f406dbdd5e4a538585f8519af9f1ccb09",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "1.6.1.1",
|
||||
"ref": "1.5.1",
|
||||
"repo": "haskell-language-server",
|
||||
"type": "github"
|
||||
}
|
||||
|
|
@ -677,7 +848,7 @@
|
|||
"hpc-coveralls": "hpc-coveralls",
|
||||
"nix-tools": "nix-tools",
|
||||
"nixpkgs": [
|
||||
"apropos-tx",
|
||||
"apropos",
|
||||
"haskell-nix",
|
||||
"nixpkgs-2105"
|
||||
],
|
||||
|
|
@ -703,13 +874,34 @@
|
|||
}
|
||||
},
|
||||
"haskell-nix_2": {
|
||||
"flake": false,
|
||||
"inputs": {
|
||||
"HTTP": "HTTP_2",
|
||||
"cabal-32": "cabal-32_2",
|
||||
"cabal-34": "cabal-34_2",
|
||||
"cardano-shell": "cardano-shell_2",
|
||||
"flake-utils": "flake-utils_2",
|
||||
"ghc-8.6.5-iohk": "ghc-8.6.5-iohk_2",
|
||||
"hackage": "hackage_2",
|
||||
"hpc-coveralls": "hpc-coveralls_2",
|
||||
"nix-tools": "nix-tools_2",
|
||||
"nixpkgs": [
|
||||
"apropos-tx",
|
||||
"haskell-nix",
|
||||
"nixpkgs-2105"
|
||||
],
|
||||
"nixpkgs-2003": "nixpkgs-2003_2",
|
||||
"nixpkgs-2105": "nixpkgs-2105_2",
|
||||
"nixpkgs-2111": "nixpkgs-2111_2",
|
||||
"nixpkgs-unstable": "nixpkgs-unstable_2",
|
||||
"old-ghc-nix": "old-ghc-nix_2",
|
||||
"stackage": "stackage_2"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1646278384,
|
||||
"narHash": "sha256-Gv1Ws3vAojjvjATcsvwAOTuOhzpxwt6tBci7EBaXxU4=",
|
||||
"lastModified": 1639371915,
|
||||
"narHash": "sha256-i5kW3hPptzXwzkpI2FAkfdDA/9QEDl/9mrwwoeBxDJg=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"rev": "7e06e14ae1b894445254fe41288bfa7dd4ccbc6f",
|
||||
"rev": "e95a1f0dacbc64603c31d11e36e4ba1af8f0eb43",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -719,26 +911,42 @@
|
|||
}
|
||||
},
|
||||
"haskell-nix_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1629380841,
|
||||
"narHash": "sha256-gWOWCfX7IgVSvMMYN6rBGK6EA0pk6pmYguXzMvGte+Q=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"rev": "7215f083b37741446aa325b20c8ba9f9f76015eb",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"haskell-nix_4": {
|
||||
"inputs": {
|
||||
"HTTP": "HTTP_2",
|
||||
"cabal-32": "cabal-32_2",
|
||||
"cabal-34": "cabal-34_2",
|
||||
"HTTP": "HTTP_3",
|
||||
"cabal-32": "cabal-32_3",
|
||||
"cabal-34": "cabal-34_3",
|
||||
"cabal-36": "cabal-36_2",
|
||||
"cardano-shell": "cardano-shell_2",
|
||||
"flake-utils": "flake-utils_2",
|
||||
"ghc-8.6.5-iohk": "ghc-8.6.5-iohk_2",
|
||||
"hackage": "hackage_2",
|
||||
"hpc-coveralls": "hpc-coveralls_2",
|
||||
"nix-tools": "nix-tools_2",
|
||||
"cardano-shell": "cardano-shell_3",
|
||||
"flake-utils": "flake-utils_3",
|
||||
"ghc-8.6.5-iohk": "ghc-8.6.5-iohk_3",
|
||||
"hackage": "hackage_3",
|
||||
"hpc-coveralls": "hpc-coveralls_3",
|
||||
"nix-tools": "nix-tools_3",
|
||||
"nixpkgs": [
|
||||
"nixpkgs-2111"
|
||||
],
|
||||
"nixpkgs-2003": "nixpkgs-2003_2",
|
||||
"nixpkgs-2105": "nixpkgs-2105_2",
|
||||
"nixpkgs-2111": "nixpkgs-2111_3",
|
||||
"nixpkgs-unstable": "nixpkgs-unstable_2",
|
||||
"old-ghc-nix": "old-ghc-nix_2",
|
||||
"stackage": "stackage_2"
|
||||
"nixpkgs-2003": "nixpkgs-2003_3",
|
||||
"nixpkgs-2105": "nixpkgs-2105_3",
|
||||
"nixpkgs-2111": "nixpkgs-2111_4",
|
||||
"nixpkgs-unstable": "nixpkgs-unstable_3",
|
||||
"old-ghc-nix": "old-ghc-nix_3",
|
||||
"stackage": "stackage_3"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1642811877,
|
||||
|
|
@ -755,7 +963,7 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"haskell-nix_4": {
|
||||
"haskell-nix_5": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1629380841,
|
||||
|
|
@ -773,7 +981,7 @@
|
|||
},
|
||||
"hercules-ci-agent": {
|
||||
"inputs": {
|
||||
"flake-compat": "flake-compat_4",
|
||||
"flake-compat": "flake-compat_5",
|
||||
"nix-darwin": "nix-darwin",
|
||||
"nixos-20_09": "nixos-20_09",
|
||||
"nixos-unstable": "nixos-unstable",
|
||||
|
|
@ -796,7 +1004,7 @@
|
|||
},
|
||||
"hercules-ci-effects": {
|
||||
"inputs": {
|
||||
"flake-compat": "flake-compat_3",
|
||||
"flake-compat": "flake-compat_4",
|
||||
"hercules-ci-agent": "hercules-ci-agent",
|
||||
"nixpkgs": "nixpkgs_3",
|
||||
"nixpkgs-nixops": "nixpkgs-nixops"
|
||||
|
|
@ -847,6 +1055,22 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"hpc-coveralls_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1607498076,
|
||||
"narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=",
|
||||
"owner": "sevanspowell",
|
||||
"repo": "hpc-coveralls",
|
||||
"rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "sevanspowell",
|
||||
"repo": "hpc-coveralls",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"hs-memory": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -883,11 +1107,11 @@
|
|||
"iohk-nix_2": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1646330344,
|
||||
"narHash": "sha256-EbhMDeneH26wDi+x5kz8nfru/dE9JZ241hJed4a8lz8=",
|
||||
"lastModified": 1648032999,
|
||||
"narHash": "sha256-3uCz+gJppvM7z6CUCkBbFSu60WgIE+e3oXwXiAiGWSY=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "iohk-nix",
|
||||
"rev": "0a0126d8fb1bdc61ce1fd2ef61cf396de800fdad",
|
||||
"rev": "5e667b374153327c7bdfdbfab8ef19b1f27d4aac",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -962,6 +1186,22 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nix-tools_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1636018067,
|
||||
"narHash": "sha256-ng306fkuwr6V/malWtt3979iAC4yMVDDH2ViwYB6sQE=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "nix-tools",
|
||||
"rev": "ed5bd7215292deba55d6ab7a4e8c21f8b1564dda",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "nix-tools",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixos-20_09": {
|
||||
"locked": {
|
||||
"lastModified": 1623585158,
|
||||
|
|
@ -997,11 +1237,11 @@
|
|||
"nixpkgs": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1645493675,
|
||||
"narHash": "sha256-9xundbZQbhFodsQRh6QMN1GeSXfo3y/5NL0CZcJULz0=",
|
||||
"lastModified": 1628785280,
|
||||
"narHash": "sha256-2B5eMrEr6O8ff2aQNeVxTB+9WrGE80OB4+oM6T7fOcc=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "74b10859829153d5c5d50f7c77b86763759e8654",
|
||||
"rev": "6525bbc06a39f26750ad8ee0d40000ddfdc24acb",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -1043,6 +1283,22 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-2003_3": {
|
||||
"locked": {
|
||||
"lastModified": 1620055814,
|
||||
"narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-20.03-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-2105": {
|
||||
"locked": {
|
||||
"lastModified": 1642244250,
|
||||
|
|
@ -1060,6 +1316,22 @@
|
|||
}
|
||||
},
|
||||
"nixpkgs-2105_2": {
|
||||
"locked": {
|
||||
"lastModified": 1639202042,
|
||||
"narHash": "sha256-xEMgCsIcDUQ0kw9xvqU0wObns580kpdcr1ACz83+gHs=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "499ca2a9f6463ce119e40361f4329afa921a1d13",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-21.05-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-2105_3": {
|
||||
"locked": {
|
||||
"lastModified": 1640283157,
|
||||
"narHash": "sha256-6Ddfop+rKE+Gl9Tjp9YIrkfoYPzb8F80ergdjcq3/MY=",
|
||||
|
|
@ -1093,11 +1365,11 @@
|
|||
},
|
||||
"nixpkgs-2111_2": {
|
||||
"locked": {
|
||||
"lastModified": 1646844010,
|
||||
"narHash": "sha256-NRDLmpjmBMNBRr/BiztSsGht5wJYl8WZFzj+b+6LhLk=",
|
||||
"lastModified": 1639213685,
|
||||
"narHash": "sha256-Evuobw7o9uVjAZuwz06Al0fOWZ5JMKOktgXR0XgWBtg=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "d59edd3833597be12763f1f017c7ad666cf1b810",
|
||||
"rev": "453bcb8380fd1777348245b3c44ce2a2b93b2e2d",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -1108,6 +1380,22 @@
|
|||
}
|
||||
},
|
||||
"nixpkgs-2111_3": {
|
||||
"locked": {
|
||||
"lastModified": 1648744337,
|
||||
"narHash": "sha256-bYe1dFJAXovjqiaPKrmAbSBEK5KUkgwVaZcTbSoJ7hg=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "0a58eebd8ec65ffdef2ce9562784123a73922052",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-21.11-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-2111_4": {
|
||||
"locked": {
|
||||
"lastModified": 1640283207,
|
||||
"narHash": "sha256-SCwl7ZnCfMDsuSYvwIroiAlk7n33bW8HFfY8NvKhcPA=",
|
||||
|
|
@ -1123,6 +1411,22 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-2111_5": {
|
||||
"locked": {
|
||||
"lastModified": 1644510859,
|
||||
"narHash": "sha256-xjpVvL5ecbyi0vxtVl/Fh9bwGlMbw3S06zE5nUzFB8A=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "0d1d5d7e3679fec9d07f2eb804d9f9fdb98378d3",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-21.11-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-nixops": {
|
||||
"locked": {
|
||||
"lastModified": 1630248577,
|
||||
|
|
@ -1156,6 +1460,22 @@
|
|||
}
|
||||
},
|
||||
"nixpkgs-unstable_2": {
|
||||
"locked": {
|
||||
"lastModified": 1639239143,
|
||||
"narHash": "sha256-9fFMUs6m3/4ZMflSqRgO4iEkBtFBnDyLWa3AB2tOvfs=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "e6df26a654b7fdd59a068c57001eab5736b1363c",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-unstable",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-unstable_3": {
|
||||
"locked": {
|
||||
"lastModified": 1641285291,
|
||||
"narHash": "sha256-KYaOBNGar3XWTxTsYPr9P6u74KAqNq0wobEC236U+0c=",
|
||||
|
|
@ -1252,6 +1572,23 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"old-ghc-nix_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1631092763,
|
||||
"narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=",
|
||||
"owner": "angerman",
|
||||
"repo": "old-ghc-nix",
|
||||
"rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "angerman",
|
||||
"ref": "master",
|
||||
"repo": "old-ghc-nix",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"plutarch": {
|
||||
"inputs": {
|
||||
"Shrinker": "Shrinker",
|
||||
|
|
@ -1260,12 +1597,12 @@
|
|||
"cardano-crypto": "cardano-crypto",
|
||||
"cardano-prelude": "cardano-prelude",
|
||||
"cryptonite": "cryptonite",
|
||||
"flake-compat": "flake-compat_2",
|
||||
"flake-compat-ci": "flake-compat-ci_2",
|
||||
"flake-compat": "flake-compat_3",
|
||||
"flake-compat-ci": "flake-compat-ci_3",
|
||||
"flat": "flat",
|
||||
"foundation": "foundation",
|
||||
"haskell-language-server": "haskell-language-server_2",
|
||||
"haskell-nix": "haskell-nix_3",
|
||||
"haskell-nix": "haskell-nix_4",
|
||||
"hercules-ci-effects": "hercules-ci-effects",
|
||||
"hs-memory": "hs-memory",
|
||||
"iohk-nix": "iohk-nix_2",
|
||||
|
|
@ -1274,6 +1611,7 @@
|
|||
"haskell-nix",
|
||||
"nixpkgs-unstable"
|
||||
],
|
||||
"nixpkgs-2111": "nixpkgs-2111_5",
|
||||
"plutus": "plutus_2",
|
||||
"protolude": "protolude",
|
||||
"safe-coloured-text": "safe-coloured-text",
|
||||
|
|
@ -1283,17 +1621,17 @@
|
|||
"validity": "validity"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1646941827,
|
||||
"narHash": "sha256-/TmkSDVOYD0Nsf6/tsyCSWhFUIeefwPn0Lz1oeZ7lyQ=",
|
||||
"owner": "Plutonomicon",
|
||||
"lastModified": 1648639396,
|
||||
"narHash": "sha256-pAkEsIDXJckVYufVPUzD/4sq4/uE7iyV0IR2BuLhZjY=",
|
||||
"owner": "peter-mlabs",
|
||||
"repo": "plutarch",
|
||||
"rev": "cb29ca64df4ed193d94a062e3fe26aa37e59b7bc",
|
||||
"rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "Plutonomicon",
|
||||
"owner": "peter-mlabs",
|
||||
"repo": "plutarch",
|
||||
"rev": "cb29ca64df4ed193d94a062e3fe26aa37e59b7bc",
|
||||
"rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
|
|
@ -1303,7 +1641,7 @@
|
|||
"gitignore-nix": "gitignore-nix",
|
||||
"hackage-nix": "hackage-nix",
|
||||
"haskell-language-server": "haskell-language-server",
|
||||
"haskell-nix": "haskell-nix_2",
|
||||
"haskell-nix": "haskell-nix_3",
|
||||
"iohk-nix": "iohk-nix",
|
||||
"nixpkgs": "nixpkgs",
|
||||
"pre-commit-hooks-nix": "pre-commit-hooks-nix",
|
||||
|
|
@ -1311,11 +1649,11 @@
|
|||
"stackage-nix": "stackage-nix"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1646401716,
|
||||
"narHash": "sha256-Xh4m6NVgxhtJZPW+/TH0KncginXLORO6EAN/ulitlrw=",
|
||||
"lastModified": 1639153959,
|
||||
"narHash": "sha256-tz8wEV5oO2yu2WFl3+wAPHedJJUP/NMFYgfcsbcyji4=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "plutus",
|
||||
"rev": "73e4bbfc32ea233ba679d3f558a95adf8513a9d7",
|
||||
"rev": "da4f85cdd2a3a261ce540e8dc51d2a3c5fa89ed2",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -1330,7 +1668,7 @@
|
|||
"gitignore-nix": "gitignore-nix_2",
|
||||
"hackage-nix": "hackage-nix_2",
|
||||
"haskell-language-server": "haskell-language-server_3",
|
||||
"haskell-nix": "haskell-nix_4",
|
||||
"haskell-nix": "haskell-nix_5",
|
||||
"iohk-nix": "iohk-nix_3",
|
||||
"nixpkgs": "nixpkgs_4",
|
||||
"pre-commit-hooks-nix": "pre-commit-hooks-nix_3",
|
||||
|
|
@ -1419,6 +1757,7 @@
|
|||
},
|
||||
"root": {
|
||||
"inputs": {
|
||||
"apropos": "apropos",
|
||||
"apropos-tx": "apropos-tx",
|
||||
"haskell-nix": [
|
||||
"plutarch",
|
||||
|
|
@ -1428,7 +1767,7 @@
|
|||
"plutarch",
|
||||
"nixpkgs"
|
||||
],
|
||||
"nixpkgs-2111": "nixpkgs-2111_2",
|
||||
"nixpkgs-2111": "nixpkgs-2111_3",
|
||||
"plutarch": "plutarch"
|
||||
}
|
||||
},
|
||||
|
|
@ -1547,6 +1886,22 @@
|
|||
}
|
||||
},
|
||||
"stackage_2": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1639185224,
|
||||
"narHash": "sha256-ZBL0Lvqq8/Iwl8F5sT2N9J8+HTh0OY+09LkkUVtuUtY=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "stackage.nix",
|
||||
"rev": "14819f5c85a92e5fb6e322cc809c803fa6419bd4",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "stackage.nix",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"stackage_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1642468901,
|
||||
|
|
|
|||
71
flake.nix
71
flake.nix
|
|
@ -3,22 +3,30 @@
|
|||
|
||||
inputs.nixpkgs.follows = "plutarch/nixpkgs";
|
||||
inputs.haskell-nix.follows = "plutarch/haskell-nix";
|
||||
|
||||
# https://github.com/mlabs-haskell/apropos-tx/pull/28
|
||||
inputs.apropos-tx.url =
|
||||
"github:mlabs-haskell/apropos-tx?rev=5b74ba897a6f02718c163bf588a08c5e3e9de204";
|
||||
inputs.apropos-tx.inputs.nixpkgs.follows =
|
||||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
|
||||
# temporary fix for nix versions that have the transitive follows bug
|
||||
# see https://github.com/NixOS/nix/issues/6013
|
||||
inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };
|
||||
|
||||
# Rev is this PR https://github.com/peter-mlabs/plutarch/pull/5.
|
||||
inputs.plutarch.url =
|
||||
"github:Plutonomicon/plutarch?rev=cb29ca64df4ed193d94a062e3fe26aa37e59b7bc";
|
||||
"github:peter-mlabs/plutarch?rev=a7a410da209b9c14c834a41e07b1c197c2a4dcd6";
|
||||
inputs.plutarch.inputs.nixpkgs.follows =
|
||||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
|
||||
# Follows jhodgdev's forks of apropos and apropos-tx, as these
|
||||
# are not constrained to `base ^>= 4.14`. Once these are merged
|
||||
# to their respective master branches, we should change the
|
||||
# inputs to follow a commit on those master branches. For more
|
||||
# info, see: https://github.com/mlabs-haskell/apropos-tx/pull/37
|
||||
inputs.apropos-tx.url =
|
||||
"github:jhodgdev/apropos-tx?rev=4eca3fac23c339caee04ea6176e641a4b3857a25";
|
||||
inputs.apropos-tx.inputs.nixpkgs.follows =
|
||||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
inputs.apropos.url =
|
||||
"github:mlabs-haskell/apropos?rev=3734bb3baa297ed990725a5ef14efcbb6a1c1c23";
|
||||
inputs.apropos.inputs.nixpkgs.follows =
|
||||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
|
||||
outputs = inputs@{ self, nixpkgs, haskell-nix, plutarch, ... }:
|
||||
let
|
||||
supportedSystems = with nixpkgs.lib.systems.supported;
|
||||
|
|
@ -32,7 +40,6 @@
|
|||
overlays = [ haskell-nix.overlay ];
|
||||
inherit (haskell-nix) config;
|
||||
};
|
||||
|
||||
nixpkgsFor' = system:
|
||||
import nixpkgs {
|
||||
inherit system;
|
||||
|
|
@ -51,12 +58,22 @@
|
|||
extraSources = plutarch.extraSources ++ [
|
||||
{
|
||||
src = inputs.plutarch;
|
||||
subdirs = [ "." "plutarch-test" "plutarch-extra" ];
|
||||
subdirs = [
|
||||
"."
|
||||
"plutarch-test"
|
||||
"plutarch-extra"
|
||||
"plutarch-numeric"
|
||||
"plutarch-safemoney"
|
||||
];
|
||||
}
|
||||
{
|
||||
src = inputs.apropos-tx;
|
||||
subdirs = [ "." ];
|
||||
}
|
||||
{
|
||||
src = inputs.apropos;
|
||||
subdirs = [ "." ];
|
||||
}
|
||||
];
|
||||
modules = [ (plutarch.haskellModule system) ];
|
||||
shell = {
|
||||
|
|
@ -66,24 +83,30 @@
|
|||
|
||||
# We use the ones from Nixpkgs, since they are cached reliably.
|
||||
# Eventually we will probably want to build these with haskell.nix.
|
||||
nativeBuildInputs = [
|
||||
pkgs'.git
|
||||
pkgs'.haskellPackages.apply-refact
|
||||
pkgs'.fd
|
||||
pkgs'.cabal-install
|
||||
pkgs'.haskell.packages."${ghcVersion}".hlint
|
||||
pkgs'.haskellPackages.cabal-fmt
|
||||
pkgs'.nixpkgs-fmt
|
||||
pkgs'.graphviz
|
||||
nativeBuildInputs = with pkgs'; [
|
||||
entr
|
||||
haskellPackages.apply-refact
|
||||
git
|
||||
fd
|
||||
cabal-install
|
||||
haskell.packages."${ghcVersion}".hlint
|
||||
haskellPackages.cabal-fmt
|
||||
nixpkgs-fmt
|
||||
graphviz
|
||||
];
|
||||
|
||||
inherit (plutarch) tools;
|
||||
|
||||
additional = ps: [
|
||||
ps.plutarch
|
||||
ps.plutarch-test
|
||||
ps.tasty-quickcheck
|
||||
ps.apropos-tx
|
||||
ps.apropos
|
||||
ps.plutarch-extra
|
||||
ps.plutarch-numeric
|
||||
ps.plutarch-safemoney
|
||||
ps.plutarch-test
|
||||
ps.apropos
|
||||
];
|
||||
};
|
||||
};
|
||||
|
|
@ -92,17 +115,15 @@
|
|||
let
|
||||
pkgs = nixpkgsFor system;
|
||||
pkgs' = nixpkgsFor' system;
|
||||
inherit (pkgs.haskell-nix.tools ghcVersion {
|
||||
inherit (plutarch.tools) fourmolu;
|
||||
})
|
||||
fourmolu;
|
||||
in pkgs.runCommand "format-check" {
|
||||
nativeBuildInputs = [
|
||||
pkgs'.git
|
||||
pkgs'.fd
|
||||
pkgs'.haskellPackages.cabal-fmt
|
||||
pkgs'.nixpkgs-fmt
|
||||
fourmolu
|
||||
(pkgs.haskell-nix.tools ghcVersion {
|
||||
inherit (plutarch.tools) fourmolu;
|
||||
}).fourmolu
|
||||
];
|
||||
} ''
|
||||
export LC_CTYPE=C.UTF-8
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue