Reset progress on treasury testing; will continue without apropos
This commit is contained in:
Jack Hodgkinson
commit
dafa6fe8f0
37 changed files with 3029 additions and 1191 deletions
6
.github/format.sh
vendored
6
.github/format.sh
vendored
|
|
@ -1,6 +0,0 @@
|
|||
#!/bin/bash
|
||||
|
||||
# Extensions necessary to tell fourmolu about
|
||||
EXTENSIONS="-o -XTypeApplications -o -XTemplateHaskell -o -XImportQualifiedPost -o -XPatternSynonyms -o -XOverloadedRecordDot"
|
||||
SOURCES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs')
|
||||
nix run nixpkgs#haskell.packages.ghc921.fourmolu -- --mode check --check-idempotence $EXTENSIONS $SOURCES
|
||||
59
.github/workflows/integrate.yaml
vendored
59
.github/workflows/integrate.yaml
vendored
|
|
@ -34,30 +34,8 @@ jobs:
|
|||
name: mlabs
|
||||
authToken: ${{ secrets.CACHIX_KEY }}
|
||||
|
||||
- run: ./.github/format.sh
|
||||
name: Run fourmolu
|
||||
|
||||
run-linter:
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- uses: actions/checkout@v2.4.0
|
||||
|
||||
- uses: cachix/install-nix-action@v16
|
||||
name: Set up Nix and IOHK caches
|
||||
with:
|
||||
nix_path: nixpkgs=channel:nixos-unstable
|
||||
extra_nix_config: |
|
||||
trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
|
||||
substituters = https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/
|
||||
experimental-features = nix-command flakes
|
||||
|
||||
- uses: cachix/cachix-action@v10
|
||||
with:
|
||||
name: mlabs
|
||||
authToken: ${{ secrets.CACHIX_KEY }}
|
||||
|
||||
- run: nix run nixpkgs#haskell.packages.ghc921.hlint -- $(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs')
|
||||
name: Run hlint
|
||||
- run: nix build .#checks.x86_64-linux.formatCheck
|
||||
name: Run 'formatCheck' from flake.nix
|
||||
|
||||
check-build:
|
||||
runs-on: ubuntu-latest
|
||||
|
|
@ -90,3 +68,36 @@ jobs:
|
|||
|
||||
- name: Build the project
|
||||
run: nix build .#check.x86_64-linux
|
||||
|
||||
|
||||
|
||||
haddock:
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- uses: actions/checkout@v2.4.0
|
||||
|
||||
- uses: cachix/install-nix-action@v16
|
||||
name: Set up Nix and IOHK caches
|
||||
with:
|
||||
nix_path: nixpkgs=channel:nixos-unstable
|
||||
extra_nix_config: |
|
||||
trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
|
||||
substituters = https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/
|
||||
experimental-features = nix-command flakes
|
||||
|
||||
- uses: cachix/cachix-action@v10
|
||||
with:
|
||||
name: mlabs
|
||||
authToken: ${{ secrets.CACHIX_KEY }}
|
||||
|
||||
- run: nix build .#packages.x86_64-linux.haddock
|
||||
name: Run 'haddock' from flake.nix
|
||||
|
||||
# This publishes the haddock result to the branch 'gh-pages',
|
||||
# which is set to automatically deploy to https://liqwid-labs.github.io/agora/.
|
||||
- name: Publish Documentation
|
||||
uses: peaceiris/actions-gh-pages@v3
|
||||
if: github.ref == 'refs/heads/master'
|
||||
with:
|
||||
github_token: ${{ secrets.GITHUB_TOKEN }}
|
||||
publish_dir: ./result/agora/html
|
||||
|
|
|
|||
15
Makefile
15
Makefile
|
|
@ -10,6 +10,7 @@ usage:
|
|||
@echo " hoogle -- Start local hoogle"
|
||||
@echo " format -- Format the project"
|
||||
@echo " haddock -- Generate Haddock docs for project"
|
||||
@echo " tag -- Generate CTAGS and ETAGS files for project"
|
||||
|
||||
hoogle:
|
||||
pkill hoogle || true
|
||||
|
|
@ -17,10 +18,14 @@ hoogle:
|
|||
hoogle server --local -p 8081 >> /dev/null &
|
||||
hoogle server --local --database=hoo/local.hoo -p 8082 >> /dev/null &
|
||||
|
||||
FORMAT_EXTENSIONS := -o -XQuasiQuotes -o -XTemplateHaskell -o -XTypeApplications -o -XImportQualifiedPost -o -XPatternSynonyms -o -XOverloadedRecordDot
|
||||
format:
|
||||
find -name '*.hs' -not -path './dist-*/*' | xargs fourmolu $(FORMAT_EXTENSIONS) -m inplace
|
||||
format: format_haskell format_nix
|
||||
|
||||
format_nix:
|
||||
git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.nix' | xargs nixpkgs-fmt
|
||||
|
||||
FORMAT_EXTENSIONS := -o -XQuasiQuotes -o -XTemplateHaskell -o -XTypeApplications -o -XImportQualifiedPost -o -XPatternSynonyms -o -XOverloadedRecordDot
|
||||
format_haskell:
|
||||
find -name '*.hs' -not -path './dist-*/*' | xargs fourmolu $(FORMAT_EXTENSIONS) -m inplace
|
||||
git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.cabal' | xargs cabal-fmt -i
|
||||
|
||||
format_check:
|
||||
|
|
@ -31,3 +36,7 @@ format_check:
|
|||
|
||||
haddock:
|
||||
cabal haddock --haddock-html --haddock-hoogle --builddir=haddock
|
||||
|
||||
tag:
|
||||
hasktags -x agora agora-bench agora-test
|
||||
|
||||
|
|
|
|||
|
|
@ -25,6 +25,8 @@ Open a development shell with `nix develop` and build the project with `cabal bu
|
|||
|
||||
Documentation for Agora may be found in [docs](./docs).
|
||||
|
||||
Haddock is deployed on GitHub Pages [here](https://liqwid-labs.github.io/agora/).
|
||||
|
||||
### Using Agora for your protocol
|
||||
|
||||
If you are a protocol wanting to use Agora, read [Using Agora](./docs/using-agora.md).
|
||||
|
|
|
|||
11
agora-test/README.org
Normal file
11
agora-test/README.org
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
#+Title: Agora Test
|
||||
This folder is the test suite for Agora governance system.
|
||||
|
||||
- =/Spec= contains different tests for different elements of Agora.
|
||||
- =/Spec/Model= contain =apropos-tx= model for logical suite
|
||||
generation and tests.
|
||||
- =/Spec/Sample= contains primitive hand-made example values.
|
||||
- =Util.hs= contains helper functions
|
||||
|
||||
Currently, planning to introduce =plutarch-test= for unit tests,
|
||||
benchmarks, and golden tests.
|
||||
|
|
@ -10,8 +10,10 @@ import Test.Tasty (defaultMain, testGroup)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Spec.AuthorityToken qualified as AuthorityToken
|
||||
import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
|
||||
import Spec.Model.MultiSig qualified as MultiSig
|
||||
import Spec.Model.Treasury qualified as Treasury
|
||||
import Spec.Proposal qualified as Proposal
|
||||
import Spec.Stake qualified as Stake
|
||||
|
||||
-- | The Agora test suite.
|
||||
|
|
@ -21,8 +23,17 @@ main =
|
|||
testGroup
|
||||
"test suite"
|
||||
[ testGroup
|
||||
"Effects"
|
||||
[ testGroup
|
||||
"Treasury Withdrawal Effect"
|
||||
TreasuryWithdrawal.tests
|
||||
]
|
||||
, testGroup
|
||||
"Stake tests"
|
||||
Stake.tests
|
||||
, testGroup
|
||||
"Proposal tests"
|
||||
Proposal.tests
|
||||
, testGroup
|
||||
"Multisig tests"
|
||||
[ testGroup
|
||||
|
|
@ -32,11 +43,6 @@ main =
|
|||
]
|
||||
]
|
||||
, testGroup
|
||||
"Treasury tests"
|
||||
[ testGroup
|
||||
"Treasury"
|
||||
[ Treasury.genTests
|
||||
, Treasury.plutarchTests
|
||||
]
|
||||
]
|
||||
"AuthorityToken tests"
|
||||
AuthorityToken.tests
|
||||
]
|
||||
|
|
|
|||
154
agora-test/Spec/AuthorityToken.hs
Normal file
154
agora-test/Spec/AuthorityToken.hs
Normal file
|
|
@ -0,0 +1,154 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{- |
|
||||
Module : Spec.AuthorityToken
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Tests for Authority token functions
|
||||
|
||||
Tests for Authority token functions
|
||||
-}
|
||||
module Spec.AuthorityToken (tests) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Plutarch
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Api (
|
||||
Address (Address),
|
||||
Credential (PubKeyCredential, ScriptCredential),
|
||||
CurrencySymbol,
|
||||
Script,
|
||||
TxInInfo (TxInInfo),
|
||||
TxInfo (..),
|
||||
TxOut (TxOut),
|
||||
TxOutRef (TxOutRef),
|
||||
ValidatorHash (ValidatorHash),
|
||||
Value,
|
||||
)
|
||||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Spec.Util (scriptFails, scriptSucceeds)
|
||||
|
||||
currencySymbol :: CurrencySymbol
|
||||
currencySymbol = "deadbeef"
|
||||
|
||||
mkTxInfo :: Value -> [TxOut] -> TxInfo
|
||||
mkTxInfo mint outs =
|
||||
TxInfo
|
||||
{ txInfoInputs = fmap (TxInInfo (TxOutRef "" 0)) outs
|
||||
, txInfoOutputs = []
|
||||
, txInfoFee = Value.singleton "" "" 1000
|
||||
, txInfoMint = mint
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = []
|
||||
, txInfoData = []
|
||||
, txInfoId = ""
|
||||
}
|
||||
|
||||
singleAuthorityTokenBurnedTest :: Value -> [TxOut] -> Script
|
||||
singleAuthorityTokenBurnedTest mint outs =
|
||||
let actual :: ClosedTerm PBool
|
||||
actual = singleAuthorityTokenBurned (pconstant currencySymbol) (pconstantData (mkTxInfo mint outs)) (pconstant mint)
|
||||
s :: ClosedTerm POpaque
|
||||
s =
|
||||
pif
|
||||
actual
|
||||
(popaque (pconstant ()))
|
||||
perror
|
||||
in compile s
|
||||
|
||||
tests :: [TestTree]
|
||||
tests =
|
||||
[ -- This is better suited for plutarch-test
|
||||
testGroup
|
||||
"singleAuthorityTokenBurned"
|
||||
[ scriptSucceeds
|
||||
"Correct simple"
|
||||
( singleAuthorityTokenBurnedTest
|
||||
( Value.singleton currencySymbol "deadbeef" (-1)
|
||||
<> Value.singleton "aa" "USDC" 100_000
|
||||
)
|
||||
[ TxOut
|
||||
(Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
|
||||
(Value.singleton currencySymbol "deadbeef" 1)
|
||||
Nothing
|
||||
]
|
||||
)
|
||||
, scriptSucceeds
|
||||
"Correct many inputs"
|
||||
( singleAuthorityTokenBurnedTest
|
||||
( Value.singleton currencySymbol "deadbeef" (-1)
|
||||
<> Value.singleton "aa" "USDC" 100_000
|
||||
)
|
||||
[ TxOut
|
||||
(Address (PubKeyCredential "") Nothing)
|
||||
(Value.singleton "aaabcc" "hello-token" 1)
|
||||
Nothing
|
||||
, TxOut
|
||||
(Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
|
||||
(Value.singleton currencySymbol "deadbeef" 1)
|
||||
Nothing
|
||||
, TxOut
|
||||
(Address (PubKeyCredential "") Nothing)
|
||||
(Value.singleton "" "" 1_000_000_000)
|
||||
Nothing
|
||||
]
|
||||
)
|
||||
, scriptFails
|
||||
"Incorrect no burn"
|
||||
( singleAuthorityTokenBurnedTest
|
||||
( Value.Value AssocMap.empty
|
||||
)
|
||||
[]
|
||||
)
|
||||
, scriptFails
|
||||
"Incorrect no GAT burn"
|
||||
( singleAuthorityTokenBurnedTest
|
||||
( Value.singleton "aabbcc" "not a GAT!" (-100)
|
||||
)
|
||||
[]
|
||||
)
|
||||
, scriptFails
|
||||
"Incorrect script mismatch"
|
||||
( singleAuthorityTokenBurnedTest
|
||||
( Value.singleton currencySymbol "i'm not deadbeef!" (-1)
|
||||
)
|
||||
[ TxOut
|
||||
(Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
|
||||
(Value.singleton currencySymbol "i'm not deadbeef!" 1)
|
||||
Nothing
|
||||
]
|
||||
)
|
||||
, scriptFails
|
||||
"Incorrect spent from PK"
|
||||
( singleAuthorityTokenBurnedTest
|
||||
( Value.singleton currencySymbol "doesn't matter" (-1)
|
||||
)
|
||||
[ TxOut
|
||||
(Address (PubKeyCredential "") Nothing)
|
||||
(Value.singleton currencySymbol "doesn't matter" 1)
|
||||
Nothing
|
||||
]
|
||||
)
|
||||
, scriptFails
|
||||
"Incorrect two GATs"
|
||||
( singleAuthorityTokenBurnedTest
|
||||
( Value.singleton currencySymbol "deadbeef" (-2)
|
||||
<> Value.singleton "aa" "USDC" 100_000
|
||||
)
|
||||
[ TxOut
|
||||
(Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
|
||||
(Value.singleton currencySymbol "deadbeef" 2)
|
||||
Nothing
|
||||
]
|
||||
)
|
||||
]
|
||||
]
|
||||
168
agora-test/Spec/Effect/TreasuryWithdrawal.hs
Normal file
168
agora-test/Spec/Effect/TreasuryWithdrawal.hs
Normal file
|
|
@ -0,0 +1,168 @@
|
|||
{- |
|
||||
Module : Spec.Effect.TreasuryWithdrawalEffect
|
||||
Maintainer : seungheon.ooh@gmail.com
|
||||
Description: Sample based testing for Treasury Withdrawal Effect
|
||||
|
||||
This module tests the Treasury Withdrawal Effect.
|
||||
-}
|
||||
module Spec.Effect.TreasuryWithdrawal (tests) where
|
||||
|
||||
import Agora.Effect.TreasuryWithdrawal (
|
||||
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
|
||||
treasuryWithdrawalValidator,
|
||||
)
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
import Spec.Sample.Effect.TreasuryWithdrawal (
|
||||
buildReceiversOutputFromDatum,
|
||||
buildScriptContext,
|
||||
currSymbol,
|
||||
inputCollateral,
|
||||
inputGAT,
|
||||
inputTreasury,
|
||||
inputUser,
|
||||
outputTreasury,
|
||||
outputUser,
|
||||
treasuries,
|
||||
users,
|
||||
)
|
||||
import Spec.Util (effectFailsWith, effectSucceedsWith)
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
|
||||
tests :: [TestTree]
|
||||
tests =
|
||||
[ testGroup
|
||||
"effect"
|
||||
[ effectSucceedsWith
|
||||
"Simple"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
datum1
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
, inputCollateral 10
|
||||
, inputTreasury 1 (asset1 10)
|
||||
]
|
||||
$ outputTreasury 1 (asset1 7) :
|
||||
buildReceiversOutputFromDatum datum1
|
||||
)
|
||||
, effectSucceedsWith
|
||||
"Simple with multiple treasuries "
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
datum1
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
, inputCollateral 10
|
||||
, inputTreasury 1 (asset1 10)
|
||||
, inputTreasury 2 (asset1 100)
|
||||
, inputTreasury 3 (asset1 500)
|
||||
]
|
||||
$ [ outputTreasury 1 (asset1 7)
|
||||
, outputTreasury 2 (asset1 100)
|
||||
, outputTreasury 3 (asset1 500)
|
||||
]
|
||||
++ buildReceiversOutputFromDatum datum1
|
||||
)
|
||||
, effectSucceedsWith
|
||||
"Mixed Assets"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
datum2
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
, inputCollateral 10
|
||||
, inputTreasury 1 (asset1 20)
|
||||
, inputTreasury 2 (asset2 20)
|
||||
]
|
||||
$ [ outputTreasury 1 (asset1 13)
|
||||
, outputTreasury 2 (asset2 14)
|
||||
]
|
||||
++ buildReceiversOutputFromDatum datum2
|
||||
)
|
||||
, effectFailsWith
|
||||
"Pay to uknown 3rd party"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
datum2
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
, inputCollateral 10
|
||||
, inputTreasury 1 (asset1 20)
|
||||
, inputTreasury 2 (asset2 20)
|
||||
]
|
||||
$ [ outputUser 100 (asset1 2)
|
||||
, outputTreasury 1 (asset1 11)
|
||||
, outputTreasury 2 (asset2 14)
|
||||
]
|
||||
++ buildReceiversOutputFromDatum datum2
|
||||
)
|
||||
, effectFailsWith
|
||||
"Missing receiver"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
datum2
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
, inputCollateral 10
|
||||
, inputTreasury 1 (asset1 20)
|
||||
, inputTreasury 2 (asset2 20)
|
||||
]
|
||||
$ [ outputTreasury 1 (asset1 13)
|
||||
, outputTreasury 2 (asset2 14)
|
||||
]
|
||||
++ drop 1 (buildReceiversOutputFromDatum datum2)
|
||||
)
|
||||
, effectFailsWith
|
||||
"Unauthorized treasury"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
datum3
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
, inputCollateral 10
|
||||
, inputTreasury 999 (asset1 20)
|
||||
]
|
||||
$ outputTreasury 999 (asset1 17) :
|
||||
buildReceiversOutputFromDatum datum3
|
||||
)
|
||||
, effectFailsWith
|
||||
"Prevent transactions besides the withdrawal"
|
||||
(treasuryWithdrawalValidator currSymbol)
|
||||
datum3
|
||||
( buildScriptContext
|
||||
[ inputGAT
|
||||
, inputTreasury 1 (asset1 20)
|
||||
, inputTreasury 999 (asset1 20)
|
||||
, inputUser 99 (asset2 100)
|
||||
]
|
||||
$ [ outputTreasury 1 (asset1 17)
|
||||
, outputUser 100 (asset2 100)
|
||||
]
|
||||
++ buildReceiversOutputFromDatum datum3
|
||||
)
|
||||
]
|
||||
]
|
||||
where
|
||||
asset1 = Value.singleton "abbc12" "OrangeBottle"
|
||||
asset2 = Value.singleton "abbc12" "19721121"
|
||||
datum1 =
|
||||
TreasuryWithdrawalDatum
|
||||
[ (head users, asset1 1)
|
||||
, (users !! 1, asset1 1)
|
||||
, (users !! 2, asset1 1)
|
||||
]
|
||||
[ treasuries !! 1
|
||||
, treasuries !! 2
|
||||
, treasuries !! 3
|
||||
]
|
||||
datum2 =
|
||||
TreasuryWithdrawalDatum
|
||||
[ (head users, asset1 4 <> asset2 5)
|
||||
, (users !! 1, asset1 2 <> asset2 1)
|
||||
, (users !! 2, asset1 1)
|
||||
]
|
||||
[ head treasuries
|
||||
, treasuries !! 1
|
||||
, treasuries !! 2
|
||||
]
|
||||
datum3 =
|
||||
TreasuryWithdrawalDatum
|
||||
[ (head users, asset1 1)
|
||||
, (users !! 1, asset1 1)
|
||||
, (users !! 2, asset1 1)
|
||||
]
|
||||
[treasuries !! 1]
|
||||
|
|
@ -1,399 +0,0 @@
|
|||
{-# OPTIONS_GHC -Wwarn #-}
|
||||
|
||||
{- |
|
||||
Module: Spec.Model.Treasury
|
||||
Description: `apropos-tx` tests for Treasury validator.
|
||||
Maintainer: jack@mlabs.city
|
||||
|
||||
This module contains `apropos-tx` tests for ensuring that
|
||||
the `Agora.Treasury` validator acts as desired. Notes on desired
|
||||
behaviour and invluded in this description.
|
||||
|
||||
A Treasury transaction should pass if:
|
||||
|
||||
1. A GAT is burned.
|
||||
|
||||
2. All GATs are valid.
|
||||
|
||||
3. The script purpose is Minting.
|
||||
|
||||
If either of these things do /not/ hold, then the transaction
|
||||
should fail.
|
||||
-}
|
||||
module Spec.Model.Treasury (
|
||||
plutarchTests,
|
||||
genTests,
|
||||
) where
|
||||
|
||||
import Agora.Treasury (
|
||||
PTreasuryDatum (PTreasuryDatum),
|
||||
PTreasuryRedeemer (PAlterTreasuryParams),
|
||||
treasuryValidator,
|
||||
)
|
||||
import Apropos (
|
||||
Apropos (Apropos),
|
||||
Contract,
|
||||
Enumerable (enumerated),
|
||||
Formula (
|
||||
All,
|
||||
Not,
|
||||
Some,
|
||||
Var,
|
||||
Yes,
|
||||
(:&&:),
|
||||
(:||:)
|
||||
),
|
||||
Gen,
|
||||
HasLogicalModel (satisfiesProperty),
|
||||
HasParameterisedGenerator (parameterisedGenerator),
|
||||
HasPermutationGenerator (buildGen, generators),
|
||||
LogicalModel (logic),
|
||||
Morphism (Morphism, contract, match, morphism, name),
|
||||
add,
|
||||
choice,
|
||||
remove,
|
||||
runGeneratorTestsWhere,
|
||||
(:+),
|
||||
)
|
||||
import Apropos.Gen.Contexts (scriptContext, txInInfo, txOutRef)
|
||||
import Apropos.Gen.Credential (stakingCredential)
|
||||
import Apropos.Gen.DCert (dCert)
|
||||
import Apropos.Gen.Value (currencySymbol)
|
||||
import Apropos.Script (ScriptModel (expect, runScriptTestsWhere, script))
|
||||
import Data.Bifunctor (Bifunctor (first))
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Set (Set)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol, PScriptContext)
|
||||
import Plutarch.Builtin (pforgetData)
|
||||
import Plutus.V1.Ledger.Address (Address (addressCredential))
|
||||
import Plutus.V1.Ledger.Contexts (
|
||||
ScriptContext (scriptContextPurpose, scriptContextTxInfo),
|
||||
ScriptPurpose (Certifying, Minting, Rewarding, Spending),
|
||||
TxInInfo (txInInfoResolved),
|
||||
TxInfo (txInfoInputs, txInfoMint, txInfoOutputs),
|
||||
TxOut (txOutAddress, txOutValue),
|
||||
)
|
||||
import Plutus.V1.Ledger.Credential (Credential (PubKeyCredential, ScriptCredential))
|
||||
import Plutus.V1.Ledger.Scripts (Script, ValidatorHash (ValidatorHash))
|
||||
import Plutus.V1.Ledger.Value (
|
||||
CurrencySymbol (CurrencySymbol),
|
||||
TokenName (TokenName, unTokenName),
|
||||
Value (Value, getValue),
|
||||
)
|
||||
import Plutus.V1.Ledger.Value qualified as Value (unionWith)
|
||||
import PlutusTx.AssocMap (Map, elems, fromList, keys, singleton, toList, unionWith)
|
||||
import PlutusTx.AssocMap qualified as AssocMap (delete, insert, lookup)
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.Hedgehog (fromGroup)
|
||||
|
||||
data TreasuryTxProp
|
||||
= GATIsBurned
|
||||
| AllGATsValid
|
||||
| ScriptPurposeIsMinting
|
||||
deriving stock (Show, Eq, Ord, Enum, Bounded)
|
||||
|
||||
instance LogicalModel TreasuryTxProp where
|
||||
logic :: Formula TreasuryTxProp
|
||||
logic = Yes
|
||||
|
||||
data TreasuryTxModel = TreasuryTxModel
|
||||
{ gatCs :: CurrencySymbol
|
||||
, ctx :: ScriptContext
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
instance Enumerable TreasuryTxProp where
|
||||
enumerated :: [TreasuryTxProp]
|
||||
enumerated = [minBound .. maxBound]
|
||||
|
||||
isMinting :: ScriptPurpose -> Bool
|
||||
isMinting (Minting _) = True
|
||||
isMinting _ = False
|
||||
|
||||
authorityTokensValidIn :: CurrencySymbol -> TxOut -> Bool
|
||||
authorityTokensValidIn cs out =
|
||||
let add = out.txOutAddress :: Address
|
||||
outValue = out.txOutValue :: Value
|
||||
|
||||
tokenMap :: Maybe (Map TokenName Integer)
|
||||
tokenMap = AssocMap.lookup cs $ getValue outValue
|
||||
|
||||
cred = add.addressCredential :: Credential
|
||||
|
||||
validCred :: Map TokenName Integer -> Bool
|
||||
validCred m = case cred of
|
||||
PubKeyCredential _ -> False
|
||||
ScriptCredential (ValidatorHash vh) ->
|
||||
all (\tn -> vh == unTokenName tn) $ keys m
|
||||
in maybe True validCred tokenMap
|
||||
|
||||
instance HasLogicalModel TreasuryTxProp TreasuryTxModel where
|
||||
satisfiesProperty :: TreasuryTxProp -> TreasuryTxModel -> Bool
|
||||
satisfiesProperty prop model =
|
||||
let purpose = model.ctx.scriptContextPurpose :: ScriptPurpose
|
||||
txInfo = model.ctx.scriptContextTxInfo :: TxInfo
|
||||
amountMinted = txInfo.txInfoMint :: Value
|
||||
|
||||
csValue :: Maybe (Map TokenName Integer)
|
||||
csValue = AssocMap.lookup model.gatCs (getValue amountMinted)
|
||||
|
||||
csValueSum :: Integer
|
||||
csValueSum = case csValue of
|
||||
Nothing -> 0
|
||||
Just m -> sum $ elems m
|
||||
in case prop of
|
||||
GATIsBurned -> csValueSum == -1
|
||||
AllGATsValid ->
|
||||
all
|
||||
(authorityTokensValidIn model.gatCs . txInInfoResolved)
|
||||
txInfo.txInfoInputs
|
||||
ScriptPurposeIsMinting -> isMinting purpose
|
||||
|
||||
instance HasParameterisedGenerator TreasuryTxProp TreasuryTxModel where
|
||||
parameterisedGenerator :: Set TreasuryTxProp -> Gen TreasuryTxModel
|
||||
parameterisedGenerator = buildGen baseGen
|
||||
where
|
||||
baseGen :: Gen TreasuryTxModel
|
||||
baseGen = do
|
||||
cs <- currencySymbol
|
||||
ctx <- scriptContext
|
||||
return $ TreasuryTxModel cs ctx
|
||||
|
||||
{- | Updates the `Integer` and `TokenName` for a given
|
||||
`CurrencySymbol` for a given value.
|
||||
-}
|
||||
replaceValue ::
|
||||
-- | The value whose entry to update.
|
||||
Value ->
|
||||
-- | The currency symbol of the entry to update.
|
||||
CurrencySymbol ->
|
||||
-- | The token name of the entry to place in the new value.
|
||||
TokenName ->
|
||||
-- | The number of tokens to place in the new value.
|
||||
Integer ->
|
||||
-- | The updated value.
|
||||
Value
|
||||
replaceValue (Value v) cs tn n = Value $ unionWith (\_ x -> x) v v'
|
||||
where
|
||||
v' :: Map CurrencySymbol (Map TokenName Integer)
|
||||
v' = singleton cs $ singleton tn n
|
||||
|
||||
kmap :: (k -> k') -> Map k v -> Map k' v
|
||||
kmap g = fromList . fmap (first g) . toList
|
||||
|
||||
fixTokenNames :: CurrencySymbol -> TxInInfo -> TxInInfo
|
||||
fixTokenNames cs inf =
|
||||
let cred = inf.txInInfoResolved.txOutAddress.addressCredential
|
||||
Value val = inf.txInInfoResolved.txOutValue
|
||||
in case cred of
|
||||
PubKeyCredential _ ->
|
||||
let newVal = Value $ AssocMap.delete cs val
|
||||
in inf {txInInfoResolved = inf.txInInfoResolved {txOutValue = newVal}}
|
||||
ScriptCredential (ValidatorHash bs) ->
|
||||
case AssocMap.lookup cs val of
|
||||
Nothing -> inf
|
||||
Just m ->
|
||||
let tn :: TokenName = TokenName bs
|
||||
m' = kmap (\_ -> tn) m
|
||||
v' = Value $ AssocMap.insert cs m' val
|
||||
in inf
|
||||
{ txInInfoResolved =
|
||||
inf.txInInfoResolved
|
||||
{ txOutValue = v'
|
||||
}
|
||||
}
|
||||
|
||||
instance HasPermutationGenerator TreasuryTxProp TreasuryTxModel where
|
||||
generators :: [Morphism TreasuryTxProp TreasuryTxModel]
|
||||
generators =
|
||||
[ Morphism
|
||||
{ name = "Ensure GAT is burned"
|
||||
, match = Not $ Var GATIsBurned
|
||||
, contract = add GATIsBurned
|
||||
, morphism = \m ->
|
||||
let ctx' = m.ctx
|
||||
txInfo = ctx'.scriptContextTxInfo
|
||||
mint = txInfo.txInfoMint
|
||||
newMint = replaceValue mint m.gatCs "gat" (-1)
|
||||
in return
|
||||
m
|
||||
{ ctx =
|
||||
ctx'
|
||||
{ scriptContextTxInfo =
|
||||
txInfo
|
||||
{ txInfoMint = newMint
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
, Morphism
|
||||
{ name = "Ensure all GATs are valid"
|
||||
, match = Not $ Var AllGATsValid
|
||||
, contract = add AllGATsValid
|
||||
, {- For every GAT to be considered "valid", their
|
||||
`TokenName`s have to be equal to the address
|
||||
of their script. To represent this as a `Morphism`:
|
||||
|
||||
- FOR every UTXO input in the transaction:
|
||||
- FOR every value in the input:
|
||||
- IF the currency symbol matches the recognised
|
||||
GAT currency symbol:
|
||||
- THEN: set the `TokenName` to be equal to
|
||||
the UTXO's address.
|
||||
- ELSE: ignore it.
|
||||
-}
|
||||
morphism = \m ->
|
||||
let ctx' = m.ctx
|
||||
txInfo = ctx'.scriptContextTxInfo
|
||||
infoInputs :: [TxInInfo] = txInfo.txInfoInputs
|
||||
in return $
|
||||
m
|
||||
{ ctx =
|
||||
ctx'
|
||||
{ scriptContextTxInfo =
|
||||
txInfo
|
||||
{ txInfoInputs =
|
||||
fixTokenNames m.gatCs <$> infoInputs
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
, Morphism
|
||||
{ name = "Ensure script purpose is minting"
|
||||
, match = Not $ Var ScriptPurposeIsMinting
|
||||
, contract = add ScriptPurposeIsMinting
|
||||
, morphism = \m ->
|
||||
return
|
||||
m
|
||||
{ ctx =
|
||||
m.ctx
|
||||
{ scriptContextPurpose = Minting m.gatCs
|
||||
}
|
||||
}
|
||||
}
|
||||
, Morphism
|
||||
{ name = "Ensure GAT is not burned"
|
||||
, match = Var GATIsBurned
|
||||
, contract = remove GATIsBurned
|
||||
, morphism = \m ->
|
||||
let ctx' = m.ctx
|
||||
txInfo = ctx'.scriptContextTxInfo
|
||||
mint = txInfo.txInfoMint
|
||||
newMint = replaceValue mint m.gatCs "gat" 0
|
||||
in return
|
||||
m
|
||||
{ ctx =
|
||||
ctx'
|
||||
{ scriptContextTxInfo =
|
||||
txInfo
|
||||
{ txInfoMint = newMint
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
, Morphism
|
||||
{ name = "Ensure ScriptPurpose is not Minting"
|
||||
, match = Var ScriptPurposeIsMinting
|
||||
, contract = remove ScriptPurposeIsMinting
|
||||
, morphism = \m -> do
|
||||
newPurpose <-
|
||||
choice
|
||||
[ Spending <$> txOutRef
|
||||
, Rewarding <$> stakingCredential
|
||||
, Certifying <$> dCert
|
||||
]
|
||||
return m {ctx = m.ctx {scriptContextPurpose = newPurpose}}
|
||||
}
|
||||
, Morphism
|
||||
{ name = "Ensure not all GATs are valid."
|
||||
, match = Var AllGATsValid
|
||||
, contract = remove AllGATsValid
|
||||
, morphism = \m -> do
|
||||
dummyInp <- txInInfo
|
||||
let ctx' = m.ctx
|
||||
txInfo = ctx'.scriptContextTxInfo
|
||||
inputs = txInfo.txInfoInputs
|
||||
firstIn = listToMaybe inputs
|
||||
inp = case firstIn of
|
||||
Nothing -> dummyInp
|
||||
Just inp' -> inp'
|
||||
inVal = inp.txInInfoResolved.txOutValue
|
||||
invalidGat =
|
||||
Value $
|
||||
singleton m.gatCs $
|
||||
singleton "notAnAddress" (-1)
|
||||
newVal = Value.unionWith (+) inVal invalidGat
|
||||
newIn =
|
||||
inp
|
||||
{ txInInfoResolved =
|
||||
inp.txInInfoResolved
|
||||
{ txOutValue = newVal
|
||||
}
|
||||
}
|
||||
newInputs = newIn : drop 1 inputs
|
||||
return
|
||||
m
|
||||
{ ctx =
|
||||
ctx'
|
||||
{ scriptContextTxInfo =
|
||||
txInfo
|
||||
{ txInfoInputs = newInputs
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
]
|
||||
|
||||
instance ScriptModel TreasuryTxProp TreasuryTxModel where
|
||||
expect :: (TreasuryTxModel :+ TreasuryTxProp) -> Formula TreasuryTxProp
|
||||
expect _ =
|
||||
Var GATIsBurned
|
||||
:&&: Var AllGATsValid
|
||||
:&&: Var ScriptPurposeIsMinting
|
||||
script :: (TreasuryTxModel :+ TreasuryTxProp) -> TreasuryTxModel -> Script
|
||||
script _ m = compile result
|
||||
where
|
||||
result :: Term s POpaque
|
||||
result =
|
||||
treasuryValidator cs
|
||||
# pforgetData (pdata d)
|
||||
# pforgetData (pdata r)
|
||||
# ctx
|
||||
|
||||
cs :: CurrencySymbol
|
||||
cs = m.gatCs
|
||||
|
||||
d :: Term s PTreasuryDatum
|
||||
d = pcon $ PTreasuryDatum fields
|
||||
where
|
||||
adaStateThread :: Term _ PCurrencySymbol
|
||||
adaStateThread = pconstant $ CurrencySymbol ""
|
||||
|
||||
fields :: Term _ (PDataRecord '["stateThread" ':= PCurrencySymbol])
|
||||
fields = pdcons # pdata adaStateThread # pdnil
|
||||
|
||||
r :: Term s PTreasuryRedeemer
|
||||
r = pcon $ PAlterTreasuryParams pdnil
|
||||
|
||||
ctx :: Term s PScriptContext
|
||||
ctx = pconstant m.ctx
|
||||
|
||||
genTests :: TestTree
|
||||
genTests =
|
||||
testGroup "genTests" $
|
||||
fromGroup
|
||||
<$> [ runGeneratorTestsWhere
|
||||
(Apropos :: TreasuryTxModel :+ TreasuryTxProp)
|
||||
"Generator"
|
||||
Yes
|
||||
]
|
||||
|
||||
plutarchTests :: TestTree
|
||||
plutarchTests =
|
||||
testGroup "plutarchTests" $
|
||||
fromGroup
|
||||
<$> [ runScriptTestsWhere
|
||||
(Apropos :: TreasuryTxModel :+ TreasuryTxProp)
|
||||
"ScriptValid"
|
||||
Yes
|
||||
]
|
||||
91
agora-test/Spec/Proposal.hs
Normal file
91
agora-test/Spec/Proposal.hs
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{- |
|
||||
Module : Spec.Proposal
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Tests for Proposal policy and validator
|
||||
|
||||
Tests for Proposal policy and validator
|
||||
-}
|
||||
module Spec.Proposal (tests) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Proposal (
|
||||
ProposalDatum (ProposalDatum),
|
||||
ProposalId (ProposalId),
|
||||
ProposalRedeemer (Cosign),
|
||||
ProposalStatus (Draft),
|
||||
ResultTag (ResultTag),
|
||||
cosigners,
|
||||
effects,
|
||||
emptyVotesFor,
|
||||
proposalId,
|
||||
status,
|
||||
thresholds,
|
||||
votes,
|
||||
)
|
||||
import Agora.Proposal.Scripts (
|
||||
proposalPolicy,
|
||||
proposalValidator,
|
||||
)
|
||||
import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake))
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Plutarch.SafeMoney (Tagged (Tagged))
|
||||
import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..))
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Spec.Sample.Proposal qualified as Proposal
|
||||
import Spec.Sample.Shared (signer, signer2)
|
||||
import Spec.Sample.Shared qualified as Shared
|
||||
import Spec.Util (policySucceedsWith, validatorSucceedsWith)
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Stake tests.
|
||||
tests :: [TestTree]
|
||||
tests =
|
||||
[ testGroup
|
||||
"policy"
|
||||
[ policySucceedsWith
|
||||
"proposalCreation"
|
||||
(proposalPolicy Shared.proposal)
|
||||
()
|
||||
Proposal.proposalCreation
|
||||
]
|
||||
, testGroup
|
||||
"validator"
|
||||
[ testGroup
|
||||
"cosignature"
|
||||
[ validatorSucceedsWith
|
||||
"proposal"
|
||||
(proposalValidator Shared.proposal)
|
||||
( ProposalDatum
|
||||
{ proposalId = ProposalId 0
|
||||
, effects =
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, [])
|
||||
, (ResultTag 1, [])
|
||||
]
|
||||
, status = Draft
|
||||
, cosigners = [signer]
|
||||
, thresholds = Shared.defaultProposalThresholds
|
||||
, votes =
|
||||
emptyVotesFor $
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, [])
|
||||
, (ResultTag 1, [])
|
||||
]
|
||||
}
|
||||
)
|
||||
(Cosign [signer2])
|
||||
(ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.proposalRef))
|
||||
, validatorSucceedsWith
|
||||
"stake"
|
||||
(stakeValidator Shared.stake)
|
||||
(StakeDatum (Tagged 50_000_000) signer2 [])
|
||||
WitnessStake
|
||||
(ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef))
|
||||
]
|
||||
]
|
||||
]
|
||||
172
agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
Normal file
172
agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
Normal file
|
|
@ -0,0 +1,172 @@
|
|||
{- |
|
||||
Module : Spec.Sample.Effect.TreasuryWithdrawalEffect
|
||||
Maintainer : seungheon.ooh@gmail.com
|
||||
Description: Sample based testing for Treasury Withdrawal Effect
|
||||
|
||||
This module provides smaples for Treasury Withdrawal Effect tests.
|
||||
-}
|
||||
module Spec.Sample.Effect.TreasuryWithdrawal (
|
||||
inputTreasury,
|
||||
inputUser,
|
||||
inputGAT,
|
||||
inputCollateral,
|
||||
outputTreasury,
|
||||
outputUser,
|
||||
buildReceiversOutputFromDatum,
|
||||
currSymbol,
|
||||
users,
|
||||
treasuries,
|
||||
buildScriptContext,
|
||||
) where
|
||||
|
||||
import Plutarch.Api.V1 (mkValidator, validatorHash)
|
||||
import Plutus.V1.Ledger.Api (
|
||||
Address (Address),
|
||||
Credential (..),
|
||||
CurrencySymbol (CurrencySymbol),
|
||||
DatumHash (DatumHash),
|
||||
PubKeyHash (PubKeyHash),
|
||||
ScriptContext (..),
|
||||
ScriptPurpose (Spending),
|
||||
TokenName (TokenName),
|
||||
TxInInfo (TxInInfo),
|
||||
TxInfo (
|
||||
TxInfo,
|
||||
txInfoDCert,
|
||||
txInfoData,
|
||||
txInfoFee,
|
||||
txInfoId,
|
||||
txInfoInputs,
|
||||
txInfoMint,
|
||||
txInfoOutputs,
|
||||
txInfoSignatories,
|
||||
txInfoValidRange,
|
||||
txInfoWdrl
|
||||
),
|
||||
TxOut (..),
|
||||
TxOutRef (TxOutRef),
|
||||
Validator,
|
||||
ValidatorHash (ValidatorHash),
|
||||
Value,
|
||||
toBuiltin,
|
||||
)
|
||||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
import Data.ByteString.Char8 qualified as C
|
||||
import Data.ByteString.Hash (sha2)
|
||||
|
||||
import Agora.Effect.TreasuryWithdrawal (
|
||||
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
|
||||
treasuryWithdrawalValidator,
|
||||
)
|
||||
|
||||
-- | A sample Currency Symbol.
|
||||
currSymbol :: CurrencySymbol
|
||||
currSymbol = CurrencySymbol "12312099"
|
||||
|
||||
-- | A sample 'PubKeyHash'.
|
||||
signer :: PubKeyHash
|
||||
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
|
||||
|
||||
-- | List of users who the effect will pay to.
|
||||
users :: [Credential]
|
||||
users = PubKeyCredential . PubKeyHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
|
||||
|
||||
-- | List of users who the effect will pay to.
|
||||
treasuries :: [Credential]
|
||||
treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
|
||||
|
||||
inputGAT :: TxInInfo
|
||||
inputGAT =
|
||||
TxInInfo
|
||||
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
|
||||
, txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
|
||||
, txOutDatumHash = Just (DatumHash "")
|
||||
}
|
||||
|
||||
inputTreasury :: Int -> Value -> TxInInfo
|
||||
inputTreasury indx val =
|
||||
TxInInfo
|
||||
(TxOutRef "" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (treasuries !! indx) Nothing
|
||||
, txOutValue = val
|
||||
, txOutDatumHash = Just (DatumHash "")
|
||||
}
|
||||
|
||||
inputUser :: Int -> Value -> TxInInfo
|
||||
inputUser indx val =
|
||||
TxInInfo
|
||||
(TxOutRef "" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (users !! indx) Nothing
|
||||
, txOutValue = val
|
||||
, txOutDatumHash = Just (DatumHash "")
|
||||
}
|
||||
|
||||
inputCollateral :: Int -> TxInInfo
|
||||
inputCollateral indx =
|
||||
TxInInfo -- Initiator
|
||||
(TxOutRef "" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (users !! indx) Nothing
|
||||
, txOutValue = Value.singleton "" "" 2000000
|
||||
, txOutDatumHash = Just (DatumHash "")
|
||||
}
|
||||
|
||||
outputTreasury :: Int -> Value -> TxOut
|
||||
outputTreasury indx val =
|
||||
TxOut
|
||||
{ txOutAddress = Address (treasuries !! indx) Nothing
|
||||
, txOutValue = val
|
||||
, txOutDatumHash = Nothing
|
||||
}
|
||||
|
||||
outputUser :: Int -> Value -> TxOut
|
||||
outputUser indx val =
|
||||
TxOut
|
||||
{ txOutAddress = Address (users !! indx) Nothing
|
||||
, txOutValue = val
|
||||
, txOutDatumHash = Nothing
|
||||
}
|
||||
|
||||
buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
|
||||
buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
|
||||
where
|
||||
f x =
|
||||
TxOut
|
||||
{ txOutAddress = Address (fst x) Nothing
|
||||
, txOutValue = snd x
|
||||
, txOutDatumHash = Nothing
|
||||
}
|
||||
|
||||
-- | Effect validator instance.
|
||||
validator :: Validator
|
||||
validator = mkValidator $ treasuryWithdrawalValidator currSymbol
|
||||
|
||||
-- | 'TokenName' that represents the hash of the 'Stake' validator.
|
||||
validatorHashTN :: TokenName
|
||||
validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
|
||||
|
||||
buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext
|
||||
buildScriptContext inputs outputs =
|
||||
ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs = inputs
|
||||
, txInfoOutputs = outputs
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer]
|
||||
, txInfoData = []
|
||||
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
}
|
||||
, scriptContextPurpose =
|
||||
Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
|
||||
}
|
||||
234
agora-test/Spec/Sample/Proposal.hs
Normal file
234
agora-test/Spec/Sample/Proposal.hs
Normal file
|
|
@ -0,0 +1,234 @@
|
|||
{- |
|
||||
Module : Spec.Sample.Proposal
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Sample based testing for Proposal utxos
|
||||
|
||||
This module tests primarily the happy path for Proposal interactions
|
||||
-}
|
||||
module Spec.Sample.Proposal (
|
||||
-- * Script contexts
|
||||
proposalCreation,
|
||||
cosignProposal,
|
||||
proposalRef,
|
||||
stakeRef,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Plutarch.Api.V1 (
|
||||
validatorHash,
|
||||
)
|
||||
import Plutus.V1.Ledger.Api (
|
||||
Address (Address),
|
||||
Credential (ScriptCredential),
|
||||
Datum (Datum),
|
||||
PubKeyHash,
|
||||
ScriptContext (..),
|
||||
ScriptPurpose (..),
|
||||
ToData (toBuiltinData),
|
||||
TxInInfo (TxInInfo),
|
||||
TxInfo (..),
|
||||
TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
|
||||
TxOutRef (TxOutRef),
|
||||
)
|
||||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Governor (
|
||||
GovernorDatum (GovernorDatum, nextProposalId, proposalThresholds),
|
||||
)
|
||||
import Agora.Proposal (
|
||||
Proposal (..),
|
||||
ProposalDatum (..),
|
||||
ProposalId (..),
|
||||
ProposalStatus (..),
|
||||
ResultTag (..),
|
||||
emptyVotesFor,
|
||||
)
|
||||
import Agora.Stake (Stake (..), StakeDatum (StakeDatum))
|
||||
import Plutarch.SafeMoney (Tagged (Tagged), untag)
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Spec.Sample.Shared
|
||||
import Spec.Util (datumPair, toDatumHash)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | This script context should be a valid transaction.
|
||||
proposalCreation :: ScriptContext
|
||||
proposalCreation =
|
||||
let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
|
||||
effects =
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, [])
|
||||
, (ResultTag 1, [])
|
||||
]
|
||||
proposalDatum :: Datum
|
||||
proposalDatum =
|
||||
Datum
|
||||
( toBuiltinData $
|
||||
ProposalDatum
|
||||
{ proposalId = ProposalId 0
|
||||
, effects = effects
|
||||
, status = Draft
|
||||
, cosigners = [signer]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = emptyVotesFor effects
|
||||
}
|
||||
)
|
||||
|
||||
govBefore :: Datum
|
||||
govBefore =
|
||||
Datum
|
||||
( toBuiltinData $
|
||||
GovernorDatum
|
||||
{ proposalThresholds = defaultProposalThresholds
|
||||
, nextProposalId = ProposalId 0
|
||||
}
|
||||
)
|
||||
govAfter :: Datum
|
||||
govAfter =
|
||||
Datum
|
||||
( toBuiltinData $
|
||||
GovernorDatum
|
||||
{ proposalThresholds = defaultProposalThresholds
|
||||
, nextProposalId = ProposalId 1
|
||||
}
|
||||
)
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo =
|
||||
TxInfo
|
||||
{ txInfoInputs =
|
||||
[ TxInInfo
|
||||
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing
|
||||
, txOutValue = Value.assetClassValue proposal.governorSTAssetClass 1
|
||||
, txOutDatumHash = Just (toDatumHash govBefore)
|
||||
}
|
||||
]
|
||||
, txInfoOutputs =
|
||||
[ TxOut
|
||||
{ txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ st
|
||||
, Value.singleton "" "" 10_000_000
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash proposalDatum)
|
||||
}
|
||||
, TxOut
|
||||
{ txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ Value.assetClassValue proposal.governorSTAssetClass 1
|
||||
, Value.singleton "" "" 10_000_000
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash govAfter)
|
||||
}
|
||||
]
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = st
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = [signer]
|
||||
, txInfoData =
|
||||
[ datumPair proposalDatum
|
||||
, datumPair govBefore
|
||||
, datumPair govAfter
|
||||
]
|
||||
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
}
|
||||
, scriptContextPurpose = Minting proposalPolicySymbol
|
||||
}
|
||||
|
||||
proposalRef :: TxOutRef
|
||||
proposalRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1
|
||||
|
||||
stakeRef :: TxOutRef
|
||||
stakeRef = TxOutRef "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" 0
|
||||
|
||||
-- | This script context should be a valid transaction.
|
||||
cosignProposal :: [PubKeyHash] -> TxInfo
|
||||
cosignProposal newSigners =
|
||||
let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
|
||||
effects =
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, [])
|
||||
, (ResultTag 1, [])
|
||||
]
|
||||
proposalBefore :: ProposalDatum
|
||||
proposalBefore =
|
||||
ProposalDatum
|
||||
{ proposalId = ProposalId 0
|
||||
, effects = effects
|
||||
, status = Draft
|
||||
, cosigners = [signer]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = emptyVotesFor effects
|
||||
}
|
||||
stakeDatum :: StakeDatum
|
||||
stakeDatum = StakeDatum (Tagged 50_000_000) signer2 []
|
||||
proposalAfter :: ProposalDatum
|
||||
proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
|
||||
in TxInfo
|
||||
{ txInfoInputs =
|
||||
[ TxInInfo
|
||||
proposalRef
|
||||
TxOut
|
||||
{ txOutAddress = proposalValidatorAddress
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ st
|
||||
, Value.singleton "" "" 10_000_000
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash proposalBefore)
|
||||
}
|
||||
, TxInInfo
|
||||
stakeRef
|
||||
TxOut
|
||||
{ txOutAddress = stakeAddress
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ Value.singleton "" "" 10_000_000
|
||||
, Value.assetClassValue (untag stake.gtClassRef) 50_000_000
|
||||
, Value.singleton stakeSymbol "" 1
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash stakeDatum)
|
||||
}
|
||||
]
|
||||
, txInfoOutputs =
|
||||
[ TxOut
|
||||
{ txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ st
|
||||
, Value.singleton "" "" 10_000_000
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter)
|
||||
}
|
||||
, TxOut
|
||||
{ txOutAddress = stakeAddress
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ Value.singleton "" "" 10_000_000
|
||||
, Value.assetClassValue (untag stake.gtClassRef) 50_000_000
|
||||
, Value.singleton stakeSymbol "" 1
|
||||
]
|
||||
, txOutDatumHash = Just (toDatumHash stakeDatum)
|
||||
}
|
||||
]
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = st
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoSignatories = newSigners
|
||||
, txInfoData =
|
||||
[ datumPair . Datum $ toBuiltinData proposalBefore
|
||||
, datumPair . Datum $ toBuiltinData proposalAfter
|
||||
, datumPair . Datum $ toBuiltinData stakeDatum
|
||||
]
|
||||
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
}
|
||||
133
agora-test/Spec/Sample/Shared.hs
Normal file
133
agora-test/Spec/Sample/Shared.hs
Normal file
|
|
@ -0,0 +1,133 @@
|
|||
{- |
|
||||
Module : Spec.Sample.Shared
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Shared useful values for creating Samples for testing.
|
||||
|
||||
Shared useful values for creating Samples for testing.
|
||||
-}
|
||||
module Spec.Sample.Shared (
|
||||
-- * Misc
|
||||
signer,
|
||||
signer2,
|
||||
|
||||
-- * Components
|
||||
|
||||
-- ** Stake
|
||||
stake,
|
||||
stakeSymbol,
|
||||
stakeValidatorHash,
|
||||
stakeAddress,
|
||||
|
||||
-- ** Governor
|
||||
governor,
|
||||
govPolicy,
|
||||
govValidator,
|
||||
govSymbol,
|
||||
|
||||
-- ** Proposal
|
||||
defaultProposalThresholds,
|
||||
proposal,
|
||||
proposalPolicySymbol,
|
||||
proposalValidatorHash,
|
||||
proposalValidatorAddress,
|
||||
) where
|
||||
|
||||
import Agora.Governor (
|
||||
Governor (Governor),
|
||||
governorPolicy,
|
||||
governorValidator,
|
||||
)
|
||||
import Agora.Proposal (
|
||||
Proposal (..),
|
||||
ProposalThresholds (..),
|
||||
)
|
||||
import Agora.Proposal.Scripts (
|
||||
proposalPolicy,
|
||||
proposalValidator,
|
||||
)
|
||||
import Agora.Stake (Stake (..))
|
||||
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
|
||||
import Plutarch.Api.V1 (
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
mkValidator,
|
||||
validatorHash,
|
||||
)
|
||||
import Plutarch.SafeMoney
|
||||
import Plutus.V1.Ledger.Address (scriptHashAddress)
|
||||
import Plutus.V1.Ledger.Api (
|
||||
Address (Address),
|
||||
Credential (ScriptCredential),
|
||||
CurrencySymbol,
|
||||
MintingPolicy (..),
|
||||
PubKeyHash,
|
||||
)
|
||||
import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
stake :: Stake
|
||||
stake =
|
||||
Stake
|
||||
{ gtClassRef =
|
||||
Tagged $
|
||||
Value.assetClass
|
||||
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
|
||||
"LQ"
|
||||
, proposalSTClass = Value.assetClass proposalPolicySymbol ""
|
||||
}
|
||||
|
||||
stakeSymbol :: CurrencySymbol
|
||||
stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef
|
||||
|
||||
stakeValidatorHash :: ValidatorHash
|
||||
stakeValidatorHash = validatorHash $ mkValidator (stakeValidator stake)
|
||||
|
||||
stakeAddress :: Address
|
||||
stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
|
||||
|
||||
governor :: Governor
|
||||
governor = Governor
|
||||
|
||||
govPolicy :: MintingPolicy
|
||||
govPolicy = mkMintingPolicy (governorPolicy governor)
|
||||
|
||||
govValidator :: Validator
|
||||
govValidator = mkValidator (governorValidator governor)
|
||||
|
||||
govSymbol :: CurrencySymbol
|
||||
govSymbol = mintingPolicySymbol govPolicy
|
||||
|
||||
proposal :: Proposal
|
||||
proposal =
|
||||
Proposal
|
||||
{ governorSTAssetClass = Value.assetClass govSymbol ""
|
||||
, stakeSTAssetClass = Value.assetClass stakeSymbol ""
|
||||
, maximumCosigners = 6
|
||||
}
|
||||
|
||||
proposalPolicySymbol :: CurrencySymbol
|
||||
proposalPolicySymbol = mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
|
||||
|
||||
-- | A sample 'PubKeyHash'.
|
||||
signer :: PubKeyHash
|
||||
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
|
||||
|
||||
-- | Another sample 'PubKeyHash'.
|
||||
signer2 :: PubKeyHash
|
||||
signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
|
||||
|
||||
proposalValidatorHash :: ValidatorHash
|
||||
proposalValidatorHash = validatorHash (mkValidator $ proposalValidator proposal)
|
||||
|
||||
proposalValidatorAddress :: Address
|
||||
proposalValidatorAddress = scriptHashAddress proposalValidatorHash
|
||||
|
||||
defaultProposalThresholds :: ProposalThresholds
|
||||
defaultProposalThresholds =
|
||||
ProposalThresholds
|
||||
{ countVoting = Tagged 1000
|
||||
, create = Tagged 1
|
||||
, startVoting = Tagged 10
|
||||
}
|
||||
|
|
@ -7,8 +7,7 @@ This module tests primarily the happy path for Stake creation
|
|||
-}
|
||||
module Spec.Sample.Stake (
|
||||
stake,
|
||||
policy,
|
||||
policySymbol,
|
||||
stakeSymbol,
|
||||
validatorHashTN,
|
||||
signer,
|
||||
|
||||
|
|
@ -22,19 +21,14 @@ module Spec.Sample.Stake (
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
import Plutarch.Api.V1 (
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
mkValidator,
|
||||
validatorHash,
|
||||
)
|
||||
import Plutus.V1.Ledger.Api (
|
||||
Address (Address),
|
||||
Credential (ScriptCredential),
|
||||
CurrencySymbol,
|
||||
Datum (Datum),
|
||||
DatumHash (DatumHash),
|
||||
MintingPolicy (..),
|
||||
PubKeyHash,
|
||||
ScriptContext (..),
|
||||
ScriptPurpose (..),
|
||||
ToData (toBuiltinData),
|
||||
|
|
@ -45,55 +39,28 @@ 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 (AssetClass (AssetClass), TokenName (TokenName))
|
||||
import Plutus.V1.Ledger.Value (TokenName (TokenName))
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Plutarch.SafeMoney
|
||||
import Spec.Sample.Shared
|
||||
import Spec.Util (datumPair, toDatumHash)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | 'Stake' parameters for 'LQ'.
|
||||
stake :: Stake
|
||||
stake =
|
||||
Stake
|
||||
{ gtClassRef =
|
||||
Tagged
|
||||
( AssetClass
|
||||
( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
|
||||
, "LQ"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
-- | 'Stake' policy instance.
|
||||
policy :: MintingPolicy
|
||||
policy = mkMintingPolicy (stakePolicy stake)
|
||||
|
||||
policySymbol :: CurrencySymbol
|
||||
policySymbol = mintingPolicySymbol policy
|
||||
|
||||
-- | A sample 'PubKeyHash'.
|
||||
signer :: PubKeyHash
|
||||
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
|
||||
|
||||
-- | 'Stake' validator instance.
|
||||
validator :: Validator
|
||||
validator = mkValidator (stakeValidator stake)
|
||||
|
||||
-- | 'TokenName' that represents the hash of the 'Stake' validator.
|
||||
validatorHashTN :: TokenName
|
||||
validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
|
||||
validatorHashTN = let ValidatorHash vh = validatorHash (mkValidator $ stakeValidator stake) in TokenName vh
|
||||
|
||||
-- | This script context should be a valid transaction.
|
||||
stakeCreation :: ScriptContext
|
||||
stakeCreation =
|
||||
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
|
||||
let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST
|
||||
datum :: Datum
|
||||
datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
|
||||
in ScriptContext
|
||||
|
|
@ -102,7 +69,7 @@ stakeCreation =
|
|||
{ txInfoInputs = []
|
||||
, txInfoOutputs =
|
||||
[ TxOut
|
||||
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
|
||||
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
|
||||
, txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242
|
||||
, txOutDatumHash = Just (DatumHash "")
|
||||
}
|
||||
|
|
@ -116,7 +83,7 @@ stakeCreation =
|
|||
, txInfoData = [("", datum)]
|
||||
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
}
|
||||
, scriptContextPurpose = Minting policySymbol
|
||||
, scriptContextPurpose = Minting stakeSymbol
|
||||
}
|
||||
|
||||
-- | This ScriptContext should fail because the datum has too much GT.
|
||||
|
|
@ -126,7 +93,7 @@ stakeCreationWrongDatum =
|
|||
datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
|
||||
in ScriptContext
|
||||
{ scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
|
||||
, scriptContextPurpose = Minting policySymbol
|
||||
, scriptContextPurpose = Minting stakeSymbol
|
||||
}
|
||||
|
||||
-- | This ScriptContext should fail because the datum has too much GT.
|
||||
|
|
@ -137,7 +104,7 @@ stakeCreationUnsigned =
|
|||
stakeCreation.scriptContextTxInfo
|
||||
{ txInfoSignatories = []
|
||||
}
|
||||
, scriptContextPurpose = Minting policySymbol
|
||||
, scriptContextPurpose = Minting stakeSymbol
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -153,7 +120,7 @@ data DepositWithdrawExample = DepositWithdrawExample
|
|||
-- | Create a ScriptContext that deposits or withdraws, given the config for it.
|
||||
stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
|
||||
stakeDepositWithdraw config =
|
||||
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
|
||||
let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST
|
||||
stakeBefore :: StakeDatum
|
||||
stakeBefore = StakeDatum config.startAmount signer []
|
||||
|
||||
|
|
@ -166,7 +133,7 @@ stakeDepositWithdraw config =
|
|||
[ TxInInfo
|
||||
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
|
||||
TxOut
|
||||
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
|
||||
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
|
||||
, txOutValue =
|
||||
st
|
||||
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
|
||||
|
|
@ -175,10 +142,9 @@ stakeDepositWithdraw config =
|
|||
]
|
||||
, txInfoOutputs =
|
||||
[ TxOut
|
||||
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
|
||||
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
|
||||
, txOutValue =
|
||||
st
|
||||
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
|
||||
st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
|
||||
, txOutDatumHash = Just (toDatumHash stakeAfter)
|
||||
}
|
||||
]
|
||||
|
|
|
|||
|
|
@ -19,7 +19,8 @@ import Test.Tasty (TestTree, testGroup)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator)
|
||||
import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw))
|
||||
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -36,20 +37,23 @@ tests =
|
|||
"policy"
|
||||
[ policySucceedsWith
|
||||
"stakeCreation"
|
||||
(stakePolicy Stake.stake)
|
||||
(stakePolicy Stake.stake.gtClassRef)
|
||||
()
|
||||
Stake.stakeCreation
|
||||
, policyFailsWith
|
||||
"stakeCreationWrongDatum"
|
||||
(stakePolicy Stake.stake)
|
||||
(stakePolicy Stake.stake.gtClassRef)
|
||||
()
|
||||
Stake.stakeCreationWrongDatum
|
||||
, policyFailsWith
|
||||
"stakeCreationUnsigned"
|
||||
(stakePolicy Stake.stake)
|
||||
(stakePolicy Stake.stake.gtClassRef)
|
||||
()
|
||||
Stake.stakeCreationUnsigned
|
||||
, validatorSucceedsWith
|
||||
]
|
||||
, testGroup
|
||||
"validator"
|
||||
[ validatorSucceedsWith
|
||||
"stakeDepositWithdraw deposit"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer [])
|
||||
|
|
|
|||
|
|
@ -13,6 +13,8 @@ module Spec.Util (
|
|||
policyFailsWith,
|
||||
validatorSucceedsWith,
|
||||
validatorFailsWith,
|
||||
effectSucceedsWith,
|
||||
effectFailsWith,
|
||||
|
||||
-- * Plutus-land utils
|
||||
datumHash,
|
||||
|
|
@ -98,10 +100,10 @@ validatorSucceedsWith ::
|
|||
PLifted redeemer ->
|
||||
ScriptContext ->
|
||||
TestTree
|
||||
validatorSucceedsWith tag policy datum redeemer scriptContext =
|
||||
validatorSucceedsWith tag validator datum redeemer scriptContext =
|
||||
scriptSucceeds tag $
|
||||
compile
|
||||
( policy
|
||||
( validator
|
||||
# pforgetData (pconstantData datum)
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
|
|
@ -120,15 +122,39 @@ validatorFailsWith ::
|
|||
PLifted redeemer ->
|
||||
ScriptContext ->
|
||||
TestTree
|
||||
validatorFailsWith tag policy datum redeemer scriptContext =
|
||||
validatorFailsWith tag validator datum redeemer scriptContext =
|
||||
scriptFails tag $
|
||||
compile
|
||||
( policy
|
||||
( validator
|
||||
# pforgetData (pconstantData datum)
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
)
|
||||
|
||||
-- | Check that a validator script succeeds, given a name and arguments.
|
||||
effectSucceedsWith ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
ScriptContext ->
|
||||
TestTree
|
||||
effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
|
||||
|
||||
-- | Check that a validator script fails, given a name and arguments.
|
||||
effectFailsWith ::
|
||||
( PLift datum
|
||||
, PlutusTx.ToData (PLifted datum)
|
||||
) =>
|
||||
String ->
|
||||
ClosedTerm PValidator ->
|
||||
PLifted datum ->
|
||||
ScriptContext ->
|
||||
TestTree
|
||||
effectFailsWith tag eff datum = validatorFailsWith tag eff datum ()
|
||||
|
||||
-- | Check that an arbitrary script doesn't error when evaluated, given a name.
|
||||
scriptSucceeds :: String -> Script -> TestTree
|
||||
scriptSucceeds name script = testCase name $ do
|
||||
|
|
|
|||
14
agora.cabal
14
agora.cabal
|
|
@ -60,6 +60,7 @@ common lang
|
|||
NamedFieldPuns
|
||||
NamedWildCards
|
||||
NumericUnderscores
|
||||
OverloadedLabels
|
||||
OverloadedStrings
|
||||
PartialTypeSignatures
|
||||
PatternGuards
|
||||
|
|
@ -123,11 +124,17 @@ library
|
|||
exposed-modules:
|
||||
Agora.AuthorityToken
|
||||
Agora.Effect
|
||||
Agora.Effect.NoOp
|
||||
Agora.Effect.TreasuryWithdrawal
|
||||
Agora.Governor
|
||||
Agora.MultiSig
|
||||
Agora.Proposal
|
||||
Agora.Proposal.Scripts
|
||||
Agora.Proposal.Time
|
||||
Agora.Record
|
||||
Agora.SafeMoney
|
||||
Agora.Stake
|
||||
Agora.Stake.Scripts
|
||||
Agora.Treasury
|
||||
|
||||
other-modules:
|
||||
|
|
@ -151,8 +158,13 @@ test-suite agora-test
|
|||
main-is: Spec.hs
|
||||
hs-source-dirs: agora-test
|
||||
other-modules:
|
||||
Spec.AuthorityToken
|
||||
Spec.Effect.TreasuryWithdrawal
|
||||
Spec.Model.MultiSig
|
||||
Spec.Model.Treasury
|
||||
Spec.Proposal
|
||||
Spec.Sample.Effect.TreasuryWithdrawal
|
||||
Spec.Sample.Proposal
|
||||
Spec.Sample.Shared
|
||||
Spec.Sample.Stake
|
||||
Spec.Sample.Treasury
|
||||
Spec.Stake
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@
|
|||
Module : Agora.AuthorityToken
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Tokens acting as redeemable proofs of DAO authority.
|
||||
|
||||
Tokens acting as redeemable proofs of DAO authority.
|
||||
-}
|
||||
module Agora.AuthorityToken (
|
||||
|
|
@ -18,30 +17,28 @@ import Plutarch.Api.V1 (
|
|||
PCurrencySymbol (..),
|
||||
PScriptContext (..),
|
||||
PScriptPurpose (..),
|
||||
PTxInInfo (..),
|
||||
PTxInInfo (PTxInInfo),
|
||||
PTxInfo (..),
|
||||
PTxOut (..),
|
||||
)
|
||||
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
|
||||
import Plutus.V1.Ledger.Value (AssetClass)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Utils (
|
||||
allInputs,
|
||||
allOutputs,
|
||||
passert,
|
||||
passetClassValueOf,
|
||||
passetClassValueOf',
|
||||
plookup,
|
||||
psymbolValueOf,
|
||||
ptokenSpent,
|
||||
)
|
||||
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -64,53 +61,35 @@ newtype AuthorityToken = AuthorityToken
|
|||
the script address the token resides in matches the TokenName.
|
||||
Since the TokenName was tagged upon mint with the Effect script
|
||||
it was sent to, this is enough to prove validity.
|
||||
|
||||
In other words, check that all assets of a particular currency symbol
|
||||
are tagged with a TokenName that matches where they live.
|
||||
-}
|
||||
authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool)
|
||||
authorityTokensValidIn = phoistAcyclic $ -- /Lift/ the `Term`.
|
||||
authorityTokensValidIn = phoistAcyclic $
|
||||
plam $ \authorityTokenSym txOut'' -> P.do
|
||||
-- Extract the desired fields: address and value, from the
|
||||
-- transaction output info.
|
||||
PTxOut txOut' <- pmatch txOut''
|
||||
txOut <- pletFields @'["address", "value"] $ txOut'
|
||||
PAddress address <- pmatch txOut.address
|
||||
PValue value' <- pmatch txOut.value
|
||||
PMap value <- pmatch value'
|
||||
|
||||
-- Search the transaction output info's value for the
|
||||
-- provided currency symbol for the authority token.
|
||||
pmatch (plookup # pdata authorityTokenSym # value) $ \case
|
||||
-- In the case of `PNothing`, no GATs exist at this output
|
||||
-- and ipso facto they are all valid.
|
||||
PNothing -> pconstant True
|
||||
-- This is the case wherein a TokenName/Integer map /has/
|
||||
-- been found for the given currency symbol.
|
||||
PJust (pfromData -> tokenMap') ->
|
||||
-- Now we need to look at the transaction output's
|
||||
-- address.
|
||||
pmatch (pfield @"credential" # address) $ \case
|
||||
-- GATs should only be sent to Effect validators,
|
||||
-- therefore we consider this invalid and return False.
|
||||
PPubKeyCredential _ -> pconstant False
|
||||
-- This is a script address. We need to ensure that
|
||||
-- the the `TokenName`s associated with the given
|
||||
-- currency symbol are all equal to this script
|
||||
-- address.
|
||||
PPubKeyCredential _ ->
|
||||
-- GATs should only be sent to Effect validators
|
||||
ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False
|
||||
PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> P.do
|
||||
-- Unwrap the `TokenName`/`Integer` map.
|
||||
PMap tokenMap <- pmatch tokenMap'
|
||||
|
||||
-- Check that the `TokenName` is equal to the validator
|
||||
-- hash for all of the `TokenName` keys in the map.
|
||||
pall
|
||||
# plam
|
||||
( \tnMap ->
|
||||
pforgetData (pfstBuiltin # tnMap)
|
||||
#== pforgetData (pdata cred)
|
||||
)
|
||||
# tokenMap
|
||||
ptraceIfFalse "authorityTokensValidIn: GAT TokenName doesn't match ScriptHash" $
|
||||
pall
|
||||
# plam
|
||||
( \pair ->
|
||||
pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred)
|
||||
)
|
||||
# tokenMap
|
||||
PNothing ->
|
||||
-- No GATs exist at this output!
|
||||
pconstant True
|
||||
|
||||
-- | Assert that a single authority token has been burned.
|
||||
singleAuthorityTokenBurned ::
|
||||
|
|
@ -123,14 +102,20 @@ singleAuthorityTokenBurned gatCs txInfo mint = P.do
|
|||
let gatAmountMinted :: Term _ PInteger
|
||||
gatAmountMinted = psymbolValueOf # gatCs # mint
|
||||
|
||||
txInfoF <- pletFields @'["inputs"] $ txInfo
|
||||
|
||||
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
|
||||
[ ptraceIfFalse "singleAuthorityTokenBurned: Must burn exactly 1 GAT" $ gatAmountMinted #== -1
|
||||
, ptraceIfFalse "singleAuthorityTokenBurned: All GAT tokens must be valid at the inputs" $
|
||||
pall
|
||||
# plam
|
||||
( \txInInfo' -> P.do
|
||||
PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
|
||||
let txOut' = pfield @"resolved" # txInInfo
|
||||
authorityTokensValidIn # gatCs # pfromData txOut'
|
||||
)
|
||||
# txInfoF.inputs
|
||||
]
|
||||
|
||||
-- | Policy given 'AuthorityToken' params.
|
||||
|
|
@ -144,28 +129,21 @@ authorityTokenPolicy params =
|
|||
PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
|
||||
txInfo <- pletFields @'["inputs", "mint"] txInfo'
|
||||
let inputs = txInfo.inputs
|
||||
let authorityTokenInputs =
|
||||
pfoldr' @PBuiltinList
|
||||
( \txInInfo' acc -> P.do
|
||||
PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
|
||||
PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
|
||||
txOut <- pletFields @'["value"] txOut'
|
||||
let txOutValue = pfromData txOut.value
|
||||
passetClassValueOf' params.authority # txOutValue + acc
|
||||
)
|
||||
# 0
|
||||
# inputs
|
||||
let mintedValue = pfromData txInfo.mint
|
||||
let tokenMoved = 0 #< authorityTokenInputs
|
||||
mintedValue = pfromData txInfo.mint
|
||||
AssetClass (govCs, govTn) = params.authority
|
||||
govAc = passetClass # pconstant govCs # pconstant govTn
|
||||
govTokenSpent = ptokenSpent # govAc # inputs
|
||||
|
||||
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
|
||||
|
||||
let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
|
||||
let mintedATs = passetClassValueOf # ownSymbol # pconstant "" # mintedValue
|
||||
mintedATs = passetClassValueOf # mintedValue # (passetClass # ownSymbol # pconstant "")
|
||||
pif
|
||||
(0 #< mintedATs)
|
||||
( P.do
|
||||
passert "Parent token did not move in minting GATs" tokenMoved
|
||||
passert "Parent token did not move in minting GATs" govTokenSpent
|
||||
passert "All outputs only emit valid GATs" $
|
||||
allOutputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
|
||||
allOutputs @PData # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
|
||||
authorityTokensValidIn
|
||||
# ownSymbol
|
||||
# txOut
|
||||
|
|
|
|||
|
|
@ -5,17 +5,13 @@ Description: Helpers for constructing effects
|
|||
|
||||
Helpers for constructing effects.
|
||||
-}
|
||||
module Agora.Effect (
|
||||
makeEffect,
|
||||
noopEffect,
|
||||
) where
|
||||
module Agora.Effect (makeEffect) 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 Plutarch.TryFrom (PTryFrom, ptryFrom)
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -28,7 +24,7 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
|
|||
-}
|
||||
makeEffect ::
|
||||
forall (datum :: PType).
|
||||
PIsData datum =>
|
||||
(PIsData datum, PTryFrom PData datum) =>
|
||||
CurrencySymbol ->
|
||||
(forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
|
||||
ClosedTerm PValidator
|
||||
|
|
@ -37,29 +33,24 @@ makeEffect gatCs' f =
|
|||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
|
||||
-- TODO: Use PTryFrom
|
||||
let datum' :: Term _ datum
|
||||
datum' = pfromData $ punsafeCoerce datum
|
||||
-- convert input datum, PData, into desierable type
|
||||
-- the way this conversion is performed should be defined
|
||||
-- by PTryFrom for each datum in effect script.
|
||||
(datum', _) <- ptryFrom @datum datum
|
||||
|
||||
-- ensure purpose is Spending.
|
||||
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
|
||||
txOutRef' <- plet (pfield @"_0" # txOutRef)
|
||||
|
||||
-- fetch minted values to ensure single GAT is burned
|
||||
txInfo <- pletFields @'["mint"] txInfo'
|
||||
let mint :: Term _ PValue
|
||||
mint = txInfo.mint
|
||||
|
||||
-- fetch script context
|
||||
gatCs <- plet $ pconstant gatCs'
|
||||
|
||||
passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
|
||||
|
||||
-- run effect function
|
||||
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 ())
|
||||
)
|
||||
|
|
|
|||
33
agora/Agora/Effect/NoOp.hs
Normal file
33
agora/Agora/Effect/NoOp.hs
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
{- |
|
||||
Module : Agora.Effect.NoOp
|
||||
Maintainer : seungheon.ooh@gmail.com
|
||||
Description: Dummy dumb dumb effect.
|
||||
|
||||
A dumb effect that only burns its GAT.
|
||||
-}
|
||||
module Agora.Effect.NoOp (noOpValidator, PNoOp) where
|
||||
|
||||
import Control.Applicative (Const)
|
||||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Plutarch.Api.V1 (PValidator)
|
||||
import Plutarch.TryFrom (PTryFrom (..))
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
|
||||
-- | Dummy datum for NoOp effect.
|
||||
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
|
||||
deriving (PlutusType, PIsData) via (DerivePNewtype PNoOp PUnit)
|
||||
|
||||
instance PTryFrom PData PNoOp where
|
||||
type PTryFromExcess PData PNoOp = Const ()
|
||||
ptryFrom' _ cont =
|
||||
-- JUSTIFICATION:
|
||||
-- We don't care anything about data.
|
||||
-- It should always be reduced to Unit.
|
||||
cont (pcon $ PNoOp (pconstant ()), ())
|
||||
|
||||
-- | Dummy effect which can only burn its GAT.
|
||||
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
|
||||
noOpValidator curr = makeEffect curr $
|
||||
\_ (_datum :: Term s PNoOp) _ _ -> P.do
|
||||
popaque (pconstant ())
|
||||
176
agora/Agora/Effect/TreasuryWithdrawal.hs
Normal file
176
agora/Agora/Effect/TreasuryWithdrawal.hs
Normal file
|
|
@ -0,0 +1,176 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.Effect.TreasuryWithdrawal
|
||||
Maintainer : seungheon.ooh@gmail.com
|
||||
Description: An Effect that withdraws treasury deposit
|
||||
|
||||
An Effect that withdraws treasury deposit
|
||||
-}
|
||||
module Agora.Effect.TreasuryWithdrawal (
|
||||
TreasuryWithdrawalDatum (..),
|
||||
PTreasuryWithdrawalDatum (..),
|
||||
treasuryWithdrawalValidator,
|
||||
) where
|
||||
|
||||
import Control.Applicative (Const)
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Agora.Utils (findTxOutByTxOutRef, paddValue, passert)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (..),
|
||||
PTuple,
|
||||
PValidator,
|
||||
PValue,
|
||||
ptuple,
|
||||
)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (..),
|
||||
)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.TryFrom (PTryFrom (..))
|
||||
import Plutus.V1.Ledger.Credential (Credential)
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
|
||||
import PlutusTx qualified
|
||||
|
||||
{- | Datum that encodes behavior of Treasury Withdrawal effect.
|
||||
|
||||
Note: This Datum acts like a "predefined redeemer". Which is to say that
|
||||
it encodes the properties a redeemer would, but is locked in-place until
|
||||
spend.
|
||||
-}
|
||||
data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
|
||||
{ receivers :: [(Credential, Value)]
|
||||
-- ^ AssocMap for Value sent to each receiver from the treasury.
|
||||
, treasuries :: [Credential]
|
||||
-- ^ What Credentials is spending from legal.
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
||||
PlutusTx.makeLift ''TreasuryWithdrawalDatum
|
||||
PlutusTx.makeIsDataIndexed ''TreasuryWithdrawalDatum [('TreasuryWithdrawalDatum, 0)]
|
||||
|
||||
-- | Haskell-level version of 'TreasuryWithdrawalDatum'.
|
||||
newtype PTreasuryWithdrawalDatum (s :: S)
|
||||
= PTreasuryWithdrawalDatum
|
||||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))
|
||||
, "treasuries" ':= PBuiltinList (PAsData PCredential)
|
||||
]
|
||||
)
|
||||
)
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic, PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via PIsDataReprInstances PTreasuryWithdrawalDatum
|
||||
|
||||
instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
|
||||
type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum
|
||||
|
||||
deriving via
|
||||
(DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
|
||||
instance
|
||||
(PConstantDecl TreasuryWithdrawalDatum)
|
||||
|
||||
instance PTryFrom PData PTreasuryWithdrawalDatum where
|
||||
type PTryFromExcess PData PTreasuryWithdrawalDatum = Const ()
|
||||
ptryFrom' opq cont =
|
||||
-- TODO: This should not use 'punsafeCoerce'.
|
||||
-- Blocked by 'PCredential', and 'PTuple'.
|
||||
cont (punsafeCoerce opq, ())
|
||||
|
||||
{- | Withdraws given list of values to specific target addresses.
|
||||
It can be evoked by burning GAT. The transaction should have correct
|
||||
outputs to the users and any left overs should be paid back to the treasury.
|
||||
|
||||
The validator does not accept any Redeemer as all "parameters" are provided
|
||||
via encoded Datum.
|
||||
|
||||
Note:
|
||||
It should check...
|
||||
1. Transaction outputs should contain all of what Datum specified
|
||||
2. Left over assets should be redirected back to Treasury
|
||||
It can be more flexiable over...
|
||||
- The number of outputs themselves
|
||||
-}
|
||||
treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
|
||||
treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
|
||||
\_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
|
||||
datum <- pletFields @'["receivers", "treasuries"] datum'
|
||||
txInfo <- pletFields @'["outputs", "inputs"] txInfo'
|
||||
PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo.inputs
|
||||
effInput <- pletFields @'["address", "value"] $ txOut
|
||||
outputValues <-
|
||||
plet $
|
||||
pmap
|
||||
# plam
|
||||
( \(pfromData -> txOut') -> P.do
|
||||
txOut <- pletFields @'["address", "value"] $ txOut'
|
||||
let cred = pfield @"credential" # pfromData txOut.address
|
||||
pdata $ ptuple # cred # txOut.value
|
||||
)
|
||||
# txInfo.outputs
|
||||
inputValues <-
|
||||
plet $
|
||||
pmap
|
||||
# plam
|
||||
( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do
|
||||
txOut <- pletFields @'["address", "value"] $ txOut'
|
||||
let cred = pfield @"credential" # pfromData txOut.address
|
||||
pdata $ ptuple # cred # txOut.value
|
||||
)
|
||||
# txInfo.inputs
|
||||
let ofTreasury =
|
||||
pfilter
|
||||
# plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
|
||||
sumValues =
|
||||
pfoldr
|
||||
# plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
|
||||
# pconstant (mempty :: Value)
|
||||
treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
|
||||
treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
|
||||
receiverValuesSum = sumValues # datum.receivers
|
||||
isPubkey = plam $ \cred -> P.do
|
||||
pmatch cred $ \case
|
||||
PPubKeyCredential _ -> pcon PTrue
|
||||
PScriptCredential _ -> pcon PFalse
|
||||
|
||||
-- Constraints
|
||||
outputContentMatchesRecivers =
|
||||
pall # plam (\out -> pelem # out # outputValues)
|
||||
#$ datum.receivers
|
||||
excessShouldBePaidToInputs =
|
||||
pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum
|
||||
shouldNotPayToEffect =
|
||||
pnot #$ pany
|
||||
# plam
|
||||
( \x ->
|
||||
effInput.address #== pfield @"address" # pfromData x
|
||||
)
|
||||
# pfromData txInfo.outputs
|
||||
inputsAreOnlyTreasuriesOrCollateral =
|
||||
pall
|
||||
# plam
|
||||
( \((pfield @"_0" #) . pfromData -> cred) ->
|
||||
cred #== pfield @"credential" # effInput.address
|
||||
#|| pelem # cred # datum.treasuries
|
||||
#|| isPubkey # pfromData cred
|
||||
)
|
||||
# inputValues
|
||||
|
||||
passert "Transaction should not pay to effects" shouldNotPayToEffect
|
||||
passert "Transaction output does not match receivers" outputContentMatchesRecivers
|
||||
passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
|
||||
passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuriesOrCollateral
|
||||
popaque $ pconstant ()
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.Governor
|
||||
Maintainer : emi@haskell.fyi
|
||||
|
|
@ -19,8 +21,8 @@ module Agora.Governor (
|
|||
) where
|
||||
|
||||
import Agora.Proposal (ProposalId, ProposalThresholds)
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Api.V1 (PMintingPolicy, PValidator)
|
||||
import PlutusTx qualified
|
||||
|
||||
-- | Datum for the Governor script.
|
||||
data GovernorDatum = GovernorDatum
|
||||
|
|
@ -30,6 +32,8 @@ data GovernorDatum = GovernorDatum
|
|||
-- ^ What tag the next proposal will get upon creating.
|
||||
}
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
|
||||
|
||||
{- | Redeemer for Governor script. The governor has two primary
|
||||
responsibilities:
|
||||
|
||||
|
|
@ -43,6 +47,8 @@ data GovernorRedeemer
|
|||
-- and allows minting GATs for each effect script.
|
||||
MintGATs
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''GovernorRedeemer [('CreateProposal, 0), ('MintGATs, 1)]
|
||||
|
||||
-- | Parameters for creating Governor scripts.
|
||||
data Governor
|
||||
= Governor
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ import Plutarch.DataRepr (
|
|||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Lift (
|
||||
PConstantDecl,
|
||||
PLifted,
|
||||
PUnsafeLiftDecl,
|
||||
)
|
||||
|
|
@ -73,7 +74,7 @@ newtype PMultiSig (s :: S) = PMultiSig
|
|||
via (PIsDataReprInstances PMultiSig)
|
||||
|
||||
instance PUnsafeLiftDecl PMultiSig where type PLifted PMultiSig = MultiSig
|
||||
deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstant MultiSig)
|
||||
deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstantDecl MultiSig)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -11,23 +11,25 @@ module Agora.Proposal (
|
|||
-- * Haskell-land
|
||||
Proposal (..),
|
||||
ProposalDatum (..),
|
||||
ProposalRedeemer (..),
|
||||
ProposalStatus (..),
|
||||
ProposalThresholds (..),
|
||||
ProposalVotes (..),
|
||||
ProposalId (..),
|
||||
ResultTag (..),
|
||||
emptyVotesFor,
|
||||
|
||||
-- * Plutarch-land
|
||||
PProposalDatum (..),
|
||||
PProposalRedeemer (..),
|
||||
PProposalStatus (..),
|
||||
PProposalThresholds (..),
|
||||
PProposalVotes (..),
|
||||
PProposalId (..),
|
||||
PResultTag (..),
|
||||
|
||||
-- * Scripts
|
||||
proposalValidator,
|
||||
proposalPolicy,
|
||||
-- * Plutarch helpers
|
||||
proposalDatumValid,
|
||||
) where
|
||||
|
||||
import GHC.Generics qualified as GHC
|
||||
|
|
@ -35,30 +37,44 @@ 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 Agora.Utils (pkeysEqual, pnotNull)
|
||||
import Control.Applicative (Const)
|
||||
import Control.Arrow (first)
|
||||
import Plutarch.Builtin (PBuiltinMap)
|
||||
import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..))
|
||||
import Plutarch.Lift (
|
||||
DerivePConstantViaNewtype (..),
|
||||
PConstantDecl,
|
||||
PUnsafeLiftDecl (..),
|
||||
)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.SafeMoney (PDiscrete, Tagged)
|
||||
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
|
||||
import Plutus.V1.Ledger.Value (AssetClass)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Haskell-land
|
||||
|
||||
{- | 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 @'ProposalId' 99@. This counter lives
|
||||
in the 'Agora.Governor.Governor'. See 'Agora.Governor.nextProposalId', and
|
||||
'Agora.Governor.pgetNextProposalId'.
|
||||
-}
|
||||
newtype ProposalId = ProposalId {proposalTag :: Integer}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
{- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
|
||||
|
||||
@
|
||||
|
|
@ -70,8 +86,10 @@ 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".
|
||||
{- | The "status" of the proposal. This is only useful for state transitions that
|
||||
need to happen as a result of a transaction as opposed to time-based "periods".
|
||||
|
||||
See the note on wording & the state machine in the tech-design.
|
||||
|
||||
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.
|
||||
|
|
@ -92,28 +110,39 @@ data ProposalStatus
|
|||
-- This means that once the timing requirements align,
|
||||
-- proposal will be able to be voted on.
|
||||
VotingReady
|
||||
| -- | The proposal has been voted on, and the votes have been locked
|
||||
-- permanently. The proposal now goes into a locking time after the
|
||||
-- normal voting time. After this, it's possible to execute the proposal.
|
||||
Locked
|
||||
| -- | 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
|
||||
-- the proposal failed due to time constraints or didn't
|
||||
-- get to 'VotingReady' first.
|
||||
--
|
||||
-- At this stage, the 'votes' field of 'ProposalDatum' is frozen.
|
||||
--
|
||||
-- See 'AdvanceProposal' for documentation on state transitions.
|
||||
--
|
||||
-- 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)]
|
||||
PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Locked, 2), ('Finished, 3)]
|
||||
|
||||
{- | The threshold values for various state transitions to happen.
|
||||
This data is stored centrally (in the 'Agora.Governor.Governor') and copied over
|
||||
to 'Proposal's when they are created.
|
||||
-}
|
||||
data ProposalThresholds = ProposalThresholds
|
||||
{ execute :: Tagged GTTag Integer
|
||||
{ countVoting :: Tagged GTTag Integer
|
||||
-- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass.
|
||||
, draft :: Tagged GTTag Integer
|
||||
, create :: Tagged GTTag Integer
|
||||
-- ^ How much GT required to "create" a proposal.
|
||||
, vote :: Tagged GTTag Integer
|
||||
--
|
||||
-- It is recommended this be a high enough amount, in order to prevent DOS from bad
|
||||
-- actors.
|
||||
, startVoting :: Tagged GTTag Integer
|
||||
-- ^ How much GT required to allow voting to happen.
|
||||
-- (i.e. to move into 'VotingReady')
|
||||
}
|
||||
|
|
@ -138,9 +167,15 @@ newtype ProposalVotes = ProposalVotes
|
|||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
-- | Create a 'ProposalVotes' that has the same shape as the 'effects' field.
|
||||
emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
|
||||
emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)
|
||||
|
||||
-- | Haskell-level datum for Proposal scripts.
|
||||
data ProposalDatum = ProposalDatum
|
||||
{ -- TODO: could we encode this more efficiently?
|
||||
{ proposalId :: ProposalId
|
||||
-- ^ Identification of the proposal.
|
||||
, -- 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 :: AssocMap.Map ResultTag [(ValidatorHash, DatumHash)]
|
||||
|
|
@ -158,17 +193,62 @@ data ProposalDatum = ProposalDatum
|
|||
|
||||
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 @'ProposalId' 99@.
|
||||
This counter lives in the 'Governor', see 'nextProposalId'.
|
||||
-}
|
||||
newtype ProposalId = ProposalId {proposalTag :: Integer}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
-- | Haskell-level redeemer for Proposal scripts.
|
||||
data ProposalRedeemer
|
||||
= -- | Cast one or more votes towards a particular 'ResultTag'.
|
||||
Vote ResultTag
|
||||
| -- | Add one or more public keys to the cosignature list.
|
||||
-- Must be signed by those cosigning.
|
||||
--
|
||||
-- This is particularly used in the 'Draft' 'ProposalStatus',
|
||||
-- where matching 'Agora.Stake.Stake's can be called to advance the proposal,
|
||||
-- provided enough GT is shared among them.
|
||||
Cosign [PubKeyHash]
|
||||
| -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
|
||||
Unlock ResultTag
|
||||
| -- | Advance the proposal, performing the required checks for whether that is legal.
|
||||
--
|
||||
-- These are roughly the checks for each possible transition:
|
||||
--
|
||||
-- === @'Draft' -> 'VotingReady'@:
|
||||
--
|
||||
-- 1. The sum of all of the cosigner's GT is larger than the 'startVoting' field of 'ProposalThresholds'.
|
||||
-- 2. The proposal's current time ensures 'isDraftPeriod'.
|
||||
--
|
||||
-- === @'VotingReady' -> 'Locked'@:
|
||||
--
|
||||
-- 1. The sum of all votes is larger than 'countVoting'.
|
||||
-- 2. The winning 'ResultTag' has more votes than all other 'ResultTag's.
|
||||
-- 3. The proposal's current time ensures 'isVotingPeriod'.
|
||||
--
|
||||
-- === @'Locked' -> 'Finished'@:
|
||||
--
|
||||
-- 1. The proposal's current time ensures 'isExecutionPeriod'.
|
||||
-- 2. The transaction mints the GATs to the receiving effects.
|
||||
--
|
||||
-- === @* -> 'Finished'@:
|
||||
--
|
||||
-- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible
|
||||
-- to transition into 'Finished' status, because it has expired (and failed).
|
||||
AdvanceProposal
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
''ProposalRedeemer
|
||||
[ ('Vote, 0)
|
||||
, ('Cosign, 1)
|
||||
, ('Unlock, 2)
|
||||
, ('AdvanceProposal, 3)
|
||||
]
|
||||
|
||||
-- | Parameters that identify the Proposal validator script.
|
||||
data Proposal = Proposal
|
||||
{ governorSTAssetClass :: AssetClass
|
||||
, stakeSTAssetClass :: AssetClass
|
||||
, maximumCosigners :: Integer
|
||||
-- ^ Arbitrary limit for maximum amount of cosigners on a proposal.
|
||||
}
|
||||
deriving stock (Show, Eq)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Plutarch-land
|
||||
|
|
@ -181,17 +261,37 @@ instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag
|
|||
deriving via
|
||||
(DerivePConstantViaNewtype ResultTag PResultTag PInteger)
|
||||
instance
|
||||
(PConstant ResultTag)
|
||||
(PConstantDecl ResultTag)
|
||||
|
||||
-- FIXME: This instance and the one below, for 'PProposalId', should be derived.
|
||||
-- Soon this will be possible through 'DerivePNewtype'.
|
||||
instance PTryFrom PData (PAsData PResultTag) where
|
||||
type PTryFromExcess PData (PAsData PResultTag) = PTryFromExcess PData (PAsData PInteger)
|
||||
ptryFrom' d k =
|
||||
ptryFrom' @_ @(PAsData PInteger) d $
|
||||
-- JUSTIFICATION:
|
||||
-- We are coercing from @PAsData PInteger@ to @PAsData PResultTag@.
|
||||
-- Since 'PResultTag' is a simple newtype, their shape is the same.
|
||||
k . first punsafeCoerce
|
||||
|
||||
-- | Plutarch-level version of 'PProposalId'.
|
||||
newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalId PInteger)
|
||||
|
||||
instance PTryFrom PData (PAsData PProposalId) where
|
||||
type PTryFromExcess PData (PAsData PProposalId) = PTryFromExcess PData (PAsData PInteger)
|
||||
ptryFrom' d k =
|
||||
ptryFrom' @_ @(PAsData PInteger) d $
|
||||
-- JUSTIFICATION:
|
||||
-- We are coercing from @PAsData PInteger@ to @PAsData PProposalId@.
|
||||
-- Since 'PProposalId' is a simple newtype, their shape is the same.
|
||||
k . first punsafeCoerce
|
||||
|
||||
instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
|
||||
deriving via
|
||||
(DerivePConstantViaNewtype ProposalId PProposalId PInteger)
|
||||
instance
|
||||
(PConstant ProposalId)
|
||||
(PConstantDecl ProposalId)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalStatus'.
|
||||
data PProposalStatus (s :: S)
|
||||
|
|
@ -199,6 +299,7 @@ data PProposalStatus (s :: S)
|
|||
-- e.g. like Tilde used 'pmatchEnum'.
|
||||
PDraft (Term s (PDataRecord '[]))
|
||||
| PVotingReady (Term s (PDataRecord '[]))
|
||||
| PLocked (Term s (PDataRecord '[]))
|
||||
| PFinished (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
|
@ -208,7 +309,7 @@ data PProposalStatus (s :: S)
|
|||
via PIsDataReprInstances PProposalStatus
|
||||
|
||||
instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
|
||||
deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstant ProposalStatus)
|
||||
deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalThresholds'.
|
||||
newtype PProposalThresholds (s :: S) = PProposalThresholds
|
||||
|
|
@ -230,7 +331,7 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
|
|||
via (PIsDataReprInstances PProposalThresholds)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
|
||||
deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstant ProposalThresholds)
|
||||
deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstantDecl ProposalThresholds)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalVotes'.
|
||||
newtype PProposalVotes (s :: S)
|
||||
|
|
@ -241,7 +342,7 @@ instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = Prop
|
|||
deriving via
|
||||
(DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap PResultTag PInteger))
|
||||
instance
|
||||
(PConstant ProposalVotes)
|
||||
(PConstantDecl ProposalVotes)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalDatum'.
|
||||
newtype PProposalDatum (s :: S) = PProposalDatum
|
||||
|
|
@ -249,9 +350,10 @@ newtype PProposalDatum (s :: S) = PProposalDatum
|
|||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
|
||||
'[ "proposalId" ':= PProposalId
|
||||
, "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
|
||||
, "status" ':= PProposalStatus
|
||||
, "cosigners" ':= PBuiltinList PPubKeyHash
|
||||
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
|
||||
, "thresholds" ':= PProposalThresholds
|
||||
, "votes" ':= PProposalVotes
|
||||
]
|
||||
|
|
@ -264,19 +366,71 @@ newtype PProposalDatum (s :: S) = PProposalDatum
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalDatum)
|
||||
|
||||
-- TODO: Derive this.
|
||||
instance PTryFrom PData (PAsData PProposalDatum) where
|
||||
type PTryFromExcess PData (PAsData PProposalDatum) = Const ()
|
||||
ptryFrom' d k =
|
||||
k (punsafeCoerce d, ())
|
||||
|
||||
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
|
||||
deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum)
|
||||
deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalRedeemer'.
|
||||
data PProposalRedeemer (s :: S)
|
||||
= PVote (Term s (PDataRecord '["resultTag" ':= PResultTag]))
|
||||
| PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)]))
|
||||
| PUnlock (Term s (PDataRecord '["resultTag" ':= PResultTag]))
|
||||
| PAdvanceProposal (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PProposalRedeemer
|
||||
|
||||
-- See below.
|
||||
instance PTryFrom PData (PAsData PProposalRedeemer) where
|
||||
type PTryFromExcess PData (PAsData PProposalRedeemer) = Const ()
|
||||
ptryFrom' d k =
|
||||
k (punsafeCoerce d, ())
|
||||
|
||||
-- TODO: Waiting on PTryFrom for 'PPubKeyHash'
|
||||
-- deriving via
|
||||
-- PAsData (PIsDataReprInstances PProposalRedeemer)
|
||||
-- instance
|
||||
-- PTryFrom PData (PAsData PProposalRedeemer)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
|
||||
deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Policy for Proposals.
|
||||
proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
|
||||
proposalPolicy _ =
|
||||
plam $ \_redeemer _ctx' -> P.do
|
||||
popaque (pconstant ())
|
||||
{- | Check for various invariants a proposal must uphold.
|
||||
This can be used to check both upon creation and
|
||||
upon any following state transitions in the proposal.
|
||||
-}
|
||||
proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool)
|
||||
proposalDatumValid proposal =
|
||||
phoistAcyclic $
|
||||
plam $ \datum' -> P.do
|
||||
datum <- pletFields @'["effects", "cosigners", "votes"] $ datum'
|
||||
|
||||
-- | Validator for Proposals.
|
||||
proposalValidator :: Proposal -> ClosedTerm PValidator
|
||||
proposalValidator _ =
|
||||
plam $ \_datum _redeemer _ctx' -> P.do
|
||||
popaque (pconstant ())
|
||||
let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash))
|
||||
effects =
|
||||
-- JUSTIFICATION:
|
||||
-- @datum.effects : PMap PResultTag (PMap PValidatorHash PDatumHash)@
|
||||
-- @PMap PResultTag (PMap PValidatorHash PDatumHash)@ is equivalent to
|
||||
-- @PBuiltinMap PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)@
|
||||
punsafeCoerce datum.effects
|
||||
|
||||
atLeastOneNegativeResult :: Term _ PBool
|
||||
atLeastOneNegativeResult =
|
||||
pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
|
||||
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
|
||||
, ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
|
||||
, ptraceIfFalse "Proposal has fewer cosigners than the limit" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners
|
||||
, ptraceIfFalse "Proposal votes and effects are compatible with each other" $ pkeysEqual # datum.effects # pto (pfromData datum.votes)
|
||||
]
|
||||
|
|
|
|||
228
agora/Agora/Proposal/Scripts.hs
Normal file
228
agora/Agora/Proposal/Scripts.hs
Normal file
|
|
@ -0,0 +1,228 @@
|
|||
{- |
|
||||
Module : Agora.Proposal.Scripts
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Plutus Scripts for Proposals.
|
||||
|
||||
Plutus Scripts for Proposals.
|
||||
-}
|
||||
module Agora.Proposal.Scripts (
|
||||
proposalValidator,
|
||||
proposalPolicy,
|
||||
) where
|
||||
|
||||
import Agora.Proposal (
|
||||
PProposalDatum (PProposalDatum),
|
||||
PProposalRedeemer (..),
|
||||
Proposal (governorSTAssetClass, stakeSTAssetClass),
|
||||
)
|
||||
import Agora.Record (mkRecordConstr, (.&), (.=))
|
||||
import Agora.Stake (findStakeOwnedBy)
|
||||
import Agora.Utils (
|
||||
anyOutput,
|
||||
findTxOutByTxOutRef,
|
||||
getMintingPolicySymbol,
|
||||
passert,
|
||||
pisUniq,
|
||||
psymbolValueOf,
|
||||
ptokenSpent,
|
||||
ptxSignedBy,
|
||||
pvalueSpent,
|
||||
)
|
||||
import Plutarch.Api.V1 (
|
||||
PMintingPolicy,
|
||||
PScriptContext (PScriptContext),
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
PTxInfo (PTxInfo),
|
||||
PValidator,
|
||||
)
|
||||
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.TryFrom (ptryFrom)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
|
||||
{- | Policy for Proposals.
|
||||
|
||||
== What this policy does
|
||||
|
||||
=== For minting:
|
||||
|
||||
- Governor is happy with mint.
|
||||
|
||||
* The governor must do most of the checking for the validity of the
|
||||
transaction. For example, the governor must check that the datum
|
||||
is correct, and that the ST is correctly paid to the right validator.
|
||||
|
||||
- Exactly 1 token is minted.
|
||||
|
||||
=== For burning:
|
||||
|
||||
- This policy cannot be burned.
|
||||
-}
|
||||
proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
|
||||
proposalPolicy proposal =
|
||||
plam $ \_redeemer ctx' -> P.do
|
||||
PScriptContext ctx' <- pmatch ctx'
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
|
||||
txInfo <- pletFields @'["inputs", "mint"] txInfo'
|
||||
PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose
|
||||
|
||||
let inputs = txInfo.inputs
|
||||
mintedValue = pfromData txInfo.mint
|
||||
AssetClass (govCs, govTn) = proposal.governorSTAssetClass
|
||||
|
||||
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
|
||||
let mintedProposalST =
|
||||
passetClassValueOf
|
||||
# mintedValue
|
||||
# (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
|
||||
|
||||
passert "Governance state-thread token must move" $
|
||||
ptokenSpent
|
||||
# (passetClass # pconstant govCs # pconstant govTn)
|
||||
# inputs
|
||||
|
||||
passert "Minted exactly one proposal ST" $
|
||||
mintedProposalST #== 1
|
||||
|
||||
popaque (pconstant ())
|
||||
|
||||
{- | The validator for Proposals.
|
||||
|
||||
The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
|
||||
|
||||
== What this validator does
|
||||
|
||||
=== Voting/unlocking
|
||||
|
||||
When voting and unlocking, the proposal must witness a state transition
|
||||
occuring in the relevant Stake. This transition must place a lock on
|
||||
the stake that is tagged with the right 'Agora.Proposal.ResultTag', and 'Agora.Proposal.ProposalId'.
|
||||
|
||||
=== Periods
|
||||
|
||||
Most redeemers are time-sensitive.
|
||||
|
||||
A list of all time-sensitive redeemers and their requirements:
|
||||
|
||||
- 'Agora.Proposal.Vote' can only be used when both the status is in 'Agora.Proposal.VotingReady',
|
||||
and 'Agora.Proposal.Time.isVotingPeriod' is true.
|
||||
- 'Agora.Proposal.Cosign' can only be used when both the status is in 'Agora.Proposal.Draft',
|
||||
and 'Agora.Proposal.Time.isDraftPeriod' is true.
|
||||
- 'Agora.Proposal.AdvanceProposal' can only be used when the status can be advanced
|
||||
(see 'Agora.Proposal.AdvanceProposal' docs).
|
||||
- 'Agora.Proposal.Unlock' is always valid.
|
||||
-}
|
||||
proposalValidator :: Proposal -> ClosedTerm PValidator
|
||||
proposalValidator proposal =
|
||||
plam $ \datum redeemer ctx' -> P.do
|
||||
PScriptContext ctx' <- pmatch ctx'
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- plet $ pfromData ctx.txInfo
|
||||
PTxInfo txInfo' <- pmatch txInfo
|
||||
txInfoF <- pletFields @'["inputs", "mint", "datums", "signatories"] txInfo'
|
||||
PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
|
||||
|
||||
PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
|
||||
txOutF <- pletFields @'["address", "value"] $ txOut
|
||||
|
||||
(pfromData -> proposalDatum, _) <-
|
||||
ptryFrom @(PAsData PProposalDatum) datum
|
||||
(pfromData -> proposalRedeemer, _) <-
|
||||
ptryFrom @(PAsData PProposalRedeemer) redeemer
|
||||
|
||||
proposalF <-
|
||||
pletFields
|
||||
@'[ "proposalId"
|
||||
, "effects"
|
||||
, "status"
|
||||
, "cosigners"
|
||||
, "thresholds"
|
||||
, "votes"
|
||||
]
|
||||
proposalDatum
|
||||
|
||||
ownAddress <- plet $ txOutF.address
|
||||
|
||||
let stCurrencySymbol =
|
||||
pconstant $ getMintingPolicySymbol (proposalPolicy proposal)
|
||||
valueSpent <- plet $ pvalueSpent # txInfoF.inputs
|
||||
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
|
||||
let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
|
||||
stakeSTAssetClass <-
|
||||
plet $ passetClass # pconstant stakeSym # pconstant stakeTn
|
||||
spentStakeST <-
|
||||
plet $ passetClassValueOf # valueSpent # stakeSTAssetClass
|
||||
|
||||
signedBy <- plet $ ptxSignedBy # txInfoF.signatories
|
||||
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
pmatch proposalRedeemer $ \case
|
||||
PVote _r -> P.do
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PCosign r -> P.do
|
||||
newSigs <- plet $ pfield @"newCosigners" # r
|
||||
|
||||
passert "Cosigners are unique" $
|
||||
pisUniq # newSigs
|
||||
|
||||
passert "Signed by all new cosigners" $
|
||||
pall # signedBy # newSigs
|
||||
|
||||
passert "As many new cosigners as Stake datums" $
|
||||
spentStakeST #== plength # newSigs
|
||||
|
||||
passert "All new cosigners are witnessed by their Stake datums" $
|
||||
pall
|
||||
# plam
|
||||
( \sig ->
|
||||
pmatch
|
||||
( findStakeOwnedBy # stakeSTAssetClass
|
||||
# pfromData sig
|
||||
# txInfoF.datums
|
||||
# txInfoF.inputs
|
||||
)
|
||||
$ \case
|
||||
PNothing -> pcon PFalse
|
||||
PJust _ -> pcon PTrue
|
||||
)
|
||||
# newSigs
|
||||
|
||||
passert "Signatures are correctly added to cosignature list" $
|
||||
anyOutput @PProposalDatum # ctx.txInfo
|
||||
#$ plam
|
||||
$ \newValue address newProposalDatum -> P.do
|
||||
let updatedSigs = pconcat # newSigs # proposalF.cosigners
|
||||
correctDatum =
|
||||
pdata newProposalDatum
|
||||
#== pdata
|
||||
( mkRecordConstr
|
||||
PProposalDatum
|
||||
( #proposalId .= proposalF.proposalId
|
||||
.& #effects .= proposalF.effects
|
||||
.& #status .= proposalF.status
|
||||
.& #cosigners .= pdata updatedSigs
|
||||
.& #thresholds .= proposalF.thresholds
|
||||
.& #votes .= proposalF.votes
|
||||
)
|
||||
)
|
||||
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Datum must be correct" correctDatum
|
||||
, ptraceIfFalse "Value should be correct" $
|
||||
pdata txOutF.value #== pdata newValue
|
||||
, ptraceIfFalse "Must be sent to Proposal's address" $
|
||||
ownAddress #== pdata address
|
||||
]
|
||||
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PUnlock _r -> P.do
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PAdvanceProposal _r -> P.do
|
||||
popaque (pconstant ())
|
||||
262
agora/Agora/Proposal/Time.hs
Normal file
262
agora/Agora/Proposal/Time.hs
Normal file
|
|
@ -0,0 +1,262 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.Proposal.Time
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Time functions for proposal phases.
|
||||
|
||||
Time functions for proposal phases.
|
||||
-}
|
||||
module Agora.Proposal.Time (
|
||||
-- * Haskell-land
|
||||
ProposalTime (..),
|
||||
ProposalTimingConfig (..),
|
||||
ProposalStartingTime (..),
|
||||
|
||||
-- * Plutarch-land
|
||||
PProposalTime (..),
|
||||
PProposalTimingConfig (..),
|
||||
PProposalStartingTime (..),
|
||||
|
||||
-- * Compute periods given config and starting time.
|
||||
currentProposalTime,
|
||||
isDraftPeriod,
|
||||
isVotingPeriod,
|
||||
isLockingPeriod,
|
||||
isExecutionPeriod,
|
||||
) where
|
||||
|
||||
import Agora.Record (mkRecordConstr, (.&), (.=))
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Plutarch.Api.V1 (
|
||||
PExtended (PFinite),
|
||||
PInterval (PInterval),
|
||||
PLowerBound (PLowerBound),
|
||||
PPOSIXTime,
|
||||
PPOSIXTimeRange,
|
||||
PUpperBound (PUpperBound),
|
||||
)
|
||||
import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.Numeric (AdditiveSemigroup ((+)))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import Plutus.V1.Ledger.Time (POSIXTime)
|
||||
import PlutusTx qualified
|
||||
import Prelude hiding ((+))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | == Establishing timing in Proposal interactions.
|
||||
|
||||
In Plutus, it's impossible to determine time exactly. It's also impossible
|
||||
to get a single point in time, yet often we need to check
|
||||
various constraints on time.
|
||||
|
||||
For the purposes of proposals, there's a single most important feature:
|
||||
The ability to determine if we can perform an action. In order to correctly
|
||||
determine if we are able to perform certain actions, we need to know what
|
||||
time it roughly is, compared to when the proposal was created.
|
||||
|
||||
'ProposalTime' represents "the time according to the proposal".
|
||||
Its representation is opaque, and doesn't matter.
|
||||
|
||||
Various functions work simply on 'ProposalTime' and 'ProposalTimingConfig'.
|
||||
In particular, 'currentProposalTime' is useful for extracting the time
|
||||
from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field
|
||||
of 'Plutus.V1.Ledger.Api.TxInfo'.
|
||||
|
||||
We avoid 'PPOSIXTimeRange' where we can in order to save on operations.
|
||||
-}
|
||||
data ProposalTime = ProposalTime
|
||||
{ lowerBound :: POSIXTime
|
||||
, upperBound :: POSIXTime
|
||||
}
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalTime [('ProposalTime, 0)]
|
||||
|
||||
-- | Represents the starting time of the proposal.
|
||||
newtype ProposalStartingTime = ProposalStartingTime
|
||||
{ getProposalStartingTime :: POSIXTime
|
||||
}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
{- | Configuration of proposal timings.
|
||||
|
||||
See: https://github.com/Liqwid-Labs/agora/blob/master/docs/tech-design/proposals.md#when-may-interactions-occur
|
||||
-}
|
||||
data ProposalTimingConfig = ProposalTimingConfig
|
||||
{ draftTime :: POSIXTime
|
||||
-- ^ "D": the length of the draft period.
|
||||
, votingTime :: POSIXTime
|
||||
-- ^ "V": the length of the voting period.
|
||||
, lockingTime :: POSIXTime
|
||||
-- ^ "L": the length of the locking period.
|
||||
, executingTime :: POSIXTime
|
||||
-- ^ "E": the length of the execution period.
|
||||
}
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Plutarch-level version of 'ProposalTime'.
|
||||
newtype PProposalTime (s :: S)
|
||||
= PProposalTime
|
||||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "lowerBound" ':= PPOSIXTime
|
||||
, "upperBound" ':= PPOSIXTime
|
||||
]
|
||||
)
|
||||
)
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalTime)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalStartingTime'.
|
||||
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalStartingTime PPOSIXTime)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalTimingConfig'.
|
||||
newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
|
||||
{ getProposalTimingConfig ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "draftTime" ':= PPOSIXTime
|
||||
, "votingTime" ':= PPOSIXTime
|
||||
, "lockingTime" ':= PPOSIXTime
|
||||
, "executingTime" ':= PPOSIXTime
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalTimingConfig)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- FIXME: Orphan instance, move this to plutarch-extra.
|
||||
instance AdditiveSemigroup (Term s PPOSIXTime) where
|
||||
(punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
|
||||
|
||||
{- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field.
|
||||
|
||||
If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is
|
||||
an infinity) then we error out.
|
||||
-}
|
||||
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
|
||||
currentProposalTime = phoistAcyclic $
|
||||
plam $ \iv -> P.do
|
||||
PInterval iv' <- pmatch iv
|
||||
ivf <- pletFields @'["from", "to"] iv'
|
||||
PLowerBound lb <- pmatch ivf.from
|
||||
PUpperBound ub <- pmatch ivf.to
|
||||
lbf <- pletFields @'["_0", "_1"] lb
|
||||
ubf <- pletFields @'["_0", "_1"] ub
|
||||
mkRecordConstr PProposalTime $
|
||||
#lowerBound
|
||||
.= pmatch
|
||||
lbf._0
|
||||
( \case
|
||||
PFinite ((pfield @"_0" #) -> d) -> d
|
||||
_ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
|
||||
)
|
||||
.& #upperBound
|
||||
.= pmatch
|
||||
ubf._0
|
||||
( \case
|
||||
PFinite ((pfield @"_0" #) -> d) -> d
|
||||
_ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
|
||||
)
|
||||
|
||||
-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
|
||||
proposalTimeWithin ::
|
||||
Term
|
||||
s
|
||||
( PPOSIXTime
|
||||
:--> PPOSIXTime
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
proposalTimeWithin = phoistAcyclic $
|
||||
plam $ \l h proposalTime' -> P.do
|
||||
PProposalTime proposalTime <- pmatch proposalTime'
|
||||
ptf <- pletFields @'["lowerBound", "upperBound"] proposalTime
|
||||
foldr1
|
||||
(#&&)
|
||||
[ l #<= pfromData ptf.lowerBound
|
||||
, pfromData ptf.upperBound #<= h
|
||||
]
|
||||
|
||||
-- | True if the 'PProposalTime' is in the draft period.
|
||||
isDraftPeriod ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PProposalTimingConfig
|
||||
:--> PProposalStartingTime
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
isDraftPeriod = phoistAcyclic $
|
||||
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
|
||||
proposalTimeWithin # s # (s + pfield @"draftTime" # config)
|
||||
|
||||
-- | True if the 'PProposalTime' is in the voting period.
|
||||
isVotingPeriod ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PProposalTimingConfig
|
||||
:--> PProposalStartingTime
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
isVotingPeriod = phoistAcyclic $
|
||||
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
|
||||
pletFields @'["draftTime", "votingTime"] config $ \f ->
|
||||
proposalTimeWithin # s # (s + f.draftTime + f.votingTime)
|
||||
|
||||
-- | True if the 'PProposalTime' is in the locking period.
|
||||
isLockingPeriod ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PProposalTimingConfig
|
||||
:--> PProposalStartingTime
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
isLockingPeriod = phoistAcyclic $
|
||||
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
|
||||
pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f ->
|
||||
proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
|
||||
|
||||
-- | True if the 'PProposalTime' is in the execution period.
|
||||
isExecutionPeriod ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PProposalTimingConfig
|
||||
:--> PProposalStartingTime
|
||||
:--> PProposalTime
|
||||
:--> PBool
|
||||
)
|
||||
isExecutionPeriod = phoistAcyclic $
|
||||
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
|
||||
pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f ->
|
||||
proposalTimeWithin # s
|
||||
# (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime)
|
||||
108
agora/Agora/Record.hs
Normal file
108
agora/Agora/Record.hs
Normal file
|
|
@ -0,0 +1,108 @@
|
|||
{- |
|
||||
Module : Agora.Record
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: PDataRecord helper functions.
|
||||
|
||||
'PDataRecord' helper functions.
|
||||
-}
|
||||
module Agora.Record (
|
||||
mkRecord,
|
||||
mkRecordConstr,
|
||||
(.=),
|
||||
(.&),
|
||||
RecordMorphism,
|
||||
FieldName,
|
||||
) where
|
||||
|
||||
import Control.Category (Category (..))
|
||||
import Data.Coerce (coerce)
|
||||
import GHC.OverloadedLabels (IsLabel (fromLabel))
|
||||
import GHC.TypeLits (Symbol)
|
||||
import Plutarch.DataRepr (PDataRecord (PDCons))
|
||||
import Prelude hiding (id, (.))
|
||||
|
||||
-- | Like 'Data.Proxy.Proxy' but local to this module.
|
||||
data FieldName (sym :: Symbol) = FieldName
|
||||
|
||||
{- | The use of two different 'Symbol's here allows unification to happen,
|
||||
ensuring 'FieldName' has a fully inferred 'Symbol'.
|
||||
|
||||
For example, @'mkRecord' (#foo .= 'pconstantData' (42 :: 'Integer'))@ gets
|
||||
the correct type. Namely, @'Term' s ('PDataRecord' '["foo" ':= 'PInteger'])@.
|
||||
-}
|
||||
instance forall (sym :: Symbol) (sym' :: Symbol). sym ~ sym' => IsLabel sym (FieldName sym) where
|
||||
fromLabel = FieldName
|
||||
|
||||
-- | Turn a constant 'RecordMorphism' into a fully built 'PDataRecord'.
|
||||
mkRecord :: forall (r :: [PLabeledType]) (s :: S). RecordMorphism s '[] r -> Term s (PDataRecord r)
|
||||
mkRecord f = f.runRecordMorphism pdnil
|
||||
|
||||
{- | 'mkRecord' but for known data-types.
|
||||
|
||||
This allows you to dynamically construct a record type constructor.
|
||||
|
||||
=== Example:
|
||||
@
|
||||
'mkRecordConstr'
|
||||
'Agora.Stake.PStakeDatum'
|
||||
( #stakedAmount '.=' 'pconstantData' ('Plutarch.SafeMoney.Tagged' @GTTag 42)
|
||||
'.&' #owner '.=' 'pconstantData' "aabbcc"
|
||||
'.&' #lockedBy '.=' 'pdata' pnil
|
||||
)
|
||||
@
|
||||
Is the same as
|
||||
|
||||
@
|
||||
'pconstant' ('Agora.Stake.StakeDatum' ('Plutarch.SafeMoney.Tagged' 42) "aabbcc" [])
|
||||
@
|
||||
-}
|
||||
mkRecordConstr ::
|
||||
forall (r :: [PLabeledType]) (s :: S) (pt :: PType).
|
||||
PlutusType pt =>
|
||||
-- | The constructor. This is just the Haskell-level constructor for the type.
|
||||
-- For 'Plutarch.Api.V1.Maybe.PMaybeData', this would
|
||||
-- be 'Plutarch.Api.V1.Maybe.PDJust', or 'Plutarch.Api.V1.Maybe.PNothing'.
|
||||
(forall s'. Term s' (PDataRecord r) -> pt s') ->
|
||||
-- | The morphism that builds the record.
|
||||
RecordMorphism s '[] r ->
|
||||
Term s pt
|
||||
mkRecordConstr ctr = pcon . ctr . mkRecord
|
||||
|
||||
-- | A morphism from one 'PDataRecord' to another, representing some sort of consing of data.
|
||||
newtype RecordMorphism (s :: S) (as :: [PLabeledType]) (bs :: [PLabeledType]) = RecordMorphism
|
||||
{ runRecordMorphism ::
|
||||
Term s (PDataRecord as) ->
|
||||
Term s (PDataRecord bs)
|
||||
}
|
||||
|
||||
instance Category (RecordMorphism s) where
|
||||
id = RecordMorphism id
|
||||
f . g = coerce $ f.runRecordMorphism . g.runRecordMorphism
|
||||
|
||||
infix 7 .=
|
||||
|
||||
-- | Cons a labeled type as a 'RecordMorphism'.
|
||||
(.=) ::
|
||||
forall (sym :: Symbol) (a :: PType) (as :: [PLabeledType]) (s :: S).
|
||||
-- | The field name. You can use @-XOverloadedLabels@ to enable the syntax:
|
||||
-- @#hello ~ 'FieldName' "hello"@
|
||||
FieldName sym ->
|
||||
-- | The value at that field. This must be 'PAsData', because the underlying
|
||||
-- type is @'PlutusCore.Data.Constr' 'Integer' ['PlutusCore.Data.Data']@.
|
||||
Term s (PAsData a) ->
|
||||
RecordMorphism s as ((sym ':= a) ': as)
|
||||
_ .= x = RecordMorphism $ pcon . PDCons x
|
||||
|
||||
infixr 6 .&
|
||||
|
||||
-- | Compose two 'RecordMorphism's.
|
||||
(.&) ::
|
||||
forall
|
||||
(s :: S)
|
||||
(a :: [PLabeledType])
|
||||
(b :: [PLabeledType])
|
||||
(c :: [PLabeledType]).
|
||||
RecordMorphism s b c ->
|
||||
RecordMorphism s a b ->
|
||||
RecordMorphism s a c
|
||||
(.&) = (.)
|
||||
|
|
@ -8,16 +8,20 @@ Description: Vote-lockable stake UTXOs holding GT.
|
|||
Vote-lockable stake UTXOs holding GT.
|
||||
-}
|
||||
module Agora.Stake (
|
||||
PStakeDatum (..),
|
||||
PStakeRedeemer (..),
|
||||
-- * Haskell-land
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (..),
|
||||
ProposalLock (..),
|
||||
PProposalLock (..),
|
||||
Stake (..),
|
||||
stakePolicy,
|
||||
stakeValidator,
|
||||
ProposalLock (..),
|
||||
|
||||
-- * Plutarch-land
|
||||
PStakeDatum (..),
|
||||
PStakeRedeemer (..),
|
||||
PProposalLock (..),
|
||||
|
||||
-- * Utility functions
|
||||
stakeLocked,
|
||||
findStakeOwnedBy,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -33,16 +37,14 @@ import PlutusTx qualified
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PMintingPolicy,
|
||||
PDatum,
|
||||
PDatumHash,
|
||||
PMaybeData (PDJust, PDNothing),
|
||||
PPubKeyHash,
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
PTokenName,
|
||||
PValidator,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
PTuple,
|
||||
PTxInInfo (PTxInInfo),
|
||||
PTxOut (PTxOut),
|
||||
)
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
|
|
@ -50,43 +52,34 @@ import Plutarch.DataRepr (
|
|||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (..))
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
import Plutus.V1.Ledger.Value (AssetClass)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Utils (
|
||||
anyInput,
|
||||
anyOutput,
|
||||
paddValue,
|
||||
passert,
|
||||
pfindTxInByTxOutRef,
|
||||
pgeqByClass,
|
||||
pgeqByClass',
|
||||
pgeqBySymbol,
|
||||
pnotNull,
|
||||
psingletonValue,
|
||||
psymbolValueOf,
|
||||
ptxSignedBy,
|
||||
pvalueSpent,
|
||||
ptryFindDatum,
|
||||
)
|
||||
import Plutarch.Numeric
|
||||
import Control.Applicative (Const)
|
||||
import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf)
|
||||
import Plutarch.Numeric ()
|
||||
import Plutarch.SafeMoney (
|
||||
PDiscrete,
|
||||
Tagged (..),
|
||||
pdiscreteValue,
|
||||
untag,
|
||||
)
|
||||
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Parameters for creating Stake scripts.
|
||||
newtype Stake = Stake
|
||||
data Stake = Stake
|
||||
{ gtClassRef :: Tagged GTTag AssetClass
|
||||
-- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
|
||||
, proposalSTClass :: AssetClass
|
||||
}
|
||||
|
||||
{- | A lock placed on a Stake datum in order to prevent
|
||||
|
|
@ -135,17 +128,20 @@ data StakeRedeemer
|
|||
| -- | 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'.
|
||||
| -- | Permit a Vote to be added onto a 'Agora.Proposal.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
|
||||
-- This action checks for permission of the 'Agora.Proposal.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]
|
||||
| -- | The owner can consume stake if nothing is changed about it.
|
||||
-- If the proposal token moves, this is equivalent to the owner consuming it.
|
||||
WitnessStake
|
||||
deriving stock (Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
|
|
@ -154,13 +150,14 @@ PlutusTx.makeIsDataIndexed
|
|||
, ('Destroy, 1)
|
||||
, ('PermitVote, 2)
|
||||
, ('RetractVotes, 3)
|
||||
, ('WitnessStake, 4)
|
||||
]
|
||||
|
||||
-- | 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.
|
||||
-- This also acts as the voting weight for 'Agora.Proposal.Proposal's.
|
||||
, owner :: PubKeyHash
|
||||
-- ^ The hash of the public key this stake belongs to.
|
||||
--
|
||||
|
|
@ -195,8 +192,13 @@ newtype PStakeDatum (s :: S) = PStakeDatum
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PStakeDatum)
|
||||
|
||||
instance PTryFrom PData (PAsData PStakeDatum) where
|
||||
type PTryFromExcess PData (PAsData PStakeDatum) = Const ()
|
||||
ptryFrom' d k =
|
||||
k (punsafeCoerce d, ())
|
||||
|
||||
instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
|
||||
deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum)
|
||||
deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstantDecl StakeDatum)
|
||||
|
||||
-- | Plutarch-level redeemer for Stake scripts.
|
||||
data PStakeRedeemer (s :: S)
|
||||
|
|
@ -205,7 +207,8 @@ data PStakeRedeemer (s :: S)
|
|||
| -- | 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]))
|
||||
| PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)]))
|
||||
| PWitnessStake (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
|
|
@ -213,9 +216,15 @@ data PStakeRedeemer (s :: S)
|
|||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PStakeRedeemer
|
||||
|
||||
instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
|
||||
deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer)
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PStakeRedeemer)
|
||||
instance
|
||||
PTryFrom PData (PAsData PStakeRedeemer)
|
||||
|
||||
instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
|
||||
deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstantDecl StakeRedeemer)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalLock'.
|
||||
newtype PProposalLock (s :: S) = PProposalLock
|
||||
{ getProposalLock ::
|
||||
Term
|
||||
|
|
@ -233,224 +242,13 @@ newtype PProposalLock (s :: S) = PProposalLock
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalLock)
|
||||
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PProposalLock)
|
||||
instance
|
||||
PTryFrom PData (PAsData PProposalLock)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock
|
||||
deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
{- What this Policy does
|
||||
|
||||
For minting:
|
||||
Check that exactly one state thread is minted
|
||||
Check that an output exists with a state thread and a valid datum
|
||||
Check that no state thread is an input
|
||||
assert TokenName == ValidatorHash of the script that we pay to
|
||||
|
||||
For burning:
|
||||
Check that exactly one state thread is burned
|
||||
Check that datum at state thread is valid and not locked
|
||||
-}
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Policy for Stake state threads.
|
||||
stakePolicy :: Stake -> ClosedTerm PMintingPolicy
|
||||
stakePolicy stake =
|
||||
plam $ \_redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'
|
||||
|
||||
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
|
||||
ownSymbol <- plet $ pfield @"_0" # ownSymbol'
|
||||
spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # pfromData txInfo'
|
||||
mintedST <- plet $ psymbolValueOf # ownSymbol # txInfo.mint
|
||||
|
||||
let burning = P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
passert "ST burned" $
|
||||
mintedST #== -1
|
||||
|
||||
passert "An unlocked input existed containing an ST" $
|
||||
anyInput @PStakeDatum # pfromData txInfo'
|
||||
#$ plam
|
||||
$ \value _ stakeDatum' -> P.do
|
||||
let hasST = psymbolValueOf # ownSymbol # value #== 1
|
||||
let unlocked = pnot # (stakeLocked # stakeDatum')
|
||||
hasST #&& unlocked
|
||||
|
||||
popaque (pconstant ())
|
||||
|
||||
let minting = P.do
|
||||
passert "ST at inputs must be 0" $
|
||||
spentST #== 0
|
||||
|
||||
passert "Minted ST must be exactly 1" $
|
||||
mintedST #== 1
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # pfromData txInfo'
|
||||
#$ plam
|
||||
$ \value address stakeDatum' -> P.do
|
||||
let cred = pfield @"credential" # address
|
||||
pmatch cred $ \case
|
||||
-- Should pay to a script address
|
||||
PPubKeyCredential _ -> pcon PFalse
|
||||
PScriptCredential validatorHash' -> P.do
|
||||
validatorHash <- pletFields @'["_0"] validatorHash'
|
||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
|
||||
-- TODO: figure out why this is required :/ (specifically, why `validatorHash._0` is `PData`)
|
||||
tn <- plet (pfromData (punsafeCoerce validatorHash._0 :: Term _ (PAsData PTokenName)))
|
||||
|
||||
let stValue =
|
||||
psingletonValue
|
||||
# ownSymbol
|
||||
-- This coerce is safe because the structure
|
||||
-- of PValidatorHash is the same as PTokenName.
|
||||
# tn
|
||||
# 1
|
||||
let expectedValue =
|
||||
paddValue
|
||||
# (pdiscreteValue stake.gtClassRef # stakeDatum.stakedAmount)
|
||||
# stValue
|
||||
let ownerSignsTransaction =
|
||||
ptxSignedBy
|
||||
# ctx.txInfo
|
||||
# stakeDatum.owner
|
||||
|
||||
-- TODO: This is quite inefficient now, as it does two lookups
|
||||
-- instead of a more efficient single pass,
|
||||
-- but it doesn't really matter for this. At least it's correct.
|
||||
let valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqByClass
|
||||
# ownSymbol
|
||||
# tn
|
||||
# value
|
||||
# expectedValue
|
||||
]
|
||||
|
||||
ownerSignsTransaction
|
||||
#&& valueCorrect
|
||||
popaque (pconstant ())
|
||||
|
||||
pif (0 #< mintedST) minting burning
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Validator intended for Stake UTXOs to live in.
|
||||
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'
|
||||
|
||||
-- TODO: Use PTryFrom
|
||||
let stakeRedeemer :: Term _ PStakeRedeemer
|
||||
stakeRedeemer = pfromData $ punsafeCoerce redeemer
|
||||
stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
|
||||
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
|
||||
|
||||
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 # 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 #$ stakeIsLocked
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo'
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum'
|
||||
delta <- plet $ pfield @"delta" # r
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let correctOutputDatum =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ stakeDatum.owner #== newStakeDatum.owner
|
||||
, (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount
|
||||
, -- We can't magically conjure GT anyway (no input to spend!)
|
||||
-- do we need to check this, really?
|
||||
zero #<= pfromData newStakeDatum.stakedAmount
|
||||
]
|
||||
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,
|
||||
-- but it doesn't really matter for this. At least it's correct.
|
||||
let valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqBySymbol
|
||||
# stCurrencySymbol
|
||||
# value
|
||||
# expectedValue
|
||||
]
|
||||
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "isScriptAddress" isScriptAddress
|
||||
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
|
||||
, ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
|
||||
popaque (pconstant ())
|
||||
deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstantDecl ProposalLock)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -461,3 +259,58 @@ stakeLocked = phoistAcyclic $
|
|||
let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
|
||||
locks = pfield @"lockedBy" # stakeDatum
|
||||
in pnotNull # locks
|
||||
|
||||
-- | Find a stake owned by a particular PK.
|
||||
findStakeOwnedBy ::
|
||||
Term
|
||||
s
|
||||
( PAssetClass
|
||||
:--> PPubKeyHash
|
||||
:--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
|
||||
:--> PBuiltinList (PAsData PTxInInfo)
|
||||
:--> PMaybe (PAsData PStakeDatum)
|
||||
)
|
||||
findStakeOwnedBy = phoistAcyclic $
|
||||
plam $ \ac pk datums inputs ->
|
||||
pmatch (pfind # (isInputStakeOwnedBy # ac # pk # datums) # inputs) $ \case
|
||||
PNothing -> pcon PNothing
|
||||
PJust (pfromData -> v) -> P.do
|
||||
let txOut = pfield @"resolved" # pto v
|
||||
txOutF <- pletFields @'["datumHash"] $ txOut
|
||||
pmatch txOutF.datumHash $ \case
|
||||
PDNothing _ -> pcon PNothing
|
||||
PDJust ((pfield @"_0" #) -> dh) -> P.do
|
||||
ptryFindDatum @(PAsData PStakeDatum) # dh # datums
|
||||
|
||||
stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
|
||||
stakeDatumOwnedBy =
|
||||
phoistAcyclic $
|
||||
plam $ \pk stakeDatum -> P.do
|
||||
stakeDatumF <- pletFields @'["owner"] $ pto stakeDatum
|
||||
stakeDatumF.owner #== pdata pk
|
||||
|
||||
-- Does the input have a `Stake` owned by a particular PK?
|
||||
isInputStakeOwnedBy ::
|
||||
Term
|
||||
_
|
||||
( PAssetClass :--> PPubKeyHash
|
||||
:--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
|
||||
:--> PAsData PTxInInfo
|
||||
:--> PBool
|
||||
)
|
||||
isInputStakeOwnedBy =
|
||||
plam $ \ac ss datums txInInfo' -> P.do
|
||||
PTxInInfo ((pfield @"resolved" #) -> txOut) <- pmatch $ pfromData txInInfo'
|
||||
PTxOut txOut' <- pmatch txOut
|
||||
txOutF <- pletFields @'["value", "datumHash"] txOut'
|
||||
outStakeST <- plet $ passetClassValueOf # txOutF.value # ac
|
||||
pmatch txOutF.datumHash $ \case
|
||||
PDNothing _ -> pcon PFalse
|
||||
PDJust ((pfield @"_0" #) -> datumHash) ->
|
||||
pif
|
||||
(outStakeST #== 1)
|
||||
( pmatch (ptryFindDatum @(PAsData PStakeDatum) # datumHash # datums) $ \case
|
||||
PNothing -> pcon PFalse
|
||||
PJust v -> stakeDatumOwnedBy # ss # pfromData (punsafeCoerce v)
|
||||
)
|
||||
(pcon PFalse)
|
||||
|
|
|
|||
405
agora/Agora/Stake/Scripts.hs
Normal file
405
agora/Agora/Stake/Scripts.hs
Normal file
|
|
@ -0,0 +1,405 @@
|
|||
{- |
|
||||
Module : Agora.Stake.Scripts
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Plutus Scripts for Stakes.
|
||||
|
||||
Plutus Scripts for Stakes.
|
||||
-}
|
||||
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
|
||||
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake
|
||||
import Agora.Utils (
|
||||
anyInput,
|
||||
anyOutput,
|
||||
paddValue,
|
||||
passert,
|
||||
pfindTxInByTxOutRef,
|
||||
pgeqByClass,
|
||||
pgeqByClass',
|
||||
pgeqBySymbol,
|
||||
psingletonValue,
|
||||
psymbolValueOf,
|
||||
ptokenSpent,
|
||||
ptxSignedBy,
|
||||
pvalueSpent,
|
||||
validatorHashToTokenName,
|
||||
)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PMintingPolicy,
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
PTokenName,
|
||||
PTxInfo,
|
||||
PValidator,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
)
|
||||
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.Numeric
|
||||
import Plutarch.SafeMoney (
|
||||
Tagged (..),
|
||||
pdiscreteValue',
|
||||
untag,
|
||||
)
|
||||
import Plutarch.TryFrom (ptryFrom)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
import Prelude hiding (Num (..))
|
||||
|
||||
{- | Policy for Stake state threads.
|
||||
|
||||
== What this Policy does
|
||||
|
||||
=== For minting:
|
||||
|
||||
- Check that exactly one state thread is minted.
|
||||
- Check that an output exists with a state thread and a valid datum.
|
||||
- Check that no state thread is an input.
|
||||
- assert @'Plutus.V1.Ledger.Api.TokenName' == 'Plutus.V1.Ledger.Api.ValidatorHash'@
|
||||
of the script that we pay to.
|
||||
|
||||
=== For burning:
|
||||
|
||||
- Check that exactly one state thread is burned.
|
||||
- Check that datum at state thread is valid and not locked.
|
||||
-}
|
||||
stakePolicy ::
|
||||
-- | The (governance) token that a Stake can store.
|
||||
Tagged GTTag AssetClass ->
|
||||
ClosedTerm PMintingPolicy
|
||||
stakePolicy gtClassRef =
|
||||
plam $ \_redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- plet $ ctx.txInfo
|
||||
let _a :: Term _ PTxInfo
|
||||
_a = txInfo
|
||||
txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
|
||||
|
||||
PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
|
||||
ownSymbol <- plet $ pfield @"_0" # ownSymbol'
|
||||
spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs
|
||||
mintedST <- plet $ psymbolValueOf # ownSymbol # txInfoF.mint
|
||||
|
||||
let burning = P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
passert "ST burned" $
|
||||
mintedST #== -1
|
||||
|
||||
passert "An unlocked input existed containing an ST" $
|
||||
anyInput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value _ stakeDatum' -> P.do
|
||||
let hasST = psymbolValueOf # ownSymbol # value #== 1
|
||||
let unlocked = pnot # (stakeLocked # stakeDatum')
|
||||
hasST #&& unlocked
|
||||
|
||||
popaque (pconstant ())
|
||||
|
||||
let minting = P.do
|
||||
passert "ST at inputs must be 0" $
|
||||
spentST #== 0
|
||||
|
||||
passert "Minted ST must be exactly 1" $
|
||||
mintedST #== 1
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address stakeDatum' -> P.do
|
||||
let cred = pfield @"credential" # address
|
||||
pmatch cred $ \case
|
||||
-- Should pay to a script address
|
||||
PPubKeyCredential _ -> pcon PFalse
|
||||
PScriptCredential validatorHash -> P.do
|
||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
|
||||
tn :: Term _ PTokenName <- plet (validatorHashToTokenName $ pfromData $ pfield @"_0" # validatorHash)
|
||||
|
||||
let stValue =
|
||||
psingletonValue
|
||||
# ownSymbol
|
||||
-- This coerce is safe because the structure
|
||||
-- of PValidatorHash is the same as PTokenName.
|
||||
# tn
|
||||
# 1
|
||||
let expectedValue =
|
||||
paddValue
|
||||
# (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount)
|
||||
# stValue
|
||||
let ownerSignsTransaction =
|
||||
ptxSignedBy
|
||||
# txInfoF.signatories
|
||||
# stakeDatum.owner
|
||||
|
||||
-- TODO: This is quite inefficient now, as it does two lookups
|
||||
-- instead of a more efficient single pass,
|
||||
-- but it doesn't really matter for this. At least it's correct.
|
||||
let valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass' (untag gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqByClass
|
||||
# ownSymbol
|
||||
# tn
|
||||
# value
|
||||
# expectedValue
|
||||
]
|
||||
|
||||
ownerSignsTransaction
|
||||
#&& valueCorrect
|
||||
popaque (pconstant ())
|
||||
|
||||
pif (0 #< mintedST) minting burning
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Validator intended for Stake UTXOs to be locked by.
|
||||
|
||||
== What this Validator does:
|
||||
|
||||
=== 'DepositWithdraw'
|
||||
|
||||
Deposit or withdraw some GT to the stake.
|
||||
|
||||
- Tx must be signed by the owner.
|
||||
- The 'stakedAmount' field must be updated.
|
||||
- The stake must not be locked.
|
||||
- The new UTXO must have the previous value plus the difference
|
||||
as stated by the redeemer.
|
||||
|
||||
=== 'PermitVote'
|
||||
|
||||
Allow a 'ProposalLock' to be put on the stake in order to vote
|
||||
on a proposal.
|
||||
|
||||
- A proposal token must be spent alongside the stake.
|
||||
|
||||
* Its total votes must be correctly updated to include this stake's
|
||||
contribution.
|
||||
|
||||
- Tx must be signed by the owner.
|
||||
|
||||
=== 'RetractVotes'
|
||||
|
||||
Remove a 'ProposalLock' set when voting on a proposal.
|
||||
|
||||
- A proposal token must be spent alongside the stake.
|
||||
- Tx must be signed by the owner.
|
||||
|
||||
=== 'Destroy'
|
||||
|
||||
Destroy the stake in order to reclaim the min ADA.
|
||||
|
||||
- The stake must not be locked.
|
||||
- Tx must be signed by the owner.
|
||||
|
||||
=== 'WitnessStake'
|
||||
|
||||
Allow this Stake to be included in a transaction without making
|
||||
any changes to it. In the future,
|
||||
this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
|
||||
|
||||
- Tx must be signed by the owner __or__ a proposal ST token must be spent
|
||||
alongside the stake.
|
||||
- The datum and value must remain unchanged.
|
||||
-}
|
||||
stakeValidator :: Stake -> ClosedTerm PValidator
|
||||
stakeValidator stake =
|
||||
plam $ \datum redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- plet $ pfromData ctx.txInfo
|
||||
txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
|
||||
|
||||
(pfromData -> stakeRedeemer, _) <- ptryFrom redeemer
|
||||
|
||||
-- TODO: Use PTryFrom
|
||||
let stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
|
||||
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
|
||||
|
||||
PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
|
||||
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 # txInfoF.signatories # stakeDatum.owner
|
||||
|
||||
stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
|
||||
mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
|
||||
valueSpent <- plet $ pvalueSpent # txInfoF.inputs
|
||||
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
|
||||
|
||||
let AssetClass (propCs, propTn) = stake.proposalSTClass
|
||||
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
|
||||
spentProposalST <- plet $ passetClassValueOf # valueSpent # proposalSTClass
|
||||
|
||||
-- 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 # stakeIsLocked
|
||||
|
||||
passert "Owner signs this transaction" ownerSignsTransaction
|
||||
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PRetractVotes _ -> P.do
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
passert "Proposal ST spent" $
|
||||
spentProposalST #== 1
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
|
||||
let valueCorrect = pdata continuingValue #== pdata value
|
||||
pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PPermitVote _ -> P.do
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
passert "Proposal ST spent" $
|
||||
spentProposalST #== 1
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
|
||||
let valueCorrect = pdata continuingValue #== pdata value
|
||||
pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
|
||||
popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PWitnessStake _ -> P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
let AssetClass (propCs, propTn) = stake.proposalSTClass
|
||||
propAssetClass = passetClass # pconstant propCs # pconstant propTn
|
||||
proposalTokenMoved =
|
||||
ptokenSpent
|
||||
# propAssetClass
|
||||
# txInfoF.inputs
|
||||
|
||||
-- In order for cosignature to be witnessed, it must be possible for a
|
||||
-- proposal to allow this transaction to happen. This puts trust into the Proposal.
|
||||
-- The Proposal must necessarily check that this is not abused.
|
||||
passert
|
||||
"Owner signs this transaction OR proposal token is spent"
|
||||
(ownerSignsTransaction #|| proposalTokenMoved)
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
|
||||
let valueCorrect = pdata continuingValue #== pdata value
|
||||
pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
popaque (pconstant ())
|
||||
PDepositWithdraw r -> P.do
|
||||
passert "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
passert "Stake unlocked" $
|
||||
pnot #$ stakeIsLocked
|
||||
passert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum'
|
||||
delta <- plet $ pfield @"delta" # r
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
let correctOutputDatum =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ stakeDatum.owner #== newStakeDatum.owner
|
||||
, (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount
|
||||
, -- We can't magically conjure GT anyway (no input to spend!)
|
||||
-- do we need to check this, really?
|
||||
zero #<= pfromData newStakeDatum.stakedAmount
|
||||
]
|
||||
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,
|
||||
-- but it doesn't really matter for this. At least it's correct.
|
||||
let valueCorrect =
|
||||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqBySymbol
|
||||
# stCurrencySymbol
|
||||
# value
|
||||
# expectedValue
|
||||
]
|
||||
|
||||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "isScriptAddress" isScriptAddress
|
||||
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
|
||||
, ptraceIfFalse "valueCorrect" valueCorrect
|
||||
]
|
||||
|
||||
popaque (pconstant ())
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module: Agora.Treasury
|
||||
Maintainer: jack@mlabs.city
|
||||
|
|
@ -8,24 +10,60 @@ treasury.
|
|||
-}
|
||||
module Agora.Treasury (module Agora.Treasury) where
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.Utils (passert)
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP
|
||||
import Plutarch.Api.V1 (PValidator)
|
||||
import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
|
||||
import Plutarch.Api.V1.Value (PCurrencySymbol, PValue)
|
||||
import Plutarch.Api.V1.Value (PValue)
|
||||
import Plutarch.DataRepr (
|
||||
PDataFields,
|
||||
DerivePConstantViaData (..),
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.TryFrom (PTryFrom, ptryFrom)
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
import PlutusTx qualified
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Agora.Utils (passert)
|
||||
import Plutarch (popaque)
|
||||
import Plutarch.Api.V1 (PValidator)
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
-- | Redeemer for Treasury actions.
|
||||
data TreasuryRedeemer
|
||||
= -- | Allow transaction to pass by delegating to GAT burn.
|
||||
SpendTreasuryGAT
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
''TreasuryRedeemer
|
||||
[ ('SpendTreasuryGAT, 0)
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Plutarch level type representing valid redeemers of the
|
||||
treasury.
|
||||
-}
|
||||
newtype PTreasuryRedeemer (s :: S)
|
||||
= -- | Alters treasury parameters, subject to the burning of a
|
||||
-- governance authority token.
|
||||
PSpendTreasuryGAT (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic, PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PTreasuryRedeemer
|
||||
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PTreasuryRedeemer)
|
||||
instance
|
||||
PTryFrom PData (PAsData PTreasuryRedeemer)
|
||||
|
||||
instance PUnsafeLiftDecl PTreasuryRedeemer where type PLifted PTreasuryRedeemer = TreasuryRedeemer
|
||||
deriving via (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer) instance (PConstantDecl TreasuryRedeemer)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Validator ensuring that transactions consuming the treasury
|
||||
do so in a valid manner.
|
||||
|
|
@ -33,12 +71,8 @@ import Plutarch.Unsafe (punsafeCoerce)
|
|||
treasuryValidator ::
|
||||
CurrencySymbol ->
|
||||
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
|
||||
treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> P.do
|
||||
(treasuryRedeemer, _) <- ptryFrom redeemer
|
||||
|
||||
-- plet required fields from script context.
|
||||
ctx <- pletFields @["txInfo", "purpose"] ctx'
|
||||
|
|
@ -47,7 +81,7 @@ treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
|
|||
PMinting _ <- pmatch ctx.purpose
|
||||
|
||||
-- Ensure redeemer type is valid.
|
||||
PAlterTreasuryParams _ <- pmatch $ pfromData treasuryRedeemer
|
||||
PSpendTreasuryGAT _ <- pmatch $ pfromData treasuryRedeemer
|
||||
|
||||
-- Get the minted value from txInfo.
|
||||
txInfo' <- plet ctx.txInfo
|
||||
|
|
@ -61,37 +95,3 @@ treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
|
|||
singleAuthorityTokenBurned gatCs txInfo' mint
|
||||
|
||||
popaque $ pconstant ()
|
||||
|
||||
{- | Plutarch level type representing datum of the treasury.
|
||||
Contains:
|
||||
|
||||
- @stateThread@ representing the asset class of the
|
||||
treasury's state thread token.
|
||||
-}
|
||||
newtype PTreasuryDatum (s :: S)
|
||||
= PTreasuryDatum
|
||||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "stateThread" ':= PCurrencySymbol
|
||||
]
|
||||
)
|
||||
)
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic, PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via PIsDataReprInstances PTreasuryDatum
|
||||
|
||||
{- | Plutarch level type representing valid redeemers of the
|
||||
treasury.
|
||||
-}
|
||||
newtype PTreasuryRedeemer (s :: S)
|
||||
= -- | Alters treasury parameters, subject to the burning of a
|
||||
-- governance authority token.
|
||||
PAlterTreasuryParams (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic, PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PTreasuryRedeemer
|
||||
|
|
|
|||
|
|
@ -10,15 +10,13 @@ module Agora.Utils (
|
|||
passert,
|
||||
pfind',
|
||||
pfindDatum,
|
||||
pfindDatum',
|
||||
ptryFindDatum,
|
||||
pvalueSpent,
|
||||
ptxSignedBy,
|
||||
paddValue,
|
||||
plookup,
|
||||
pfromMaybe,
|
||||
psymbolValueOf,
|
||||
passetClassValueOf,
|
||||
passetClassValueOf',
|
||||
pgeqByClass,
|
||||
pgeqBySymbol,
|
||||
pgeqByClass',
|
||||
|
|
@ -26,12 +24,22 @@ module Agora.Utils (
|
|||
psingletonValue,
|
||||
pfindMap,
|
||||
pnotNull,
|
||||
pisJust,
|
||||
ptokenSpent,
|
||||
pkeysEqual,
|
||||
pnub,
|
||||
pisUniq,
|
||||
|
||||
-- * Functions which should (probably) not be upstreamed
|
||||
anyOutput,
|
||||
allOutputs,
|
||||
anyInput,
|
||||
allInputs,
|
||||
findTxOutByTxOutRef,
|
||||
scriptHashFromAddress,
|
||||
findOutputsToAddress,
|
||||
findTxOutDatum,
|
||||
validatorHashToTokenName,
|
||||
getMintingPolicySymbol,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -42,23 +50,33 @@ import Plutus.V1.Ledger.Value (AssetClass (..))
|
|||
|
||||
import Plutarch.Api.V1 (
|
||||
PAddress,
|
||||
PCredential (PScriptCredential),
|
||||
PCurrencySymbol,
|
||||
PDatum,
|
||||
PDatumHash,
|
||||
PMap,
|
||||
PMaybeData (PDJust),
|
||||
PMintingPolicy,
|
||||
PPubKeyHash,
|
||||
PTokenName,
|
||||
PTokenName (PTokenName),
|
||||
PTuple,
|
||||
PTxInInfo (PTxInInfo),
|
||||
PTxInfo (PTxInfo),
|
||||
PTxInfo,
|
||||
PTxOut (PTxOut),
|
||||
PTxOutRef,
|
||||
PValidatorHash,
|
||||
PValue,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
)
|
||||
import Plutarch.Api.V1.AssocMap (PMap (PMap))
|
||||
import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf)
|
||||
import Plutarch.Api.V1.Value (PValue (PValue))
|
||||
import Plutarch.Builtin (ppairDataBuiltin)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Map.Extra (pkeys)
|
||||
import Plutarch.Monadic qualified as P
|
||||
import Plutarch.TryFrom (PTryFrom, ptryFrom)
|
||||
import Plutus.V1.Ledger.Api (CurrencySymbol)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Validator-level utility functions
|
||||
|
|
@ -68,24 +86,24 @@ passert :: Term s PString -> Term s PBool -> Term s k -> Term s k
|
|||
passert errorMessage check k = pif check k (ptraceError errorMessage)
|
||||
|
||||
-- | Find a datum with the given hash.
|
||||
pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum)
|
||||
pfindDatum :: Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe PDatum)
|
||||
pfindDatum = phoistAcyclic $
|
||||
plam $ \datumHash txInfo'' -> P.do
|
||||
PTxInfo txInfo' <- pmatch txInfo''
|
||||
plookupTuple # datumHash #$ pfield @"data" # txInfo'
|
||||
plam $ \datumHash datums -> plookupTuple # datumHash # datums
|
||||
|
||||
{- | Find a datum with the given hash.
|
||||
NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB.
|
||||
-}
|
||||
pfindDatum' :: PIsData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe (PAsData a))
|
||||
pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x
|
||||
-- | Find a datum with the given hash, and `ptryFrom` it.
|
||||
ptryFindDatum :: forall (a :: PType) (s :: S). PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a)
|
||||
ptryFindDatum = phoistAcyclic $
|
||||
plam $ \datumHash inputs ->
|
||||
pmatch (pfindDatum # datumHash # inputs) $ \case
|
||||
PNothing -> pcon PNothing
|
||||
PJust datum -> P.do
|
||||
(datum', _) <- ptryFrom (pto datum)
|
||||
pcon (PJust datum')
|
||||
|
||||
-- | Check if a PubKeyHash signs this transaction.
|
||||
ptxSignedBy :: Term s (PTxInfo :--> PAsData PPubKeyHash :--> PBool)
|
||||
ptxSignedBy :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PAsData PPubKeyHash :--> PBool)
|
||||
ptxSignedBy = phoistAcyclic $
|
||||
plam $ \txInfo' pkh -> P.do
|
||||
txInfo <- pletFields @'["signatories"] txInfo'
|
||||
pelem @PBuiltinList # pkh # txInfo.signatories
|
||||
plam $ \sigs sig -> pelem # sig # sigs
|
||||
|
||||
-- | Get the first element that matches a predicate or return Nothing.
|
||||
pfind' ::
|
||||
|
|
@ -143,6 +161,15 @@ pfromMaybe = phoistAcyclic $
|
|||
PJust a' -> a'
|
||||
PNothing -> e
|
||||
|
||||
-- | Yield True if a given PMaybe is of form PJust _.
|
||||
pisJust :: forall a s. Term s (PMaybe a :--> PBool)
|
||||
pisJust = phoistAcyclic $
|
||||
plam $ \v' -> P.do
|
||||
v <- pmatch v'
|
||||
case v of
|
||||
PJust _ -> pconstant True
|
||||
PNothing -> pconstant False
|
||||
|
||||
-- | Escape with a particular value on expecting 'Just'. For use in monadic context.
|
||||
pexpectJust ::
|
||||
forall r a s.
|
||||
|
|
@ -166,30 +193,17 @@ psymbolValueOf =
|
|||
PMap m <- pmatch (pfromData m')
|
||||
pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m
|
||||
|
||||
-- | Extract amount from PValue belonging to a Plutarch-level asset class.
|
||||
passetClassValueOf ::
|
||||
Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger)
|
||||
passetClassValueOf =
|
||||
phoistAcyclic $
|
||||
plam $ \sym token value'' -> P.do
|
||||
PValue value' <- pmatch value''
|
||||
PMap value <- pmatch value'
|
||||
m' <- pexpectJust 0 (plookup # pdata sym # value)
|
||||
PMap m <- pmatch (pfromData m')
|
||||
v <- pexpectJust 0 (plookup # pdata token # m)
|
||||
pfromData v
|
||||
|
||||
-- | Extract amount from PValue belonging to a Haskell-level AssetClass.
|
||||
passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger)
|
||||
passetClassValueOf' (AssetClass (sym, token)) =
|
||||
passetClassValueOf # pconstant sym # pconstant token
|
||||
phoistAcyclic $ plam $ \value -> pvalueOf # value # pconstant sym # pconstant token
|
||||
|
||||
-- | 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
|
||||
pvalueOf # b # cs # tn #<= pvalueOf # a # cs # tn
|
||||
|
||||
-- | Return '>=' on two values comparing by only a particular CurrencySymbol.
|
||||
pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool)
|
||||
|
|
@ -217,11 +231,10 @@ pmapUnionWith = phoistAcyclic $
|
|||
# plam
|
||||
( \p -> P.do
|
||||
pf <- plet $ pfstBuiltin # p
|
||||
ps <- plet $ psndBuiltin # p
|
||||
pmatch (plookup # pf # ys) $ \case
|
||||
PJust v ->
|
||||
-- Data conversions here are silly, aren't they?
|
||||
ppairDataBuiltin # pf # pdata (f # pfromData ps # pfromData v)
|
||||
ppairDataBuiltin # pf # pdata (f # pfromData (psndBuiltin # p) # pfromData v)
|
||||
PNothing -> p
|
||||
)
|
||||
# xs
|
||||
|
|
@ -246,46 +259,100 @@ paddValue = phoistAcyclic $
|
|||
)
|
||||
|
||||
-- | Sum of all value at input.
|
||||
pvalueSpent :: Term s (PTxInfo :--> PValue)
|
||||
pvalueSpent :: Term s (PBuiltinList (PAsData PTxInInfo) :--> PValue)
|
||||
pvalueSpent = phoistAcyclic $
|
||||
plam $ \txInfo' ->
|
||||
pmatch txInfo' $ \(PTxInfo txInfo) ->
|
||||
pfoldr
|
||||
# plam
|
||||
( \txInInfo' v ->
|
||||
pmatch
|
||||
(pfromData txInInfo')
|
||||
$ \(PTxInInfo txInInfo) ->
|
||||
paddValue
|
||||
# pmatch
|
||||
(pfield @"resolved" # txInInfo)
|
||||
(\(PTxOut o) -> pfromData $ pfield @"value" # o)
|
||||
# v
|
||||
)
|
||||
# pconstant mempty
|
||||
# (pfield @"inputs" # txInfo)
|
||||
plam $ \inputs ->
|
||||
pfoldr
|
||||
# plam
|
||||
( \txInInfo' v ->
|
||||
pmatch
|
||||
(pfromData txInInfo')
|
||||
$ \(PTxInInfo txInInfo) ->
|
||||
paddValue
|
||||
# pmatch
|
||||
(pfield @"resolved" # txInInfo)
|
||||
(\(PTxOut o) -> pfromData $ pfield @"value" # o)
|
||||
# v
|
||||
)
|
||||
# pconstant mempty
|
||||
# inputs
|
||||
|
||||
-- | Find the TxInInfo by a TxOutRef.
|
||||
pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PTxInfo :--> PMaybe PTxInInfo)
|
||||
pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PBuiltinList (PAsData PTxInInfo) :--> PMaybe PTxInInfo)
|
||||
pfindTxInByTxOutRef = phoistAcyclic $
|
||||
plam $ \txOutRef txInfo' ->
|
||||
pmatch txInfo' $ \(PTxInfo txInfo) ->
|
||||
pfindMap
|
||||
# plam
|
||||
( \txInInfo' ->
|
||||
plet (pfromData txInInfo') $ \r ->
|
||||
pmatch r $ \(PTxInInfo txInInfo) ->
|
||||
pif
|
||||
(pdata txOutRef #== pfield @"outRef" # txInInfo)
|
||||
(pcon (PJust r))
|
||||
(pcon PNothing)
|
||||
)
|
||||
#$ (pfield @"inputs" # txInfo)
|
||||
plam $ \txOutRef inputs ->
|
||||
pfindMap
|
||||
# plam
|
||||
( \txInInfo' ->
|
||||
plet (pfromData txInInfo') $ \r ->
|
||||
pmatch r $ \(PTxInInfo txInInfo) ->
|
||||
pif
|
||||
(pdata txOutRef #== pfield @"outRef" # txInInfo)
|
||||
(pcon (PJust r))
|
||||
(pcon PNothing)
|
||||
)
|
||||
#$ inputs
|
||||
|
||||
-- | 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)
|
||||
|
||||
{- | Check if a particular asset class has been spent in the input list.
|
||||
|
||||
When using this as an authority check, you __MUST__ ensure the authority
|
||||
knows how to ensure its end of the contract.
|
||||
-}
|
||||
ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool)
|
||||
ptokenSpent =
|
||||
plam $ \tokenClass inputs ->
|
||||
0
|
||||
#< pfoldr @PBuiltinList
|
||||
# plam
|
||||
( \txInInfo' acc -> P.do
|
||||
PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
|
||||
PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
|
||||
txOut <- pletFields @'["value"] txOut'
|
||||
let txOutValue = pfromData txOut.value
|
||||
acc + passetClassValueOf # txOutValue # tokenClass
|
||||
)
|
||||
# 0
|
||||
# inputs
|
||||
|
||||
{- | True if both maps have exactly the same keys.
|
||||
Using @'#=='@ is not sufficient, because keys returned are not ordered.
|
||||
-}
|
||||
pkeysEqual :: forall (s :: S) k a b. Term s (PMap k a :--> PMap k b :--> PBool)
|
||||
pkeysEqual = phoistAcyclic $
|
||||
plam $ \p q -> P.do
|
||||
pks <- plet $ pkeys # p
|
||||
qks <- plet $ pkeys # q
|
||||
pall # plam (\pk -> pelem # pk # qks) # pks
|
||||
#&& pall # plam (\qk -> pelem # qk # pks) # qks
|
||||
|
||||
-- | / O(n^2) /. Clear out duplicates in a list. The order is not preserved.
|
||||
pnub :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> list a)
|
||||
pnub =
|
||||
phoistAcyclic $
|
||||
precList
|
||||
( \self x xs ->
|
||||
pif
|
||||
(pnot #$ pelem # x # xs)
|
||||
(pcons # x # (self # xs))
|
||||
(self # xs)
|
||||
)
|
||||
(const pnil)
|
||||
|
||||
-- | / O(n^2) /. Check if a list contains no duplicates.
|
||||
pisUniq :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> PBool)
|
||||
pisUniq =
|
||||
phoistAcyclic $
|
||||
precList
|
||||
( \self x xs ->
|
||||
(pnot #$ pelem # x # xs)
|
||||
#&& (self # xs)
|
||||
)
|
||||
(const $ pcon PTrue)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
{- Functions which should (probably) not be upstreamed
|
||||
All of these functions are quite inefficient.
|
||||
|
|
@ -295,18 +362,19 @@ pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse)
|
|||
anyOutput ::
|
||||
forall (datum :: PType) s.
|
||||
( PIsData datum
|
||||
, PTryFrom PData (PAsData datum)
|
||||
) =>
|
||||
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
|
||||
anyOutput = phoistAcyclic $
|
||||
plam $ \txInfo' predicate -> P.do
|
||||
txInfo <- pletFields @'["outputs"] txInfo'
|
||||
txInfo <- pletFields @'["outputs", "datums"] txInfo'
|
||||
pany
|
||||
# plam
|
||||
( \txOut'' -> P.do
|
||||
PTxOut txOut' <- pmatch (pfromData txOut'')
|
||||
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
|
||||
PDJust dh <- pmatch txOut.datumHash
|
||||
pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
|
||||
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
|
||||
PJust datum -> P.do
|
||||
predicate # txOut.value # txOut.address # pfromData datum
|
||||
PNothing -> pcon PFalse
|
||||
|
|
@ -317,18 +385,19 @@ anyOutput = phoistAcyclic $
|
|||
allOutputs ::
|
||||
forall (datum :: PType) s.
|
||||
( PIsData datum
|
||||
, PTryFrom PData (PAsData datum)
|
||||
) =>
|
||||
Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
|
||||
allOutputs = phoistAcyclic $
|
||||
plam $ \txInfo' predicate -> P.do
|
||||
txInfo <- pletFields @'["outputs"] txInfo'
|
||||
txInfo <- pletFields @'["outputs", "datums"] txInfo'
|
||||
pall
|
||||
# plam
|
||||
( \txOut'' -> P.do
|
||||
PTxOut txOut' <- pmatch (pfromData txOut'')
|
||||
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
|
||||
PDJust dh <- pmatch txOut.datumHash
|
||||
pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
|
||||
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
|
||||
PJust datum -> P.do
|
||||
predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
|
||||
PNothing -> pcon PFalse
|
||||
|
|
@ -339,11 +408,12 @@ allOutputs = phoistAcyclic $
|
|||
anyInput ::
|
||||
forall (datum :: PType) s.
|
||||
( PIsData datum
|
||||
, PTryFrom PData (PAsData datum)
|
||||
) =>
|
||||
Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
|
||||
anyInput = phoistAcyclic $
|
||||
plam $ \txInfo' predicate -> P.do
|
||||
txInfo <- pletFields @'["inputs"] txInfo'
|
||||
txInfo <- pletFields @'["inputs", "datums"] txInfo'
|
||||
pany
|
||||
# plam
|
||||
( \txInInfo'' -> P.do
|
||||
|
|
@ -352,37 +422,13 @@ anyInput = phoistAcyclic $
|
|||
PTxOut txOut' <- pmatch (pfromData txOut'')
|
||||
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
|
||||
PDJust dh <- pmatch txOut.datumHash
|
||||
pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
|
||||
pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
|
||||
PJust datum -> P.do
|
||||
predicate # txOut.value # txOut.address # pfromData datum
|
||||
PNothing -> pcon PFalse
|
||||
)
|
||||
# pfromData txInfo.inputs
|
||||
|
||||
-- | Check if all (resolved) inputs match the predicate.
|
||||
allInputs ::
|
||||
forall (datum :: PType) s.
|
||||
( PIsData datum
|
||||
) =>
|
||||
Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
|
||||
allInputs = phoistAcyclic $
|
||||
plam $ \txInfo' predicate -> P.do
|
||||
txInfo <- pletFields @'["inputs"] txInfo'
|
||||
pall
|
||||
# plam
|
||||
( \txInInfo'' -> P.do
|
||||
PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'')
|
||||
let txOut'' = pfield @"resolved" # txInInfo'
|
||||
PTxOut txOut' <- pmatch (pfromData txOut'')
|
||||
txOut <- pletFields @'["value", "datumHash", "address"] txOut'
|
||||
PDJust dh <- pmatch txOut.datumHash
|
||||
pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
|
||||
PJust datum -> P.do
|
||||
predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
|
||||
PNothing -> pcon PFalse
|
||||
)
|
||||
# pfromData txInfo.inputs
|
||||
|
||||
-- | Create a value with a single asset class.
|
||||
psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue)
|
||||
psingletonValue = phoistAcyclic $
|
||||
|
|
@ -391,3 +437,46 @@ psingletonValue = phoistAcyclic $
|
|||
outerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata sym # pdata innerTup
|
||||
res = pcon $ PValue outerTup
|
||||
in res
|
||||
|
||||
-- | Finds the TxOut of an effect from TxInfo and TxOutRef
|
||||
findTxOutByTxOutRef :: Term s (PTxOutRef :--> PBuiltinList (PAsData PTxInInfo) :--> PMaybe PTxOut)
|
||||
findTxOutByTxOutRef = phoistAcyclic $
|
||||
plam $ \txOutRef inputs ->
|
||||
pmatch (pfindTxInByTxOutRef # txOutRef # inputs) $ \case
|
||||
PJust ((pfield @"resolved" #) -> txOut) -> pcon $ PJust txOut
|
||||
PNothing -> pcon PNothing
|
||||
|
||||
-- | Get script hash from an Address.
|
||||
scriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash)
|
||||
scriptHashFromAddress = phoistAcyclic $
|
||||
plam $ \addr ->
|
||||
pmatch (pfromData $ pfield @"credential" # addr) $ \case
|
||||
PScriptCredential ((pfield @"_0" #) -> h) -> pcon $ PJust h
|
||||
_ -> pcon PNothing
|
||||
|
||||
-- | Find all TxOuts sent to an Address
|
||||
findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut))
|
||||
findOutputsToAddress = phoistAcyclic $
|
||||
plam $ \outputs address' -> P.do
|
||||
address <- plet $ pdata address'
|
||||
pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address)
|
||||
# outputs
|
||||
|
||||
-- | Find the data corresponding to a TxOut, if there is one
|
||||
findTxOutDatum :: Term s (PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PTxOut :--> PMaybe PDatum)
|
||||
findTxOutDatum = phoistAcyclic $
|
||||
plam $ \datums out -> P.do
|
||||
datumHash' <- pmatch $ pfromData $ pfield @"datumHash" # out
|
||||
case datumHash' of
|
||||
PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums
|
||||
_ -> pcon PNothing
|
||||
|
||||
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
-}
|
||||
validatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName
|
||||
validatorHashToTokenName vh = pcon (PTokenName (pto vh))
|
||||
|
||||
-- | Get the CurrencySymbol of a PMintingPolicy.
|
||||
getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
|
||||
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v
|
||||
|
|
|
|||
|
|
@ -11,8 +11,7 @@ module PPrelude (
|
|||
module Plutarch,
|
||||
) where
|
||||
|
||||
-- NOTE: These are not exported by Plutarch.Prelude, for some reason.
|
||||
-- Maybe we can 'fix' this upstream?
|
||||
import Plutarch (ClosedTerm, POpaque, compile)
|
||||
-- 'compile' is not exported by Plutarch.Prelude.
|
||||
import Plutarch (compile)
|
||||
import Plutarch.Prelude
|
||||
import Prelude
|
||||
|
|
|
|||
|
|
@ -17,5 +17,5 @@ The following is a list of terms that are used frequently throughout the documen
|
|||
- **DAO**: decentralised autonomous organisation.
|
||||
- **Proposal**: a set of changes to a Cardano protocol, suggested by a community member. Will be enacted, if passed by the community.
|
||||
- **Governance token (GT)**: the token that confers the right to vote on proposals within the protocol. May affect the user's eligibility for rewards. Examples include Liqwid's LQ.
|
||||
- **Governance authority token (GAT)**: A token that grant's the effects of a proposal the authority to alter the system. More information can be read [here](./tech-design/authority-tokens.md).
|
||||
- **Governance authority token (GAT)**: A token that grants the effects of a proposal the authority to alter the system. More information can be read [here](./tech-design/authority-tokens.md).
|
||||
- **Effect**: A script for implementing changes suggested by a proposal. An effect can make numerous changes and a proposal may have multiple effects.
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ This document gives an overview of the technical design of the proposals system
|
|||
|
||||
| Specification | Implementation | Last revision |
|
||||
|:-----------:|:-----------:|:-------------:|
|
||||
| WIP | WIP | v0.1 2022-04-11 |
|
||||
| WIP | WIP | v0.1 2022-04-27 |
|
||||
|
||||
---
|
||||
|
||||
|
|
@ -35,35 +35,31 @@ Initiating a proposal requires the proposer to have more than a certain amount o
|
|||
|
||||
### Voting stages
|
||||
|
||||
The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' phase being the initial state, and 'executed' and 'failed' being the terminating states. Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.
|
||||
The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' state being the initial state, and 'executed' and 'failed' being the terminating states.
|
||||
|
||||
Note: this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.
|
||||
**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some transitions in the state machine representation don't need to happen on-chain, as a transaction. A key example of this is a proposal going from the "lock" phase to the "execution" phase. No on-chain transition takes place: it is simply that we have reached the time in the real-world, when the proposal is allowed to be executed.
|
||||
|
||||
To make the following diagram clear, we employ the following terminology:
|
||||
|
||||
|
||||
> state
|
||||
> A 'state' in our conceptual FSM representation above. Useful for thinking about proposals. Does not necessarily reflect a change occurring on-chain.
|
||||
|
||||
|
||||
> period
|
||||
> A segment of real-world, POSIX time. As we transition from one period to another, a proposal's status (see below) will not be updated.
|
||||
|
||||
|
||||
> status
|
||||
> The 'status' of a proposal is stored in the proposal's datum and is thus always represented on-chain. Changing this requires a transaction to take place.
|
||||
|
||||
|
||||
|
||||
|
||||
#### When may interactions occur?
|
||||
|
||||
Consider the following 'stages' of a proposal:
|
||||
|
||||
- `S`: when the proposal was created.
|
||||
- `D`: the length of the draft period.
|
||||
- `V`: the length of the voting period.
|
||||
- `L`: the length of the locking period.
|
||||
- `E`: the length of the execution period.
|
||||
|
||||
| Action | Valid POSIXTimeRange | Valid _stored_ state(s) |
|
||||
|-------------------------------------|-------------------------------------|-------------------------|
|
||||
| Witness | \[S, ∞) | \* |
|
||||
| Cosign | \[S, S + D) | Draft |
|
||||
| AdvanceProposal | \[S, S + D) | Draft |
|
||||
| Vote | \[S + D, S + D + V) | Voting |
|
||||
| Unlock | \[S + D, ∞) | \* |
|
||||
| CountVotes | \[S + D + V, S + D + V + L) | Voting |
|
||||
| ExecuteProposal (if quorum reached) | \[S + D + V + L, S + D + V + L + E) | Voting |
|
||||
|
||||
> Jack 2022-02-02: I will consider revising this table further at a later time.
|
||||
|
||||
#### Draft phase
|
||||
|
||||
During the draft phase, a new UTXO at the proposal script has been created. At this stage, only votes in favor of co-signing the draft are counted. For the proposal to transition to the voting phase, a threshold of GT will have to be staked backing the proposal. This threshold will be determined on a per-system basis and could itself be a 'governable' parameter. It's important to note that cosignatures are not locking votes. Cosignatures are more like a delegated approval to a proposal. The sum of all cosignatures must tally to the threshold, and all cosigner stake datums must fit into a single transaction to witness their size.
|
||||
During the draft phase, a new UTXO at the proposal script has been created. At this stage, only votes in favor of co-signing the draft are counted. For the proposal to transition to the voting phase, a threshold of GT will have to be staked backing the proposal. This threshold will be determined on a per-system basis and could itself be a 'governable' parameter. It's important to note that cosignatures are not locking votes. Cosignatures are more like a delegated approval to a proposal. The sum of all cosignatures must tally to the threshold, and all cosigner stake datums must fit into a single transaction to witness their size. A limit on the maximum amount of cosigners is placed in order to prevent a situation where the stake datums no longer fit in the transaction. The number doesn't matter and may be expressed in a parameterized way.
|
||||
|
||||
#### Voting phase
|
||||
|
||||
|
|
|
|||
190
flake.lock
generated
190
flake.lock
generated
|
|
@ -103,34 +103,17 @@
|
|||
"plutus": "plutus"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1649673880,
|
||||
"narHash": "sha256-LpR+F+fHB6Mh1NHI2O+3zeeSE+ZzyVBwuP9T12X3rek=",
|
||||
"owner": "mlabs-haskell",
|
||||
"lastModified": 1648805998,
|
||||
"narHash": "sha256-TWEiUifHkhgCHqe70aNn9j6LdFFWv2nMbSWV8hR59oE=",
|
||||
"owner": "jhodgdev",
|
||||
"repo": "apropos-tx",
|
||||
"rev": "dd292b49a29f8a259bdc3e35cf4ab1dbbc73582f",
|
||||
"rev": "4eca3fac23c339caee04ea6176e641a4b3857a25",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "mlabs-haskell",
|
||||
"owner": "jhodgdev",
|
||||
"repo": "apropos-tx",
|
||||
"rev": "dd292b49a29f8a259bdc3e35cf4ab1dbbc73582f",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"autodocodec": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1644358110,
|
||||
"narHash": "sha256-X1TNZlmO2qDFk3OL4Z1v/gzvd3ouoACAiMweutsYek4=",
|
||||
"owner": "srid",
|
||||
"repo": "autodocodec",
|
||||
"rev": "42b42a7407f33c6c74fa4e8c84906aebfed28daf",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "srid",
|
||||
"ref": "ghc921",
|
||||
"repo": "autodocodec",
|
||||
"rev": "4eca3fac23c339caee04ea6176e641a4b3857a25",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
|
|
@ -463,21 +446,6 @@
|
|||
"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": {
|
||||
|
|
@ -495,22 +463,6 @@
|
|||
}
|
||||
},
|
||||
"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,
|
||||
|
|
@ -527,7 +479,7 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flake-compat_5": {
|
||||
"flake-compat_4": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1606424373,
|
||||
|
|
@ -981,7 +933,7 @@
|
|||
},
|
||||
"hercules-ci-agent": {
|
||||
"inputs": {
|
||||
"flake-compat": "flake-compat_5",
|
||||
"flake-compat": "flake-compat_4",
|
||||
"nix-darwin": "nix-darwin",
|
||||
"nixos-20_09": "nixos-20_09",
|
||||
"nixos-unstable": "nixos-unstable",
|
||||
|
|
@ -1004,7 +956,7 @@
|
|||
},
|
||||
"hercules-ci-effects": {
|
||||
"inputs": {
|
||||
"flake-compat": "flake-compat_4",
|
||||
"flake-compat": "flake-compat_3",
|
||||
"hercules-ci-agent": "hercules-ci-agent",
|
||||
"nixpkgs": "nixpkgs_3",
|
||||
"nixpkgs-nixops": "nixpkgs-nixops"
|
||||
|
|
@ -1088,6 +1040,55 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"hspec": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1649095108,
|
||||
"narHash": "sha256-cPmt4hvmdh727VT6UAL8yFArmm4FAWeg3K5Qi3XtU4g=",
|
||||
"owner": "srid",
|
||||
"repo": "hspec",
|
||||
"rev": "44f2a143e10c93df237af428457d0e4b74ae270a",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "srid",
|
||||
"ref": "askAncestors",
|
||||
"repo": "hspec",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"hspec-golden": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1648755064,
|
||||
"narHash": "sha256-5a6BksZx00o2iL0Ei/L1Kkou2BsnsIagN+tTmqYyKfs=",
|
||||
"owner": "stackbuilders",
|
||||
"repo": "hspec-golden",
|
||||
"rev": "4b0ad56b2de0254a7b1e0feda917656f78a5bcda",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "stackbuilders",
|
||||
"repo": "hspec-golden",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"hspec-hedgehog": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1602603478,
|
||||
"narHash": "sha256-XnS3zjQ7eh3iBOWq+Z/YcwrfWI55hV6k8LsZ8qm/qOc=",
|
||||
"owner": "parsonsmatt",
|
||||
"repo": "hspec-hedgehog",
|
||||
"rev": "eb617d854542510f0129acdea4bf52e50b13042e",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "parsonsmatt",
|
||||
"repo": "hspec-hedgehog",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"iohk-nix": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -1592,19 +1593,24 @@
|
|||
"plutarch": {
|
||||
"inputs": {
|
||||
"Shrinker": "Shrinker",
|
||||
"autodocodec": "autodocodec",
|
||||
"cardano-base": "cardano-base",
|
||||
"cardano-crypto": "cardano-crypto",
|
||||
"cardano-prelude": "cardano-prelude",
|
||||
"cryptonite": "cryptonite",
|
||||
"flake-compat": "flake-compat_3",
|
||||
"flake-compat-ci": "flake-compat-ci_3",
|
||||
"emanote": [
|
||||
"plutarch",
|
||||
"haskell-nix",
|
||||
"nixpkgs-unstable"
|
||||
],
|
||||
"flat": "flat",
|
||||
"foundation": "foundation",
|
||||
"haskell-language-server": "haskell-language-server_2",
|
||||
"haskell-nix": "haskell-nix_4",
|
||||
"hercules-ci-effects": "hercules-ci-effects",
|
||||
"hs-memory": "hs-memory",
|
||||
"hspec": "hspec",
|
||||
"hspec-golden": "hspec-golden",
|
||||
"hspec-hedgehog": "hspec-hedgehog",
|
||||
"iohk-nix": "iohk-nix_2",
|
||||
"nixpkgs": [
|
||||
"plutarch",
|
||||
|
|
@ -1614,24 +1620,21 @@
|
|||
"nixpkgs-2111": "nixpkgs-2111_5",
|
||||
"plutus": "plutus_2",
|
||||
"protolude": "protolude",
|
||||
"safe-coloured-text": "safe-coloured-text",
|
||||
"sized-functors": "sized-functors",
|
||||
"sydtest": "sydtest",
|
||||
"th-extras": "th-extras",
|
||||
"validity": "validity"
|
||||
"th-extras": "th-extras"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1648639396,
|
||||
"narHash": "sha256-pAkEsIDXJckVYufVPUzD/4sq4/uE7iyV0IR2BuLhZjY=",
|
||||
"lastModified": 1650382454,
|
||||
"narHash": "sha256-b31DK+E/0MtR45+Z+F5U1E8jjcewvZ42UmFLZlXDAYM=",
|
||||
"owner": "peter-mlabs",
|
||||
"repo": "plutarch",
|
||||
"rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
|
||||
"rev": "6ef18aacd02050fc07398e399cff5e8734c1045e",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "peter-mlabs",
|
||||
"repo": "plutarch",
|
||||
"rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
|
||||
"rev": "6ef18aacd02050fc07398e399cff5e8734c1045e",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
|
|
@ -1771,23 +1774,6 @@
|
|||
"plutarch": "plutarch"
|
||||
}
|
||||
},
|
||||
"safe-coloured-text": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1644357337,
|
||||
"narHash": "sha256-sXSKw8m6O9K/H2BBiYqO5e4sJIo+9UP+UvEukRn28d8=",
|
||||
"owner": "srid",
|
||||
"repo": "safe-coloured-text",
|
||||
"rev": "034f3612525568b422e0c62b52417d77b7cf31c2",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "srid",
|
||||
"ref": "ghc921",
|
||||
"repo": "safe-coloured-text",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"sized-functors": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -1917,23 +1903,6 @@
|
|||
"type": "github"
|
||||
}
|
||||
},
|
||||
"sydtest": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1645114028,
|
||||
"narHash": "sha256-P6ZwwfFeN8fpi3fziz9yERTn7BfxdE/j/OofUu+4GdA=",
|
||||
"owner": "srid",
|
||||
"repo": "sydtest",
|
||||
"rev": "9c6c7678f7aabe22e075aab810a6a2e304591d24",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "srid",
|
||||
"ref": "ghc921",
|
||||
"repo": "sydtest",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"th-extras": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
|
|
@ -1950,23 +1919,6 @@
|
|||
"rev": "787ed752c1e5d41b5903b74e171ed087de38bffa",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"validity": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1644358698,
|
||||
"narHash": "sha256-dpMIu08qXMzy8Kilk/2VWpuwIsfqFtpg/3mkwt5pdjA=",
|
||||
"owner": "srid",
|
||||
"repo": "validity",
|
||||
"rev": "f7982549b95d0ab727950dc876ca06b1862135ba",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "srid",
|
||||
"ref": "ghc921",
|
||||
"repo": "validity",
|
||||
"type": "github"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
|
|
|
|||
33
flake.nix
33
flake.nix
|
|
@ -7,9 +7,10 @@
|
|||
# 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:peter-mlabs/plutarch?rev=a7a410da209b9c14c834a41e07b1c197c2a4dcd6";
|
||||
"github:peter-mlabs/plutarch?rev=6ef18aacd02050fc07398e399cff5e8734c1045e";
|
||||
inputs.plutarch.inputs.emanote.follows =
|
||||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
inputs.plutarch.inputs.nixpkgs.follows =
|
||||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
|
||||
|
|
@ -19,7 +20,7 @@
|
|||
# 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:mlabs-haskell/apropos-tx?rev=dd292b49a29f8a259bdc3e35cf4ab1dbbc73582f";
|
||||
"github:jhodgdev/apropos-tx?rev=4eca3fac23c339caee04ea6176e641a4b3857a25";
|
||||
inputs.apropos-tx.inputs.nixpkgs.follows =
|
||||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
inputs.apropos.url =
|
||||
|
|
@ -117,6 +118,11 @@
|
|||
let
|
||||
pkgs = nixpkgsFor system;
|
||||
pkgs' = nixpkgsFor' system;
|
||||
|
||||
inherit (pkgs.haskell-nix.tools ghcVersion {
|
||||
inherit (plutarch.tools) fourmolu;
|
||||
})
|
||||
fourmolu;
|
||||
in
|
||||
pkgs.runCommand "format-check"
|
||||
{
|
||||
|
|
@ -125,9 +131,8 @@
|
|||
pkgs'.fd
|
||||
pkgs'.haskellPackages.cabal-fmt
|
||||
pkgs'.nixpkgs-fmt
|
||||
(pkgs.haskell-nix.tools ghcVersion {
|
||||
inherit (plutarch.tools) fourmolu;
|
||||
}).fourmolu
|
||||
fourmolu
|
||||
pkgs'.haskell.packages."${ghcVersion}".hlint
|
||||
];
|
||||
} ''
|
||||
export LC_CTYPE=C.UTF-8
|
||||
|
|
@ -135,14 +140,28 @@
|
|||
export LANG=C.UTF-8
|
||||
cd ${self}
|
||||
make format_check || (echo " Please run 'make format'" ; exit 1)
|
||||
find -name '*.hs' -not -path './dist*/*' -not -path './haddock/*' | xargs hlint
|
||||
mkdir $out
|
||||
'';
|
||||
|
||||
in
|
||||
{
|
||||
project = perSystem projectFor;
|
||||
flake = perSystem (system: (projectFor system).flake { });
|
||||
|
||||
packages = perSystem (system: self.flake.${system}.packages);
|
||||
packages = perSystem (system:
|
||||
self.flake.${system}.packages // {
|
||||
haddock =
|
||||
let
|
||||
agora-doc = self.flake.${system}.packages."agora:lib:agora".doc;
|
||||
pkgs = nixpkgsFor system;
|
||||
in
|
||||
pkgs.runCommand "haddock-merge" { } ''
|
||||
cd ${self}
|
||||
mkdir $out
|
||||
cp -r ${agora-doc}/share/doc/* $out
|
||||
'';
|
||||
});
|
||||
|
||||
# Define what we want to test
|
||||
checks = perSystem (system:
|
||||
|
|
|
|||
6
hie.yaml
6
hie.yaml
|
|
@ -1,8 +1,2 @@
|
|||
cradle:
|
||||
cabal:
|
||||
- path: "./agora"
|
||||
component: "lib:agora"
|
||||
- path: "./agora-bench"
|
||||
component: "benchmark:agora-bench"
|
||||
- path: "./agora-test"
|
||||
component: "test:agora-test"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue