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

Merge pull request #150 from Liqwid-Labs/connor/liqwid-nix

Browse source 
Use `liqwid-nix`; Bump plutarch
This commit is contained in:
emiflake 2022-08-12 14:38:22 +02:00 • committed by GitHub
commit 8516dec99c
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
50 changed files with 5350 additions and 5994 deletions
Download patch file Download diff file Expand all files Collapse all files

95
Makefile
View file

@ -1,12 +1,31 @@
# This really ought to be `/usr/bin/env bash`, but nix flakes don't like that.
SHELL := /bin/sh
.PHONY: hoogle format haddock usage tag format_nix format_haskell format_check lint ps_bridge bench bench_check scripts
.PHONY: hoogle format haddock usage tag format_nix format_haskell format_check \
lint refactor ps_bridge bench bench_check scripts test build ci
AGORA_TARGETS := agora agora-bench agora-purescript-bridge agora-scripts agora-specs agora-test agora-testlib
SOURCE_FILES := $(shell git ls-tree -r HEAD --full-tree --name-only)
SOURCE_FILES := $(wildcard $(SOURCE_FILES))
HASKELL_SOURCES := $(filter %.hs,$(SOURCE_FILES))
CABAL_SOURCES := $(filter %.cabal,$(SOURCE_FILES))
NIX_SOURCES := $(filter %.nix,$(SOURCE_FILES))
FORMAT_EXTENSIONS := -o -XQuasiQuotes -o -XTemplateHaskell -o -XTypeApplications \
-o -XImportQualifiedPost -o -XPatternSynonyms -o -XOverloadedRecordDot
HLINT_EXTS := -XQuasiQuotes
THREADS ?= 8
PS_BRIDGE_OUTPUT_DIR ?= agora-purescript-bridge/
BENCH_OUTPUT ?= bench.csv
TEST_CASE_TIMEOUT ?= 100
usage:
@echo "usage: make <command> [OPTIONS]"
@echo "usage: [env [<variable>=<value> ...]] make <command> [OPTIONS]"
@echo
@echo "Available variables:"
@echo " THREADS -- The number of threads for building the project"
@echo " PS_BRIDGE_OUTPUT_DIR -- The output directory of the purescript bridge"
@echo " BENCH_OUTPUT -- The output file of the benchmark report"
@echo " TEST_CASE_TIMEOUT -- Timeout for individual tests. Default unit: s"
@echo
@echo "Available commands:"
@echo " hoogle -- Start local hoogle"
@ -21,8 +40,13 @@ usage:
@echo " bench -- Generate bench report bench.csv"
@echo " bench_check -- Check if bench report is up-to-date"
@echo " scripts -- Run the agora script server (dev mode)"
@echo " ci -- Run all the CI checks"
hoogle:
requires_nix_shell:
@ [ "$(IN_NIX_SHELL)" ] || echo "The $(MAKECMDGOALS) target must be run from inside a nix shell"
@ [ "$(IN_NIX_SHELL)" ] || (echo " run 'nix develop' first" && false)
hoogle: requires_nix_shell
pkill hoogle || true
hoogle generate --local=haddock --database=hoo/local.hoo
hoogle server --local -p 8081 >> /dev/null &
@ -30,45 +54,48 @@ hoogle:
format: format_haskell format_nix
format_nix:
git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.nix' | xargs nixpkgs-fmt
format_nix: requires_nix_shell
nixpkgs-fmt $(NIX_SOURCES)
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_haskell: requires_nix_shell
fourmolu $(FORMAT_EXTENSIONS) -m inplace $(HASKELL_SOURCES)
cabal-fmt -i $(CABAL_SOURCES)
format_check:
find -name '*.hs' \
-not -path './dist*/*' \
-not -path './haddock/*' \
| xargs fourmolu $(FORMAT_EXTENSIONS) -m check
format_check: requires_nix_shell
fourmolu $(FORMAT_EXTENSIONS) -m check $(HASKELL_SOURCES)
nixpkgs-fmt --check $(NIX_SOURCES)
cabal-fmt --check $(CABAL_SOURCES)
haddock:
haddock: requires_nix_shell
cabal haddock --haddock-html --haddock-hoogle --builddir=haddock
tag:
hasktags -x $(AGORA_TARGETS)
tag: requires_nix_shell
hasktags -x $(HASKELL_SOURCES)
lint:
hlint $(AGORA_TARGETS)
lint: requires_nix_shell
hlint $(HLINT_EXTS) $(HASKELL_SOURCES)
PS_BRIDGE_OUTPUT_DIR := agora-purescript-bridge/
ps_bridge:
refactor: requires_nix_shell
for src in $(HASKELL_SOURCES) ; do \
hlint $(HLINT_EXTS) --refactor --refactor-options='-i -s' $$src ;\
done
ps_bridge: requires_nix_shell
cabal run exe:agora-purescript-bridge -- -o $(PS_BRIDGE_OUTPUT_DIR)
bench:
cabal run agora-bench
bench: requires_nix_shell
cabal run agora-bench -- -o $(BENCH_OUTPUT)
BENCH_TMPDIR := $(shell mktemp -d)
BENCH_TMPFILE := $(BENCH_TMPDIR)/bench.csv
bench_check:
(cabal run agora-bench -- -o "$(BENCH_TMPFILE)" \
|| $(bench) -o "$(BENCH_TMPFILE)") >> /dev/null
diff bench.csv $(BENCH_TMPFILE) \
|| (echo "bench.csv is outdated"; exit 1)
# TODO: do the clean-up even if `diff` fails.
rm -rf $(BENCH_TMPDIR)
bench_check: requires_nix_shell
cabal -v0 new-run agora-bench | diff bench.csv -
scripts:
scripts: requires_nix_shell
cabal run agora-scripts -- -c
test: requires_nix_shell
cabal test --test-options="--hide-successes -t $(TEST_CASE_TIMEOUT) -j$(THREADS)"
build: requires_nix_shell
cabal build -j$(THREADS)
ci: format_check lint build bench_check test haddock

1
agora-bench/Bench.hs
View file

@ -8,7 +8,6 @@ import Data.ByteString.Short qualified as SBS
import Data.Csv (DefaultOrdered, ToNamedRecord, header, headerOrder, namedRecord, toNamedRecord, (.=))
import Data.List (intercalate)
import Data.Text (Text, pack)
import GHC.Generics (Generic)
import Plutarch.Evaluate (evalScript)
import PlutusLedgerApi.V1 (
ExBudget (ExBudget),

18
agora-bench/Main.hs
View file

@ -3,10 +3,10 @@ module Main (main) where
import Bench (specificationTreeToBenchmarks)
import Data.Csv (EncodeOptions (encUseCrLf), defaultEncodeOptions, encodeDefaultOrderedByNameWith)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Text.Lazy.IO as I (writeFile)
import Data.Text.Lazy.IO as I (putStr, writeFile)
import Options (Options (..), parseOptions)
import Prettyprinter (defaultLayoutOptions, layoutPretty, pretty)
import Prettyprinter.Render.String (renderString)
import Prettyprinter.Render.Text (renderLazy)
import Spec.AuthorityToken qualified as AuthorityToken
import Spec.Effect.GovernorMutation qualified as GovernorMutation
import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
@ -14,6 +14,7 @@ import Spec.Governor qualified as Governor
import Spec.Proposal qualified as Proposal
import Spec.Stake qualified as Stake
import Spec.Treasury qualified as Treasury
import System.IO (hIsTerminalDevice, stdout)
import Test.Specification (group)
import Prelude
@ -22,11 +23,14 @@ import Prelude
main :: IO ()
main = do
options <- parseOptions
isTTY <- hIsTerminalDevice stdout
I.writeFile options.output $
(decodeUtf8 . encodeDefaultOrderedByNameWith encodeOptions) res
mapM_ (`I.writeFile` csv) options.output
mapM_ (putStrLn . renderString . layoutPretty defaultLayoutOptions . pretty) res
I.putStr $
if isTTY
then prettified
else csv
where
encodeOptions =
defaultEncodeOptions
@ -49,3 +53,7 @@ main = do
, group "AuthorityToken" AuthorityToken.specs
, group "Governor" Governor.specs
]
csv = decodeUtf8 $ encodeDefaultOrderedByNameWith encodeOptions res
prettified = renderLazy $ layoutPretty defaultLayoutOptions $ pretty res

7
agora-bench/Options.hs
View file

@ -1,19 +1,20 @@
module Options (Options (..), parseOptions) where
import Control.Applicative (optional)
import Options.Applicative ((<**>))
import Options.Applicative qualified as Opt
newtype Options = Options
{ output :: FilePath
{ output :: Maybe FilePath
}
outputOpt :: Opt.Parser FilePath
outputOpt :: Opt.Parser (Maybe FilePath)
outputOpt =
optional $
Opt.strOption
( Opt.long "output-path"
<> Opt.short 'o'
<> Opt.metavar "OUTPUT_PATH"
<> Opt.value "./bench.csv"
<> Opt.help "The path of the bench report file."
)

4
agora-purescript-bridge/AgoraTypes.hs
View file

@ -31,14 +31,12 @@ agoraTypes =
, mkSumType (Proxy @Proposal.ProposalVotes)
, mkSumType (Proxy @Proposal.ProposalDatum)
, mkSumType (Proxy @Proposal.ProposalRedeemer)
, mkSumType (Proxy @Proposal.Proposal)
, -- Governor
mkSumType (Proxy @Governor.GovernorDatum)
, mkSumType (Proxy @Governor.GovernorRedeemer)
, mkSumType (Proxy @Governor.Governor)
, -- Stake
mkSumType (Proxy @Stake.Stake)
, mkSumType (Proxy @Stake.ProposalLock)
mkSumType (Proxy @Stake.ProposalLock)
, mkSumType (Proxy @Stake.StakeRedeemer)
, mkSumType (Proxy @Stake.StakeDatum)
, -- Treasury

91
agora-scripts/Main.hs
View file

@ -8,16 +8,11 @@
-}
module Main (main) where
import Agora.AuthorityToken (AuthorityToken, authorityTokenPolicy)
import Agora.Governor (Governor (Governor))
import Agora.Governor qualified as Governor
import Agora.Governor.Scripts (authorityTokenFromGovernor, authorityTokenSymbolFromGovernor, governorPolicy, governorValidator, proposalFromGovernor, stakeFromGovernor)
import Agora.Proposal (Proposal)
import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
import Agora.Bootstrap qualified as Bootstrap
import Agora.Governor (Governor (..))
import Agora.SafeMoney (GTTag)
import Agora.Stake (Stake)
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
import Agora.Treasury (treasuryValidator)
import Agora.Scripts qualified as Scripts
import Agora.Utils (CompiledMintingPolicy (..), CompiledValidator (..))
import Data.Aeson qualified as Aeson
import Data.Default (def)
import Data.Function ((&))
@ -25,13 +20,16 @@ import Data.Tagged (Tagged)
import Data.Text (Text)
import Development.GitRev (gitBranch, gitHash)
import GHC.Generics qualified as GHC
import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy)
import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol)
import PlutusLedgerApi.V1.Value qualified as Value
import Plutarch (Config (..), TracingMode (DoTracing))
import PlutusLedgerApi.V1 (
MintingPolicy (getMintingPolicy),
TxOutRef,
Validator (getValidator),
)
import PlutusLedgerApi.V1.Value (AssetClass)
import ScriptExport.API (runServer)
import ScriptExport.Options (parseOptions)
import ScriptExport.ScriptInfo (ScriptInfo, mkPolicyInfo, mkValidatorInfo)
import ScriptExport.ScriptInfo (ScriptInfo (..), mkPolicyInfo, mkScriptInfo, mkValidatorInfo)
import ScriptExport.Types (Builders, insertBuilder)
main :: IO ()
@ -81,39 +79,23 @@ builders =
agoraScripts :: ScriptParams -> AgoraScripts
agoraScripts params =
AgoraScripts
{ governorPolicyInfo = mkPolicyInfo (governorPolicy governor)
, governorValidatorInfo = mkValidatorInfo (governorValidator governor)
, stakePolicyInfo = mkPolicyInfo (stakePolicy params.gtClassRef)
, stakeValidatorInfo = mkValidatorInfo (stakeValidator stake)
, proposalPolicyInfo = mkPolicyInfo (proposalPolicy governorSTAssetClass)
, proposalValidatorInfo = mkValidatorInfo (proposalValidator proposal)
, treasuryValidatorInfo = mkValidatorInfo (treasuryValidator authorityTokenSymbol)
, authorityTokenPolicyInfo = mkPolicyInfo (authorityTokenPolicy authorityToken)
{ governorPolicyInfo = mkPolicyInfo' scripts.compiledGovernorPolicy
, governorValidatorInfo = mkValidatorInfo' scripts.compiledGovernorValidator
, stakePolicyInfo = mkPolicyInfo' scripts.compiledStakePolicy
, stakeValidatorInfo = mkValidatorInfo' scripts.compiledStakeValidator
, proposalPolicyInfo = mkPolicyInfo' scripts.compiledProposalPolicy
, proposalValidatorInfo = mkValidatorInfo' scripts.compiledProposalValidator
, treasuryValidatorInfo = mkValidatorInfo' scripts.compiledTreasuryValidator
, authorityTokenPolicyInfo = mkPolicyInfo' scripts.compiledAuthorityTokenPolicy
}
where
governor :: Governor
governor =
Governor
{ Governor.gstOutRef = params.governorInitialSpend
, Governor.gtClassRef = params.gtClassRef
, Governor.maximumCosigners = params.maximumCosigners
}
Agora.Governor.Governor
params.governorInitialSpend
params.gtClassRef
params.maximumCosigners
authorityToken :: AuthorityToken
authorityToken = authorityTokenFromGovernor governor
authorityTokenSymbol :: CurrencySymbol
authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
governorSTAssetClass :: AssetClass
governorSTAssetClass =
Value.assetClass (mintingPolicySymbol $ mkMintingPolicy $ governorPolicy governor) ""
proposal :: Proposal
proposal = proposalFromGovernor governor
stake :: Stake
stake = stakeFromGovernor governor
scripts = Bootstrap.agoraScripts plutarchConfig governor
{- | Params required for creating script export.
@ -157,3 +139,26 @@ data AgoraScripts = AgoraScripts
, -- | @since 0.2.0
GHC.Generic
)
{- | Default plutarch configuration for compiling scripts.
TODO: we should have an option to control this.
@since 0.2.0
-}
plutarchConfig :: Config
plutarchConfig = Config {tracingMode = DoTracing}
{- | Turn a precompiled minting policy to a 'ScriptInfo'.
@since 0.2.0
-}
mkPolicyInfo' :: forall redeemer. CompiledMintingPolicy redeemer -> ScriptInfo
mkPolicyInfo' = mkScriptInfo . getMintingPolicy . getCompiledMintingPolicy
{- | Turn a precompiled validator to a 'ScriptInfo'.
@since 0.2.0
-}
mkValidatorInfo' :: forall redeemer datum. CompiledValidator datum redeemer -> ScriptInfo
mkValidatorInfo' = mkScriptInfo . getValidator . getCompiledValidator

12
agora-specs/Property/Generator.hs
View file

@ -114,8 +114,10 @@ genInput = do
val <- genSingletonValue
return $
input $
credential cred
. withValue val
mconcat
[ credential cred
, withValue val
]
genOutput :: Builder a => Gen a
genOutput = do
@ -123,8 +125,10 @@ genOutput = do
val <- genSingletonValue
return $
output $
credential cred
. withValue val
mconcat
[ credential cred
, withValue val
]
genOutRef :: Gen TxOutRef
genOutRef = do

12
agora-specs/Property/Governor.hs
View file

@ -7,7 +7,7 @@ Property model and tests for 'Governor' related functions
-}
module Property.Governor (props) where
import Agora.Governor (GovernorDatum (..), pisGovernorDatumValid)
import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid)
import Agora.Governor.Scripts (governorPolicy)
import Agora.Proposal (
ProposalId (ProposalId),
@ -157,7 +157,13 @@ governorMintingProperty =
-}
gst = assetClassValue govAssetClass 1
mintAmount x = mint . mconcat $ replicate x gst
outputToGov = output $ script govValidatorHash . withValue gst . withDatum govDatum
outputToGov =
output $
mconcat
[ script govValidatorHash
, withValue gst
, withDatum govDatum
]
referencedInput = input $ withOutRef gstUTXORef
govDatum :: GovernorDatum
@ -195,7 +201,7 @@ governorMintingProperty =
opaqueToUnit = plam $ \_ -> pconstant ()
actual :: Term s (PScriptContext :--> PUnit)
actual = plam $ \sc -> opaqueToUnit #$ governorPolicy governor # pforgetData (pconstantData ()) # sc
actual = plam $ \sc -> opaqueToUnit #$ governorPolicy governor.gstOutRef # pforgetData (pconstantData ()) # sc
classifier :: ScriptContext -> GovernorPolicyCases
classifier sc

17
agora-specs/Sample/Effect/GovernorMutation.hs
View file

@ -17,6 +17,7 @@ import Agora.Effect.GovernorMutation (
)
import Agora.Governor (GovernorDatum (..))
import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
import Agora.Utils (validatorHashToTokenName)
import Data.Default.Class (Default (def))
import Data.Tagged (Tagged (..))
import Plutarch.Api.V1 (mkValidator, validatorHash)
@ -24,7 +25,6 @@ import PlutusLedgerApi.V1 (
Address,
Datum (..),
ToData (..),
TokenName (..),
TxInInfo (..),
TxInfo (..),
TxOut (..),
@ -40,10 +40,11 @@ import PlutusLedgerApi.V1.Value qualified as Value (
singleton,
)
import Sample.Shared (
agoraScripts,
authorityTokenSymbol,
deterministicTracingConfing,
govAssetClass,
govValidatorAddress,
governor,
minAda,
signer,
)
@ -51,7 +52,7 @@ import Test.Util (datumPair, toDatumHash)
-- | The effect validator instance.
effectValidator :: Validator
effectValidator = mkValidator $ mutateGovernorValidator governor
effectValidator = mkValidator deterministicTracingConfing $ mutateGovernorValidator agoraScripts
-- | The hash of the validator instance.
effectValidatorHash :: ValidatorHash
@ -65,17 +66,15 @@ effectValidatorAddress = scriptHashAddress effectValidatorHash
atAssetClass :: AssetClass
atAssetClass = assetClass authorityTokenSymbol tokenName
where
-- TODO: use 'validatorHashToTokenName'
ValidatorHash bs = effectValidatorHash
tokenName = TokenName bs
tokenName = validatorHashToTokenName effectValidatorHash
-- | The mock reference of the governor state UTXO.
govRef :: TxOutRef
govRef = TxOutRef "614481d2159bfb72350222d61fce17e548e0fc00e5a1f841ff1837c431346ce7" 1
govRef = TxOutRef "1475e1ee22330dfc55430980e5a6b100ec9d9249bb4b462256a79559" 1
-- | The mock reference of the effect UTXO.
effectRef :: TxOutRef
effectRef = TxOutRef "c31164dc11835de7eb6187f67d0e1a19c1dfc0786a456923eef5043189cdb578" 1
effectRef = TxOutRef "a302d327d8e5553d50b9d017475369753f723d7e999ac1b68da8ad52" 1
-- | The input effect datum in 'mkEffectTransaction'.
mkEffectDatum :: GovernorDatum -> MutateGovernorDatum
@ -159,7 +158,7 @@ mkEffectTxInfo newGovDatum =
, txInfoValidRange = Interval.always
, txInfoSignatories = [signer]
, txInfoData = datumPair <$> [governorInputDatum, governorOutputDatum, effectInputDatum]
, txInfoId = "4dae3806cc69615b721d52ed09b758f43f25a8f39b7934d6b28514caf71f5f7b"
, txInfoId = "74c75505691e7baa981fa80e50b9b7e88dbe1eda67d4f062d89d203b"
}
validNewGovernorDatum :: GovernorDatum

7
agora-specs/Sample/Effect/TreasuryWithdrawal.hs
View file

@ -23,11 +23,12 @@ import Agora.Effect.TreasuryWithdrawal (
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
treasuryWithdrawalValidator,
)
import Data.Default (def)
import Plutarch.Api.V1 (mkValidator, validatorHash)
import PlutusLedgerApi.V1 (
Address (Address),
Credential (..),
CurrencySymbol (CurrencySymbol),
CurrencySymbol,
DatumHash (DatumHash),
PubKeyHash,
ScriptContext (..),
@ -59,7 +60,7 @@ import Test.Util (scriptCredentials, userCredentials)
-- | A sample Currency Symbol.
currSymbol :: CurrencySymbol
currSymbol = CurrencySymbol "12312099"
currSymbol = "9c04a69c7133e26061fe5a15adaf4f79cd51e47ef22a2e3c91a36f04"
-- | A sample 'PubKeyHash'.
signer :: PubKeyHash
@ -147,7 +148,7 @@ buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
-- | Effect validator instance.
validator :: Validator
validator = mkValidator $ treasuryWithdrawalValidator currSymbol
validator = mkValidator def $ treasuryWithdrawalValidator currSymbol
-- | 'TokenName' that represents the hash of the 'Agora.Stake.Stake' validator.
validatorHashTN :: TokenName

55
agora-specs/Sample/Governor/Initialize.hs
View file

@ -19,16 +19,20 @@ module Sample.Governor.Initialize (
mkTestCase,
) where
import Agora.Bootstrap (agoraScripts)
import Agora.Governor (Governor (..), GovernorDatum (..))
import Agora.Governor.Scripts (
governorPolicy,
governorSTAssetClassFromGovernor,
import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
import Agora.Proposal.Time (
MaxTimeRangeWidth (MaxTimeRangeWidth),
ProposalTimingConfig (ProposalTimingConfig),
)
import Agora.Scripts (
AgoraScripts (compiledGovernorPolicy),
governorSTAssetClass,
governorSTSymbol,
governorValidatorHash,
)
import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
import Agora.Proposal.Time (MaxTimeRangeWidth (MaxTimeRangeWidth), ProposalTimingConfig (ProposalTimingConfig))
import Data.Default (Default (..))
import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy)
import Plutarch.Context (
input,
mint,
@ -43,7 +47,6 @@ import Plutarch.Context (
)
import PlutusLedgerApi.V1 (
CurrencySymbol,
MintingPolicy,
TxOutRef (TxOutRef),
ValidatorHash,
)
@ -107,17 +110,17 @@ governor =
{ gstOutRef = witnessRef
}
scripts :: AgoraScripts
scripts = agoraScripts Shared.deterministicTracingConfing governor
govAssetClass :: AssetClass
govAssetClass = governorSTAssetClassFromGovernor governor
govAssetClass = governorSTAssetClass scripts
govValidatorHash :: ValidatorHash
govValidatorHash = governorValidatorHash governor
govPolicy :: MintingPolicy
govPolicy = mkMintingPolicy (governorPolicy governor)
govValidatorHash = governorValidatorHash scripts
govSymbol :: CurrencySymbol
govSymbol = mintingPolicySymbol govPolicy
govSymbol = governorSTSymbol scripts
--------------------------------------------------------------------------------
@ -169,12 +172,16 @@ mintGST ps = builder
then
mconcat
[ input $
pubKey witnessPubKey
. withValue witnessValue
. withOutRef witnessRef
mconcat
[ pubKey witnessPubKey
, withValue witnessValue
, withOutRef witnessRef
]
, output $
pubKey witnessPubKey
. withValue witnessValue
mconcat
[ pubKey witnessPubKey
, withValue witnessValue
]
]
else mempty
@ -184,11 +191,13 @@ mintGST ps = builder
let datum =
if ps.withGovernorDatum
then withDatum governorOutputDatum
else id
else mempty
in output $
script govValidatorHash
. withValue governorValue
. datum
mconcat
[ script govValidatorHash
, withValue governorValue
, datum
]
--
builder =
mconcat
@ -265,6 +274,6 @@ mkTestCase name ps valid =
testPolicy
valid
name
(governorPolicy governor)
scripts.compiledGovernorPolicy
()
(mkMinting mintGST ps govSymbol)

42
agora-specs/Sample/Governor/Mutate.hs
View file

@ -18,8 +18,8 @@ module Sample.Governor.Mutate (
import Agora.Effect.NoOp (noOpValidator)
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
import Agora.Governor.Scripts (governorValidator)
import Agora.Proposal (ProposalId (ProposalId), ProposalThresholds (..))
import Agora.Scripts (AgoraScripts (..))
import Agora.Utils (validatorHashToTokenName)
import Data.Default (def)
import Plutarch.Api.V1 (PValidator, mkValidator, validatorHash)
@ -42,14 +42,14 @@ import PlutusLedgerApi.V1 (
)
import PlutusLedgerApi.V1.Value qualified as Value
import Sample.Shared (
agoraScripts,
authorityTokenSymbol,
govAssetClass,
govValidatorHash,
governor,
minAda,
)
import Test.Specification (SpecificationTree, testValidator)
import Test.Util (CombinableBuilder, mkSpending, pubKeyHashes, sortValue, validatorHashes, withOptional)
import Test.Util (CombinableBuilder, mkSpending, pubKeyHashes, sortValue, validatorHashes)
--------------------------------------------------------------------------------
@ -142,18 +142,22 @@ mkGovernorBuilder ps =
then pubKey $ head pubKeyHashes
else script govValidatorHash
withGSTDatum =
withOptional withDatum $
maybe mempty withDatum $
mkGovernorOutputDatum ps.governorOutputDatumValidity
in mconcat
[ input $
script govValidatorHash
. withDatum governorInputDatum
. withValue value
. withOutRef governorRef
mconcat
[ script govValidatorHash
, withDatum governorInputDatum
, withValue value
, withOutRef governorRef
]
, output $
gstOutput
. withGSTDatum
. withValue value
mconcat
[ gstOutput
, withGSTDatum
, withValue value
]
]
--------------------------------------------------------------------------------
@ -162,7 +166,7 @@ mockEffectValidator :: ClosedTerm PValidator
mockEffectValidator = noOpValidator authorityTokenSymbol
mockEffectValidatorHash :: ValidatorHash
mockEffectValidatorHash = validatorHash $ mkValidator mockEffectValidator
mockEffectValidatorHash = validatorHash $ mkValidator def mockEffectValidator
mkGATValue :: GATValidity -> Integer -> Value
mkGATValue NoGAT _ = mempty
@ -187,11 +191,15 @@ mkMockEffectBuilder ps =
in mconcat
[ mint burnt
, input $
script mockEffectValidatorHash
. withValue inputValue
mconcat
[ script mockEffectValidatorHash
, withValue inputValue
]
, output $
script mockEffectValidatorHash
. withValue outputValue
mconcat
[ script mockEffectValidatorHash
, withValue outputValue
]
]
--------------------------------------------------------------------------------
@ -211,7 +219,7 @@ mkTestCase name pb (Validity forGov) =
testValidator
forGov
name
(governorValidator governor)
agoraScripts.compiledGovernorValidator
governorInputDatum
governorRedeemer
(mkSpending mutate pb governorRef)

88
agora-specs/Sample/Proposal/Advance.hs
View file

@ -37,15 +37,11 @@ module Sample.Proposal.Advance (
mkBadGovernorOutputDatumBundle,
) where
import Agora.AuthorityToken (
AuthorityToken (AuthorityToken),
authorityTokenPolicy,
)
import Agora.Governor (
Governor (..),
GovernorDatum (..),
GovernorRedeemer (MintGATs),
)
import Agora.Governor.Scripts (governorValidator)
import Agora.Proposal (
ProposalDatum (..),
ProposalId (ProposalId),
@ -56,7 +52,6 @@ import Agora.Proposal (
ResultTag (ResultTag),
emptyVotesFor,
)
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (
@ -66,12 +61,11 @@ import Agora.Proposal.Time (
votingTime
),
)
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (
Stake (gtClassRef),
StakeDatum (..),
StakeRedeemer (WitnessStake),
)
import Agora.Stake.Scripts (stakeValidator)
import Agora.Utils (validatorHashToTokenName)
import Control.Monad.State (execState, modify, when)
import Data.Default (def)
@ -107,18 +101,18 @@ import Sample.Proposal.Shared (
stakeTxRef,
)
import Sample.Shared (
agoraScripts,
authorityTokenSymbol,
govAssetClass,
govValidatorHash,
governor,
minAda,
proposalPolicySymbol,
proposalValidatorHash,
signer,
stake,
stakeAssetClass,
stakeValidatorHash,
)
import Sample.Shared qualified as Shared
import Test.Specification (
SpecificationTree,
group,
@ -321,14 +315,18 @@ mkProposalBuilder ps =
value = sortValue $ minAda <> pst
in mconcat
[ input $
script proposalValidatorHash
. withOutRef proposalRef
. withDatum (mkProposalInputDatum ps)
. withValue value
mconcat
[ script proposalValidatorHash
, withOutRef proposalRef
, withDatum (mkProposalInputDatum ps)
, withValue value
]
, output $
script proposalValidatorHash
. withDatum (mkProposalOutputDatum ps)
. withValue value
mconcat
[ script proposalValidatorHash
, withDatum (mkProposalOutputDatum ps)
, withValue value
]
]
{- | The proposal redeemer used to spend the proposal UTXO, which is always
@ -390,7 +388,7 @@ mkStakeBuilder ps =
minAda
<> Value.assetClassValue stakeAssetClass 1
<> Value.assetClassValue
(untag stake.gtClassRef)
(untag governor.gtClassRef)
ps.perStakeGTs
perStake idx i o =
let withSig =
@ -400,14 +398,18 @@ mkStakeBuilder ps =
in mconcat
[ withSig
, input $
script stakeValidatorHash
. withOutRef (mkStakeRef idx)
. withValue perStakeValue
. withDatum i
mconcat
[ script stakeValidatorHash
, withOutRef (mkStakeRef idx)
, withValue perStakeValue
, withDatum i
]
, output $
script stakeValidatorHash
. withValue perStakeValue
. withDatum o
mconcat
[ script stakeValidatorHash
, withValue perStakeValue
, withDatum o
]
]
in mconcat $
zipWith3
@ -457,15 +459,19 @@ mkGovernorBuilder ps =
value = sortValue $ gst <> minAda
in mconcat
[ input $
script govValidatorHash
. withValue value
. withOutRef governorRef
. withDatum governorInputDatum
mconcat
[ script govValidatorHash
, withValue value
, withOutRef governorRef
, withDatum governorInputDatum
]
, output $
script govValidatorHash
. withValue value
. withOutRef governorRef
. withDatum (mkGovernorOutputDatum ps)
mconcat
[ script govValidatorHash
, withValue value
, withOutRef governorRef
, withDatum (mkGovernorOutputDatum ps)
]
]
{- | The proposal redeemer used to spend the governor UTXO, which is always
@ -501,9 +507,11 @@ mkAuthorityTokenBuilder (AuthorityTokenParameters es mdt invalidTokenName) =
in mconcat
[ mint minted
, output $
script vh
. maybe id withDatum mdt
. withValue value
mconcat
[ script vh
, maybe mempty withDatum mdt
, withValue value
]
]
-- | The redeemer used while running the authority token policy.
@ -551,7 +559,7 @@ mkTestTree name pb val =
testValidator
val.forProposalValidator
"proposal"
(proposalValidator Shared.proposal)
agoraScripts.compiledProposalValidator
proposalInputDatum
proposalRedeemer
(spend proposalRef)
@ -562,7 +570,7 @@ mkTestTree name pb val =
testValidator
val.forStakeValidator
"stake"
(stakeValidator Shared.stake)
agoraScripts.compiledStakeValidator
(getStakeInputDatumAt pb.stakeParameters idx)
stakeRedeemer
( spend (mkStakeRef idx)
@ -572,7 +580,7 @@ mkTestTree name pb val =
testValidator
(fromJust val.forGovernorValidator)
"governor"
(governorValidator Shared.governor)
agoraScripts.compiledGovernorValidator
governorInputDatum
governorRedeemer
(spend governorRef)
@ -582,7 +590,7 @@ mkTestTree name pb val =
testPolicy
(fromJust val.forAuthorityTokenPolicy)
"authority"
(authorityTokenPolicy $ AuthorityToken Shared.govAssetClass)
agoraScripts.compiledAuthorityTokenPolicy
authorityTokenRedeemer
(mint authorityTokenSymbol)
<$ (pb.authorityTokenParameters)

55
agora-specs/Sample/Proposal/Cosign.hs
View file

@ -14,6 +14,7 @@ module Sample.Proposal.Cosign (
mkTestTree,
) where
import Agora.Governor (Governor (..))
import Agora.Proposal (
ProposalDatum (..),
ProposalId (ProposalId),
@ -22,19 +23,17 @@ import Agora.Proposal (
ResultTag (ResultTag),
emptyVotesFor,
)
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (draftTime),
)
import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (
Stake (gtClassRef),
StakeDatum (StakeDatum, owner),
StakeRedeemer (WitnessStake),
stakedAmount,
)
import Agora.Stake.Scripts (stakeValidator)
import Data.Coerce (coerce)
import Data.Default (def)
import Data.List (sort)
@ -61,15 +60,15 @@ import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
import Sample.Shared (
agoraScripts,
governor,
minAda,
proposalPolicySymbol,
proposalValidatorHash,
signer,
stake,
stakeAssetClass,
stakeValidatorHash,
)
import Sample.Shared qualified as Shared
import Test.Specification (
SpecificationTree,
group,
@ -149,7 +148,7 @@ cosign ps = builder
sortValue $
minAda
<> Value.assetClassValue
(untag stake.gtClassRef)
(untag governor.gtClassRef)
(untag perStakedGTs)
<> sst
@ -162,15 +161,19 @@ cosign ps = builder
else stakeDatum
in mconcat
[ input $
script stakeValidatorHash
. withValue stakeValue
. withDatum stakeDatum
. withTxId stakeTxRef
. withOutRef (mkStakeRef refIdx)
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum stakeDatum
, withTxId stakeTxRef
, withOutRef (mkStakeRef refIdx)
]
, output $
script stakeValidatorHash
. withValue stakeValue
. withDatum stakeOutputDatum
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum stakeOutputDatum
]
, signedWith stakeDatum.owner
]
)
@ -189,15 +192,19 @@ cosign ps = builder
proposalBuilder =
mconcat
[ input $
script proposalValidatorHash
. withValue pst
. withDatum proposalInputDatum
. withTxId proposalTxRef
. withOutRef proposalRef
mconcat
[ script proposalValidatorHash
, withValue pst
, withDatum proposalInputDatum
, withTxId proposalTxRef
, withOutRef proposalRef
]
, output $
script proposalValidatorHash
. withValue (sortValue (pst <> minAda))
. withDatum proposalOutputDatum
mconcat
[ script proposalValidatorHash
, withValue (sortValue (pst <> minAda))
, withDatum proposalOutputDatum
]
]
validTimeRange :: POSIXTimeRange
@ -314,7 +321,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
in testValidator
isValid
"proposal"
(proposalValidator Shared.proposal)
agoraScripts.compiledProposalValidator
proposalInputDatum
(mkProposalRedeemer ps)
(spend proposalRef)
@ -326,7 +333,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
in testValidator
isValid
"stake"
(stakeValidator Shared.stake)
agoraScripts.compiledStakeValidator
stakeInputDatum
stakeRedeemer
(spend $ mkStakeRef idx)

68
agora-specs/Sample/Proposal/Create.hs
View file

@ -20,27 +20,24 @@ module Sample.Proposal.Create (
) where
import Agora.Governor (
Governor (..),
GovernorDatum (..),
GovernorRedeemer (CreateProposal),
)
import Agora.Governor.Scripts (governorValidator)
import Agora.Proposal (
Proposal (governorSTAssetClass),
ProposalDatum (..),
ProposalId (ProposalId),
ProposalStatus (..),
ResultTag (ResultTag),
emptyVotesFor,
)
import Agora.Proposal.Scripts (proposalPolicy)
import Agora.Proposal.Time (MaxTimeRangeWidth (MaxTimeRangeWidth), ProposalStartingTime (..))
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (
ProposalLock (..),
Stake (gtClassRef),
StakeDatum (..),
StakeRedeemer (PermitVote),
)
import Agora.Stake.Scripts (stakeValidator)
import Data.Coerce (coerce)
import Data.Default (Default (def))
import Data.Tagged (Tagged, untag)
@ -69,19 +66,19 @@ import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (stakeTxRef)
import Sample.Shared (
agoraScripts,
govAssetClass,
govValidatorHash,
governor,
minAda,
proposal,
proposalPolicySymbol,
proposalStartingTimeFromTimeRange,
proposalValidatorHash,
signer,
signer2,
stake,
stakeAssetClass,
stakeValidatorHash,
)
import Sample.Shared qualified as Shared
import Test.Specification (SpecificationTree, group, testPolicy, testValidator)
import Test.Util (CombinableBuilder, closedBoundedInterval, mkMinting, mkSpending, sortValue)
@ -270,7 +267,7 @@ createProposal ps = builder
where
pst = Value.singleton proposalPolicySymbol "" 1
sst = Value.assetClassValue stakeAssetClass 1
gst = Value.assetClassValue proposal.governorSTAssetClass 1
gst = Value.assetClassValue govAssetClass 1
---
@ -279,7 +276,7 @@ createProposal ps = builder
sortValue $
sortValue $
sst
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakedGTs)
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakedGTs)
<> minAda
proposalValue = sortValue $ pst <> minAda
@ -302,29 +299,39 @@ createProposal ps = builder
, ---
timeRange $ mkTimeRange ps
, input $
script govValidatorHash
. withValue governorValue
. withDatum governorInputDatum
. withOutRef governorRef
mconcat
[ script govValidatorHash
, withValue governorValue
, withDatum governorInputDatum
, withOutRef governorRef
]
, output $
script govValidatorHash
. withValue governorValue
. withDatum (mkGovernorOutputDatum ps)
mconcat
[ script govValidatorHash
, withValue governorValue
, withDatum (mkGovernorOutputDatum ps)
]
, ---
input $
script stakeValidatorHash
. withValue stakeValue
. withDatum (mkStakeInputDatum ps)
. withOutRef stakeRef
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum (mkStakeInputDatum ps)
, withOutRef stakeRef
]
, output $
script stakeValidatorHash
. withValue stakeValue
. withDatum (mkStakeOutputDatum ps)
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum (mkStakeOutputDatum ps)
]
, ---
output $
script proposalValidatorHash
. withValue proposalValue
. withDatum (mkProposalOutputDatum ps)
mconcat
[ script proposalValidatorHash
, withValue proposalValue
, withDatum (mkProposalOutputDatum ps)
]
]
--------------------------------------------------------------------------------
@ -428,7 +435,7 @@ mkTestTree
testPolicy
validForProposalPolicy
"proposal"
(proposalPolicy Shared.proposal.governorSTAssetClass)
agoraScripts.compiledProposalPolicy
proposalPolicyRedeemer
(mint proposalPolicySymbol)
@ -436,15 +443,16 @@ mkTestTree
testValidator
validForGovernorValidator
"governor"
(governorValidator Shared.governor)
agoraScripts.compiledGovernorValidator
governorInputDatum
governorRedeemer
(spend governorRef)
stakeTest =
testValidator
validForStakeValidator
"stake"
(stakeValidator Shared.stake)
agoraScripts.compiledStakeValidator
(mkStakeInputDatum ps)
stakeRedeemer
(spend stakeRef)

52
agora-specs/Sample/Proposal/UnlockStake.hs
View file

@ -25,6 +25,7 @@ module Sample.Proposal.UnlockStake (
--------------------------------------------------------------------------------
import Agora.Governor (Governor (..))
import Agora.Proposal (
ProposalDatum (..),
ProposalId (..),
@ -33,10 +34,9 @@ import Agora.Proposal (
ProposalVotes (..),
ResultTag (..),
)
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
import Agora.Stake (ProposalLock (..), Stake (..), StakeDatum (..), StakeRedeemer (RetractVotes))
import Agora.Stake.Scripts (stakeValidator)
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (ProposalLock (..), StakeDatum (..), StakeRedeemer (RetractVotes))
import Data.Default.Class (Default (def))
import Data.Tagged (Tagged (..), untag)
import Plutarch.Context (
@ -59,15 +59,15 @@ import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (stakeTxRef)
import Sample.Shared (
agoraScripts,
governor,
minAda,
proposalPolicySymbol,
proposalValidatorHash,
signer,
stake,
stakeAssetClass,
stakeValidatorHash,
)
import Sample.Shared qualified as Shared
import Test.Specification (SpecificationTree, group, testValidator)
import Test.Util (CombinableBuilder, mkSpending, sortValue, updateMap)
@ -257,14 +257,18 @@ unlockStake ps =
( \((i, o), idx) ->
mconcat
[ input $
script proposalValidatorHash
. withValue pst
. withDatum i
. withOutRef (mkProposalRef idx)
mconcat
[ script proposalValidatorHash
, withValue pst
, withDatum i
, withOutRef (mkProposalRef idx)
]
, output $
script proposalValidatorHash
. withValue (sortValue $ pst <> minAda)
. withDatum o
mconcat
[ script proposalValidatorHash
, withValue (sortValue $ pst <> minAda)
, withDatum o
]
]
)
(zip pIODatums [0 ..])
@ -273,7 +277,7 @@ unlockStake ps =
sortValue $
mconcat
[ Value.assetClassValue
(untag stake.gtClassRef)
(untag governor.gtClassRef)
(untag defStakedGTs)
, sst
, minAda
@ -285,14 +289,18 @@ unlockStake ps =
stakes =
mconcat
[ input $
script stakeValidatorHash
. withValue stakeValue
. withDatum sInDatum
. withOutRef stakeRef
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum sInDatum
, withOutRef stakeRef
]
, output $
script stakeValidatorHash
. withValue stakeValue
. withDatum sOutDatum
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum sOutDatum
]
]
builder =
@ -524,7 +532,7 @@ mkTestTree name ps isValid = group name [stake, proposal]
testValidator
(not ps.alterOutputStake)
"stake"
(stakeValidator Shared.stake)
agoraScripts.compiledStakeValidator
(mkStakeInputDatum ps)
stakeRedeemer
(spend stakeRef)
@ -536,7 +544,7 @@ mkTestTree name ps isValid = group name [stake, proposal]
in testValidator
isValid
"proposal"
(proposalValidator Shared.proposal)
agoraScripts.compiledProposalValidator
(mkProposalInputDatum ps pid)
proposalRedeemer
(spend ref)

51
agora-specs/Sample/Proposal/Vote.hs
View file

@ -11,6 +11,7 @@ module Sample.Proposal.Vote (
validVoteAsDelegateParameters,
) where
import Agora.Governor (Governor (..))
import Agora.Proposal (
ProposalDatum (..),
ProposalId (ProposalId),
@ -19,18 +20,16 @@ import Agora.Proposal (
ProposalVotes (ProposalVotes),
ResultTag (ResultTag),
)
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (draftTime, votingTime),
)
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (
ProposalLock (..),
Stake (gtClassRef),
StakeDatum (..),
StakeRedeemer (PermitVote),
)
import Agora.Stake.Scripts (stakeValidator)
import Data.Default (Default (def))
import Data.Tagged (Tagged (Tagged), untag)
import Plutarch.Context (
@ -52,15 +51,15 @@ import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
import Sample.Shared (
agoraScripts,
governor,
minAda,
proposalPolicySymbol,
proposalValidatorHash,
signer,
stake,
stakeAssetClass,
stakeValidatorHash,
)
import Sample.Shared qualified as Shared
import Test.Specification (
SpecificationTree,
group,
@ -205,7 +204,7 @@ vote params =
stakeValue =
sortValue $
sst
<> Value.assetClassValue (untag stake.gtClassRef) params.voteCount
<> Value.assetClassValue (untag governor.gtClassRef) params.voteCount
<> minAda
signer =
@ -219,23 +218,31 @@ vote params =
, signedWith signer
, timeRange validTimeRange
, input $
script proposalValidatorHash
. withValue pst
. withDatum proposalInputDatum
. withOutRef proposalRef
mconcat
[ script proposalValidatorHash
, withValue pst
, withDatum proposalInputDatum
, withOutRef proposalRef
]
, input $
script stakeValidatorHash
. withValue stakeValue
. withDatum stakeInputDatum
. withOutRef stakeRef
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum stakeInputDatum
, withOutRef stakeRef
]
, output $
script proposalValidatorHash
. withValue pst
. withDatum proposalOutputDatum
mconcat
[ script proposalValidatorHash
, withValue pst
, withDatum proposalOutputDatum
]
, output $
script stakeValidatorHash
. withValue stakeValue
. withDatum stakeOutputDatum
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum stakeOutputDatum
]
]
in builder
@ -270,7 +277,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
testValidator
isValid
"proposal"
(proposalValidator Shared.proposal)
agoraScripts.compiledProposalValidator
proposalInputDatum
(mkProposalRedeemer ps)
(spend proposalRef)
@ -279,7 +286,7 @@ mkTestTree name ps isValid = group name [proposal, stake]
let stakeInputDatum = mkStakeInputDatum ps
in validatorSucceedsWith
"stake"
(stakeValidator Shared.stake)
agoraScripts.compiledStakeValidator
stakeInputDatum
stakeRedeemer
(spend stakeRef)

107
agora-specs/Sample/Shared.hs
View file

@ -12,11 +12,15 @@ module Sample.Shared (
signer,
signer2,
minAda,
deterministicTracingConfing,
mkEffect,
-- * Agora Scripts
agoraScripts,
-- * Components
-- ** Stake
stake,
stakeAssetClass,
stakeValidatorHash,
stakeAddress,
@ -33,14 +37,12 @@ module Sample.Shared (
gstUTXORef,
-- ** Proposal
proposal,
proposalPolicySymbol,
proposalValidatorHash,
proposalValidatorAddress,
proposalStartingTimeFromTimeRange,
-- ** Authority
authorityToken,
authorityTokenSymbol,
-- ** Treasury
@ -53,38 +55,29 @@ module Sample.Shared (
wrongEffHash,
) where
import Agora.AuthorityToken (AuthorityToken)
import Agora.Bootstrap qualified as Bootstrap
import Agora.Effect.NoOp (noOpValidator)
import Agora.Governor (Governor (Governor))
import Agora.Governor.Scripts (
authorityTokenFromGovernor,
authorityTokenSymbolFromGovernor,
governorPolicy,
governorSTAssetClassFromGovernor,
governorValidator,
governorValidatorHash,
proposalFromGovernor,
proposalSTSymbolFromGovernor,
proposalValidatorHashFromGovernor,
stakeFromGovernor,
stakeSTAssetClassFromGovernor,
stakeSTSymbolFromGovernor,
stakeValidatorHashFromGovernor,
)
import Agora.Proposal (Proposal (..), ProposalThresholds (..))
import Agora.Proposal (ProposalThresholds (..))
import Agora.Proposal.Time (
MaxTimeRangeWidth (..),
ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (..),
)
import Agora.Stake (Stake (..))
import Agora.Scripts qualified as Scripts
import Agora.Treasury (treasuryValidator)
import Agora.Utils (validatorHashToTokenName)
import Agora.Utils (
CompiledEffect (CompiledEffect),
CompiledMintingPolicy (getCompiledMintingPolicy),
CompiledValidator (getCompiledValidator),
validatorHashToTokenName,
)
import Data.Default.Class (Default (..))
import Data.Tagged (Tagged (..))
import Plutarch (Config (..), TracingMode (DetTracing))
import Plutarch.Api.V1 (
PValidator,
mintingPolicySymbol,
mkMintingPolicy,
mkValidator,
validatorHash,
)
@ -110,24 +103,13 @@ import PlutusLedgerApi.V1.Value qualified as Value (
assetClass,
singleton,
)
import PlutusTx qualified
stake :: Stake
stake = stakeFromGovernor governor
stakeSymbol :: CurrencySymbol
stakeSymbol = stakeSTSymbolFromGovernor governor
stakeAssetClass :: AssetClass
stakeAssetClass = stakeSTAssetClassFromGovernor governor
stakeValidatorHash :: ValidatorHash
stakeValidatorHash = stakeValidatorHashFromGovernor governor
stakeAddress :: Address
stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
gstUTXORef :: TxOutRef
gstUTXORef = TxOutRef "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d" 0
-- Plutarch compiler configauration.
-- TODO: add the ability to change this value. Maybe wrap everything in a
-- Reader monad?
deterministicTracingConfing :: Config
deterministicTracingConfing = Config DetTracing
governor :: Governor
governor = Governor oref gt mc
@ -140,29 +122,44 @@ governor = Governor oref gt mc
"LQ"
mc = 20
agoraScripts :: Scripts.AgoraScripts
agoraScripts = Bootstrap.agoraScripts deterministicTracingConfing governor
stakeSymbol :: CurrencySymbol
stakeSymbol = Scripts.stakeSTSymbol agoraScripts
stakeAssetClass :: AssetClass
stakeAssetClass = Scripts.stakeSTAssetClass agoraScripts
stakeValidatorHash :: ValidatorHash
stakeValidatorHash = Scripts.stakeValidatorHash agoraScripts
stakeAddress :: Address
stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
gstUTXORef :: TxOutRef
gstUTXORef = TxOutRef "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d" 0
govPolicy :: MintingPolicy
govPolicy = mkMintingPolicy (governorPolicy governor)
govPolicy = getCompiledMintingPolicy $ agoraScripts.compiledGovernorPolicy
govValidator :: Validator
govValidator = mkValidator (governorValidator governor)
govValidator = getCompiledValidator $ agoraScripts.compiledGovernorValidator
govSymbol :: CurrencySymbol
govSymbol = mintingPolicySymbol govPolicy
govAssetClass :: AssetClass
govAssetClass = governorSTAssetClassFromGovernor governor
govAssetClass = Scripts.governorSTAssetClass agoraScripts
govValidatorHash :: ValidatorHash
govValidatorHash = governorValidatorHash governor
govValidatorHash = Scripts.governorValidatorHash agoraScripts
govValidatorAddress :: Address
govValidatorAddress = scriptHashAddress govValidatorHash
proposal :: Proposal
proposal = proposalFromGovernor governor
proposalPolicySymbol :: CurrencySymbol
proposalPolicySymbol = proposalSTSymbolFromGovernor governor
proposalPolicySymbol = Scripts.proposalSTSymbol agoraScripts
-- | A sample 'PubKeyHash'.
signer :: PubKeyHash
@ -173,7 +170,7 @@ signer2 :: PubKeyHash
signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
proposalValidatorHash :: ValidatorHash
proposalValidatorHash = proposalValidatorHashFromGovernor governor
proposalValidatorHash = Scripts.proposalValidatoHash agoraScripts
proposalValidatorAddress :: Address
proposalValidatorAddress = scriptHashAddress proposalValidatorHash
@ -189,11 +186,8 @@ instance Default ProposalThresholds where
, vote = Tagged 100
}
authorityToken :: AuthorityToken
authorityToken = authorityTokenFromGovernor governor
authorityTokenSymbol :: CurrencySymbol
authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
authorityTokenSymbol = Scripts.authorityTokenSymbol agoraScripts
{- | Default value of 'Agora.Governor.GovernorDatum.proposalTimings'.
For testing purpose only.
@ -222,6 +216,9 @@ proposalStartingTimeFromTimeRange
ProposalStartingTime $ (l + u) `div` 2
proposalStartingTimeFromTimeRange _ = error "Given time range should be finite and closed"
mkEffect :: (PlutusTx.ToData datum) => ClosedTerm PValidator -> CompiledEffect datum
mkEffect v = CompiledEffect $ mkValidator deterministicTracingConfing v
------------------------------------------------------------------
treasuryOut :: TxOut
@ -239,7 +236,7 @@ gatCs :: CurrencySymbol
gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
trValidator :: Validator
trValidator = mkValidator (treasuryValidator gatCs)
trValidator = mkValidator def (treasuryValidator gatCs)
-- | `ScriptCredential` used for the dummy treasury validator.
trCredential :: Credential
@ -251,7 +248,7 @@ gatTn = validatorHashToTokenName $ validatorHash mockTrEffect
-- | Mock treasury effect script, used for testing.
mockTrEffect :: Validator
mockTrEffect = mkValidator $ noOpValidator gatCs
mockTrEffect = mkValidator def $ noOpValidator gatCs
-- | Mock treasury effect validator hash
mockTrEffectHash :: ValidatorHash

49
agora-specs/Sample/Stake.hs
View file

@ -6,10 +6,8 @@ Description: Sample based testing for Stake utxos
This module tests primarily the happy path for Stake creation
-}
module Sample.Stake (
stake,
stakeAssetClass,
stakeSymbol,
validatorHashTN,
signer,
-- * Script contexts
@ -20,14 +18,12 @@ module Sample.Stake (
DepositWithdrawExample (..),
) where
import Agora.Governor (Governor (gtClassRef))
import Agora.SafeMoney (GTTag)
import Agora.Stake (
Stake (gtClassRef),
StakeDatum (StakeDatum, stakedAmount),
)
import Agora.Stake.Scripts (stakeValidator)
import Data.Tagged (Tagged, untag)
import Plutarch.Api.V1 (mkValidator, validatorHash)
import Plutarch.Context (
MintingBuilder,
SpendingBuilder,
@ -50,9 +46,7 @@ import PlutusLedgerApi.V1 (
ScriptContext (..),
ScriptPurpose (Minting),
ToData (toBuiltinData),
TokenName (TokenName),
TxInfo (txInfoData, txInfoSignatories),
ValidatorHash (ValidatorHash),
)
import PlutusLedgerApi.V1.Contexts (TxOutRef (..))
import PlutusLedgerApi.V1.Value qualified as Value (
@ -60,16 +54,13 @@ import PlutusLedgerApi.V1.Value qualified as Value (
singleton,
)
import Sample.Shared (
governor,
signer,
stake,
stakeAssetClass,
stakeSymbol,
stakeValidatorHash,
)
-- | 'TokenName' that represents the hash of the 'Stake' validator.
validatorHashTN :: TokenName
validatorHashTN = let ValidatorHash vh = validatorHash (mkValidator $ stakeValidator stake) in TokenName vh
import Test.Util (sortValue)
-- | This script context should be a valid transaction.
stakeCreation :: ScriptContext
@ -85,9 +76,11 @@ stakeCreation =
, signedWith signer
, mint st
, output $
script stakeValidatorHash
. withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242)
. withDatum datum
mconcat
[ script stakeValidatorHash
, withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242)
, withDatum datum
]
, withMinting stakeSymbol
]
in buildMintingUnsafe builder
@ -143,14 +136,26 @@ stakeDepositWithdraw config =
, signedWith signer
, mint st
, input $
script stakeValidatorHash
. withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount))
. withDatum stakeAfter
. withOutRef stakeRef
mconcat
[ script stakeValidatorHash
, withValue
( sortValue $
st
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakeBefore.stakedAmount)
)
, withDatum stakeAfter
, withOutRef stakeRef
]
, output $
script stakeValidatorHash
. withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount))
. withDatum stakeAfter
mconcat
[ script stakeValidatorHash
, withValue
( sortValue $
st
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakeAfter.stakedAmount)
)
, withDatum stakeAfter
]
, withSpendingOutRef stakeRef
]
in buildSpendingUnsafe builder

29
agora-specs/Sample/Stake/SetDelegate.hs
View file

@ -19,12 +19,12 @@ module Sample.Stake.SetDelegate (
delegateToOwnerParameters,
) where
import Agora.Governor (Governor (gtClassRef))
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (
Stake (gtClassRef),
StakeDatum (..),
StakeRedeemer (ClearDelegate, DelegateTo),
)
import Agora.Stake.Scripts (stakeValidator)
import Data.Tagged (untag)
import Plutarch.Context (
SpendingBuilder,
@ -46,10 +46,11 @@ import PlutusLedgerApi.V1 (
)
import PlutusLedgerApi.V1.Value qualified as Value
import Sample.Shared (
agoraScripts,
governor,
minAda,
signer,
signer2,
stake,
stakeAssetClass,
stakeValidatorHash,
)
@ -118,7 +119,7 @@ setDelegate ps = buildSpendingUnsafe builder
mconcat
[ st
, Value.assetClassValue
(untag stake.gtClassRef)
(untag governor.gtClassRef)
(untag stakeInput.stakedAmount)
, minAda
]
@ -129,14 +130,18 @@ setDelegate ps = buildSpendingUnsafe builder
[ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
, signedWith signer
, input $
script stakeValidatorHash
. withValue stakeValue
. withDatum stakeInput
. withOutRef stakeRef
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum stakeInput
, withOutRef stakeRef
]
, output $
script stakeValidatorHash
. withValue stakeValue
. withDatum stakeOutput
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum stakeOutput
]
, withSpendingOutRef stakeRef
]
@ -150,7 +155,7 @@ mkTestCase name ps valid =
testValidator
valid
name
(stakeValidator stake)
agoraScripts.compiledStakeValidator
(mkStakeInputDatum ps)
(mkStakeRedeemer ps)
(setDelegate ps)

28
agora-specs/Sample/Treasury.hs
View file

@ -19,7 +19,6 @@ module Sample.Treasury (
import Plutarch.Context (
MintingBuilder,
UTXO,
buildMintingUnsafe,
credential,
input,
@ -57,11 +56,12 @@ import Sample.Shared (
baseCtxBuilder :: MintingBuilder
baseCtxBuilder =
let treasury :: UTXO -> UTXO
treasury =
credential trCredential
. withValue minAda
. withTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
let treasury =
mconcat
[ credential trCredential
, withValue minAda
, withTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
]
in mconcat
[ txId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
, signedWith signer
@ -81,9 +81,11 @@ validCtx =
mconcat
[ baseCtxBuilder
, input $
script mockTrEffectHash
. withValue (Value.singleton gatCs gatTn 1 <> minAda)
. withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
mconcat
[ script mockTrEffectHash
, withValue (Value.singleton gatCs gatTn 1 <> minAda)
, withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
]
]
in buildMintingUnsafe builder
@ -122,8 +124,10 @@ trCtxGATNameNotAddress =
mconcat
[ baseCtxBuilder
, input $
script wrongEffHash
. withValue (Value.singleton gatCs gatTn 1 <> minAda)
. withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
mconcat
[ script wrongEffHash
, withValue (Value.singleton gatCs gatTn 1 <> minAda)
, withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
]
]
in buildMintingUnsafe builder

5
agora-specs/Spec/AuthorityToken.hs
View file

@ -10,7 +10,8 @@ Tests for Authority token functions
module Spec.AuthorityToken (specs) where
import Agora.AuthorityToken (singleAuthorityTokenBurned)
import Plutarch (ClosedTerm, POpaque, compile, perror, popaque)
import Plutarch (ClosedTerm, POpaque, perror, popaque)
import Plutarch.Extra.Compile (mustCompile)
import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V1 (
Address (Address),
@ -60,7 +61,7 @@ singleAuthorityTokenBurnedTest mint outs =
actual
(popaque (pconstant ()))
perror
in compile s
in mustCompile s
-- | The SpecificationTree exported by this module.
specs :: [SpecificationTree]

12
agora-specs/Spec/Effect/GovernorMutation.hs
View file

@ -2,8 +2,8 @@ module Spec.Effect.GovernorMutation (specs) where
import Agora.Effect.GovernorMutation (mutateGovernorValidator)
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
import Agora.Governor.Scripts (governorValidator)
import Agora.Proposal (ProposalId (..))
import Agora.Scripts (AgoraScripts (..))
import Data.Default.Class (Default (def))
import PlutusLedgerApi.V1 (ScriptContext (ScriptContext), ScriptPurpose (Spending))
import Sample.Effect.GovernorMutation (
@ -14,7 +14,7 @@ import Sample.Effect.GovernorMutation (
mkEffectTxInfo,
validNewGovernorDatum,
)
import Sample.Shared qualified as Shared
import Sample.Shared (agoraScripts, mkEffect)
import Test.Specification (
SpecificationTree,
effectFailsWith,
@ -32,7 +32,7 @@ specs =
"valid new governor datum"
[ validatorSucceedsWith
"governor validator should pass"
(governorValidator Shared.governor)
agoraScripts.compiledGovernorValidator
( GovernorDatum
def
(ProposalId 0)
@ -47,7 +47,7 @@ specs =
)
, effectSucceedsWith
"effect validator should pass"
(mutateGovernorValidator Shared.governor)
(mkEffect $ mutateGovernorValidator agoraScripts)
(mkEffectDatum validNewGovernorDatum)
(ScriptContext (mkEffectTxInfo validNewGovernorDatum) (Spending effectRef))
]
@ -55,7 +55,7 @@ specs =
"invalid new governor datum"
[ validatorFailsWith
"governor validator should fail"
(governorValidator Shared.governor)
agoraScripts.compiledGovernorValidator
( GovernorDatum
def
(ProposalId 0)
@ -70,7 +70,7 @@ specs =
)
, effectFailsWith
"effect validator should fail"
(mutateGovernorValidator Shared.governor)
(mkEffect $ mutateGovernorValidator agoraScripts)
(mkEffectDatum validNewGovernorDatum)
(ScriptContext (mkEffectTxInfo invalidNewGovernorDatum) (Spending effectRef))
]

30
agora-specs/Spec/Effect/TreasuryWithdrawal.hs
View file

@ -25,12 +25,14 @@ import Sample.Effect.TreasuryWithdrawal (
treasuries,
users,
)
import Sample.Shared (mkEffect)
import Test.Specification (
SpecificationTree,
effectFailsWith,
effectSucceedsWith,
group,
)
import Test.Util (sortValue)
specs :: [SpecificationTree]
specs =
@ -38,7 +40,7 @@ specs =
"effect"
[ effectSucceedsWith
"Simple"
(treasuryWithdrawalValidator currSymbol)
(mkEffect $ treasuryWithdrawalValidator currSymbol)
datum1
( buildScriptContext
[ inputGAT
@ -50,7 +52,7 @@ specs =
)
, effectSucceedsWith
"Simple with multiple treasuries "
(treasuryWithdrawalValidator currSymbol)
(mkEffect $ treasuryWithdrawalValidator currSymbol)
datum1
( buildScriptContext
[ inputGAT
@ -67,7 +69,7 @@ specs =
)
, effectSucceedsWith
"Mixed Assets"
(treasuryWithdrawalValidator currSymbol)
(mkEffect $ treasuryWithdrawalValidator currSymbol)
datum2
( buildScriptContext
[ inputGAT
@ -82,7 +84,7 @@ specs =
)
, effectFailsWith
"Pay to uknown 3rd party"
(treasuryWithdrawalValidator currSymbol)
(mkEffect $ treasuryWithdrawalValidator currSymbol)
datum2
( buildScriptContext
[ inputGAT
@ -98,7 +100,7 @@ specs =
)
, effectFailsWith
"Missing receiver"
(treasuryWithdrawalValidator currSymbol)
(mkEffect $ treasuryWithdrawalValidator currSymbol)
datum2
( buildScriptContext
[ inputGAT
@ -113,7 +115,7 @@ specs =
)
, effectFailsWith
"Unauthorized treasury"
(treasuryWithdrawalValidator currSymbol)
(mkEffect $ treasuryWithdrawalValidator currSymbol)
datum3
( buildScriptContext
[ inputGAT
@ -125,7 +127,7 @@ specs =
)
, effectFailsWith
"Prevent transactions besides the withdrawal"
(treasuryWithdrawalValidator currSymbol)
(mkEffect $ treasuryWithdrawalValidator currSymbol)
datum3
( buildScriptContext
[ inputGAT
@ -141,8 +143,14 @@ specs =
]
]
where
asset1 = Value.singleton "abbc12" "OrangeBottle"
asset2 = Value.singleton "abbc12" "19721121"
asset1 =
Value.singleton
"0d586e057e76238f8c56c0752507bfa45ae13b04f8497a311d4aaa48"
"OrangeBottle"
asset2 =
Value.singleton
"7e6aa764bceeba1f7acf47d20f1a2a85440afa2928f8ae96376f4d85"
"19721121"
datum1 =
TreasuryWithdrawalDatum
[ (head users, asset1 1)
@ -155,8 +163,8 @@ specs =
]
datum2 =
TreasuryWithdrawalDatum
[ (head users, asset2 5 <> asset1 4)
, (users !! 1, asset2 1 <> asset1 2)
[ (head users, sortValue $ asset2 5 <> asset1 4)
, (users !! 1, sortValue $ asset2 1 <> asset1 2)
, (users !! 2, asset1 1)
]
[ head treasuries

30
agora-specs/Spec/Stake.hs
View file

@ -9,14 +9,14 @@ Tests for Stake policy and validator
-}
module Spec.Stake (specs) where
import Agora.Scripts (AgoraScripts (..))
import Agora.Stake (
Stake (..),
StakeDatum (StakeDatum),
StakeRedeemer (DepositWithdraw),
)
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
import Data.Bool (Bool (..))
import Data.Maybe (Maybe (..))
import Sample.Shared (agoraScripts)
import Sample.Stake (
DepositWithdrawExample (
DepositWithdrawExample,
@ -26,7 +26,6 @@ import Sample.Stake (
signer,
)
import Sample.Stake qualified as Stake (
stake,
stakeCreation,
stakeCreationUnsigned,
stakeCreationWrongDatum,
@ -41,7 +40,6 @@ import Test.Specification (
validatorFailsWith,
validatorSucceedsWith,
)
import Test.Util (toDatum)
import Prelude (Num (negate), ($))
-- | The SpecificationTree exported by this module.
@ -51,17 +49,17 @@ specs =
"policy"
[ policySucceedsWith
"stakeCreation"
(stakePolicy Stake.stake.gtClassRef)
agoraScripts.compiledStakePolicy
()
Stake.stakeCreation
, policyFailsWith
"stakeCreationWrongDatum"
(stakePolicy Stake.stake.gtClassRef)
agoraScripts.compiledStakePolicy
()
Stake.stakeCreationWrongDatum
, policyFailsWith
"stakeCreationUnsigned"
(stakePolicy Stake.stake.gtClassRef)
agoraScripts.compiledStakePolicy
()
Stake.stakeCreationUnsigned
]
@ -69,21 +67,21 @@ specs =
"validator"
[ validatorSucceedsWith
"stakeDepositWithdraw deposit"
(stakeValidator Stake.stake)
(toDatum $ StakeDatum 100_000 signer Nothing [])
(toDatum $ DepositWithdraw 100_000)
agoraScripts.compiledStakeValidator
(StakeDatum 100_000 signer Nothing [])
(DepositWithdraw 100_000)
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
, validatorSucceedsWith
"stakeDepositWithdraw withdraw"
(stakeValidator Stake.stake)
(toDatum $ StakeDatum 100_000 signer Nothing [])
(toDatum $ DepositWithdraw $ negate 100_000)
agoraScripts.compiledStakeValidator
(StakeDatum 100_000 signer Nothing [])
(DepositWithdraw $ negate 100_000)
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
, validatorFailsWith
"stakeDepositWithdraw negative GT"
(stakeValidator Stake.stake)
(toDatum $ StakeDatum 100_000 signer Nothing [])
(toDatum $ DepositWithdraw 1_000_000)
agoraScripts.compiledStakeValidator
(StakeDatum 100_000 signer Nothing [])
(DepositWithdraw 1_000_000)
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
, group
"set delegate"

24
agora-specs/Spec/Treasury.hs
View file

@ -25,6 +25,8 @@ import Agora.Treasury (
TreasuryRedeemer (SpendTreasuryGAT),
treasuryValidator,
)
import Agora.Utils (CompiledValidator (CompiledValidator))
import Plutarch.Api.V1 (mkValidator)
import PlutusLedgerApi.V1 (DCert (DCertDelegRegKey))
import PlutusLedgerApi.V1.Contexts (
ScriptContext (scriptContextPurpose, scriptContextTxInfo),
@ -35,7 +37,7 @@ import PlutusLedgerApi.V1.Credential (
StakingCredential (StakingHash),
)
import PlutusLedgerApi.V1.Value qualified as Value (singleton)
import Sample.Shared (trCredential)
import Sample.Shared (deterministicTracingConfing, trCredential)
import Sample.Treasury (
gatCs,
gatTn,
@ -51,6 +53,12 @@ import Test.Specification (
validatorSucceedsWith,
)
compiledTreasuryValidator :: CompiledValidator () TreasuryRedeemer
compiledTreasuryValidator =
CompiledValidator $
mkValidator deterministicTracingConfing $
treasuryValidator gatCs
specs :: [SpecificationTree]
specs =
[ group
@ -59,7 +67,7 @@ specs =
"Positive"
[ validatorSucceedsWith
"Allows for effect changes"
(treasuryValidator gatCs)
compiledTreasuryValidator
()
SpendTreasuryGAT
validCtx
@ -70,7 +78,7 @@ specs =
"Fails with ScriptPurpose not Minting"
[ validatorFailsWith
"Spending"
(treasuryValidator gatCs)
compiledTreasuryValidator
()
SpendTreasuryGAT
validCtx
@ -78,7 +86,7 @@ specs =
}
, validatorFailsWith
"Rewarding"
(treasuryValidator gatCs)
compiledTreasuryValidator
()
SpendTreasuryGAT
validCtx
@ -88,7 +96,7 @@ specs =
}
, validatorFailsWith
"Certifying"
(treasuryValidator gatCs)
compiledTreasuryValidator
()
SpendTreasuryGAT
validCtx
@ -100,7 +108,7 @@ specs =
]
, validatorFailsWith -- TODO: Use QuickCheck.
"Fails when multiple GATs burned"
(treasuryValidator gatCs)
compiledTreasuryValidator
()
SpendTreasuryGAT
validCtx
@ -115,13 +123,13 @@ specs =
}
, validatorFailsWith
"Fails when GAT token name is not script address"
(treasuryValidator gatCs)
compiledTreasuryValidator
()
SpendTreasuryGAT
trCtxGATNameNotAddress
, validatorFailsWith
"Fails with wallet as input"
(treasuryValidator gatCs)
compiledTreasuryValidator
()
SpendTreasuryGAT
( let txInfo = validCtx.scriptContextTxInfo

183
agora-testlib/Test/Specification.hs
View file

@ -49,11 +49,18 @@ module Test.Specification (
toTestTree,
) where
import Plutarch.Api.V1 (PMintingPolicy, PValidator)
import Plutarch.Builtin (pforgetData)
import Agora.Utils (CompiledEffect (..), CompiledMintingPolicy (..), CompiledValidator (..))
import Control.Composition ((.**), (.***))
import Data.Coerce (coerce)
import Plutarch.Evaluate (evalScript)
import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
import PlutusLedgerApi.V1 (Script, ScriptContext)
import PlutusLedgerApi.V1 (
Datum (..),
Redeemer (Redeemer),
Script,
ScriptContext,
ToData (toBuiltinData),
)
import PlutusLedgerApi.V1.Scripts (Context (..), applyMintingPolicyScript, applyValidator)
import PlutusTx.IsData qualified as PlutusTx (ToData)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase)
@ -152,122 +159,133 @@ scriptSucceeds name script = Terminal $ Specification name Success script
scriptFails :: String -> Script -> SpecificationTree
scriptFails name script = Terminal $ Specification name Failure script
mkContext :: ScriptContext -> Context
mkContext = Context . toBuiltinData
mkRedeemer ::
forall redeemer.
(PlutusTx.ToData redeemer) =>
redeemer ->
Redeemer
mkRedeemer = Redeemer . toBuiltinData
mkDatum ::
forall datum.
(PlutusTx.ToData datum) =>
datum ->
Datum
mkDatum = Datum . toBuiltinData
applyMintingPolicy' ::
(PlutusTx.ToData redeemer) =>
CompiledMintingPolicy redeemer ->
redeemer ->
ScriptContext ->
Script
applyMintingPolicy' policy redeemer scriptContext =
applyMintingPolicyScript
(mkContext scriptContext)
(getCompiledMintingPolicy policy)
(mkRedeemer redeemer)
applyValidator' ::
( PlutusTx.ToData datum
, PlutusTx.ToData redeemer
) =>
CompiledValidator datum redeemer ->
datum ->
redeemer ->
ScriptContext ->
Script
applyValidator' validator datum redeemer scriptContext =
applyValidator
(mkContext scriptContext)
(getCompiledValidator validator)
(mkDatum datum)
(mkRedeemer redeemer)
-- | Check that a policy script succeeds, given a name and arguments.
policySucceedsWith ::
( PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
) =>
(PlutusTx.ToData redeemer) =>
String ->
ClosedTerm PMintingPolicy ->
PLifted redeemer ->
CompiledMintingPolicy redeemer ->
redeemer ->
ScriptContext ->
SpecificationTree
policySucceedsWith tag policy redeemer scriptContext =
scriptSucceeds tag $
compile
( policy
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
)
policySucceedsWith tag =
scriptSucceeds tag .** applyMintingPolicy'
-- | Check that a policy script fails, given a name and arguments.
policyFailsWith ::
( PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
) =>
(PlutusTx.ToData redeemer) =>
String ->
ClosedTerm PMintingPolicy ->
PLifted redeemer ->
CompiledMintingPolicy redeemer ->
redeemer ->
ScriptContext ->
SpecificationTree
policyFailsWith tag policy redeemer scriptContext =
scriptFails tag $
compile
( policy
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
)
policyFailsWith tag =
scriptFails tag .** applyMintingPolicy'
-- | Check that a validator script succeeds, given a name and arguments.
validatorSucceedsWith ::
( PLift datum
, PlutusTx.ToData (PLifted datum)
, PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
( PlutusTx.ToData datum
, PlutusTx.ToData redeemer
) =>
String ->
ClosedTerm PValidator ->
PLifted datum ->
PLifted redeemer ->
CompiledValidator datum redeemer ->
datum ->
redeemer ->
ScriptContext ->
SpecificationTree
validatorSucceedsWith tag validator datum redeemer scriptContext =
scriptSucceeds tag $
compile
( validator
# pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
)
validatorSucceedsWith tag =
scriptSucceeds tag .*** applyValidator'
-- | Check that a validator script fails, given a name and arguments.
validatorFailsWith ::
( PLift datum
, PlutusTx.ToData (PLifted datum)
, PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
( PlutusTx.ToData datum
, PlutusTx.ToData redeemer
) =>
String ->
ClosedTerm PValidator ->
PLifted datum ->
PLifted redeemer ->
CompiledValidator datum redeemer ->
datum ->
redeemer ->
ScriptContext ->
SpecificationTree
validatorFailsWith tag validator datum redeemer scriptContext =
scriptFails tag $
compile
( validator
# pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
)
validatorFailsWith tag =
scriptFails tag .*** applyValidator'
-- | Check that an effect succeeds, given a name and argument.
effectSucceedsWith ::
( PLift datum
, PlutusTx.ToData (PLifted datum)
( PlutusTx.ToData datum
) =>
String ->
ClosedTerm PValidator ->
PLifted datum ->
CompiledEffect datum ->
datum ->
ScriptContext ->
SpecificationTree
effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
effectSucceedsWith tag eff datum = validatorSucceedsWith tag (coerce eff) datum ()
-- | Check that an effect fails, given a name and argument.
effectFailsWith ::
( PLift datum
, PlutusTx.ToData (PLifted datum)
( PlutusTx.ToData datum
) =>
String ->
ClosedTerm PValidator ->
PLifted datum ->
CompiledEffect datum ->
datum ->
ScriptContext ->
SpecificationTree
effectFailsWith tag eff datum = validatorFailsWith tag eff datum ()
effectFailsWith tag eff datum = validatorFailsWith tag (coerce eff) datum ()
-- | Test a validator, given the expectation as a boolean value.
testValidator ::
( PLift datum
, PlutusTx.ToData (PLifted datum)
, PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
) =>
-- | Should the validator pass?
forall datum redeemer.
(PlutusTx.ToData datum, PlutusTx.ToData redeemer) =>
-- | Is this test case expected to succeed?
Bool ->
String ->
ClosedTerm PValidator ->
PLifted datum ->
PLifted redeemer ->
CompiledValidator datum redeemer ->
datum ->
redeemer ->
ScriptContext ->
SpecificationTree
testValidator isValid =
@ -275,14 +293,15 @@ testValidator isValid =
then validatorSucceedsWith
else validatorFailsWith
-- | Test a policy, given the expectation as a boolean value.
testPolicy ::
( PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
) =>
forall redeemer.
(PlutusTx.ToData redeemer) =>
-- | Is this test case expected to succeed?
Bool ->
String ->
ClosedTerm PMintingPolicy ->
PLifted redeemer ->
CompiledMintingPolicy redeemer ->
redeemer ->
ScriptContext ->
SpecificationTree
testPolicy isValid =

11
agora-testlib/Test/Util.hs
View file

@ -19,7 +19,6 @@ module Test.Util (
scriptCredentials,
validatorHashes,
groupsOfN,
withOptional,
mkSpending,
mkMinting,
CombinableBuilder,
@ -37,7 +36,6 @@ import Data.ByteString.Lazy qualified as ByteString.Lazy
import Data.List (sortOn)
import Plutarch.Context (
Builder,
UTXO,
buildMintingUnsafe,
buildSpendingUnsafe,
withMinting,
@ -182,15 +180,6 @@ groupsOfN n xs =
--------------------------------------------------------------------------------
-- | Optionally apply a modifier to the given 'UTXO'.
withOptional ::
(a -> UTXO -> UTXO) ->
Maybe a ->
UTXO ->
UTXO
withOptional f (Just b) = f b
withOptional _ _ = id
{- | Given the builder generator and the parameters, create a 'ScriptContext'
that spends the UTXO that referenced by the given 'TxOutRef'.
-}

3
agora.cabal
View file

@ -95,6 +95,7 @@ common deps
, bytestring
, cardano-binary
, cardano-prelude
, composition-prelude
, containers
, data-default
, data-default-class
@ -143,6 +144,7 @@ library
exposed-modules:
Agora.Aeson.Orphans
Agora.AuthorityToken
Agora.Bootstrap
Agora.Effect
Agora.Effect.GovernorMutation
Agora.Effect.NoOp
@ -154,6 +156,7 @@ library
Agora.Proposal.Scripts
Agora.Proposal.Time
Agora.SafeMoney
Agora.Scripts
Agora.Stake
Agora.Stake.Scripts
Agora.Treasury

11
agora/Agora/AuthorityToken.hs
View file

@ -12,7 +12,6 @@ module Agora.AuthorityToken (
AuthorityToken (..),
) where
import GHC.Generics qualified as GHC
import Plutarch.Api.V1 (
AmountGuarantees,
KeyGuarantees,
@ -53,7 +52,7 @@ newtype AuthorityToken = AuthorityToken
}
deriving stock
( -- | @since 0.1.0
GHC.Generic
Generic
)
--------------------------------------------------------------------------------
@ -105,7 +104,7 @@ authorityTokensValidIn = phoistAcyclic $
singleAuthorityTokenBurned ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s PCurrencySymbol ->
Term s (PBuiltinList (PAsData PTxInInfo)) ->
Term s (PBuiltinList PTxInInfo) ->
Term s (PValue keys amounts) ->
Term s PBool
singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
@ -120,7 +119,7 @@ singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
pall
# plam
( \txInInfo' -> unTermCont $ do
PTxInInfo txInInfo <- pmatchC (pfromData txInInfo')
PTxInInfo txInInfo <- pmatchC txInInfo'
let txOut' = pfield @"resolved" # txInInfo
pure $ authorityTokensValidIn # gatCs # pfromData txOut'
)
@ -156,9 +155,7 @@ authorityTokenPolicy params =
pguardC "All outputs only emit valid GATs" $
pall
# plam
( (authorityTokensValidIn # ownSymbol #)
. pfromData
)
(authorityTokensValidIn # ownSymbol #)
# txInfo.outputs
pure $ popaque $ pconstant ()
)

67
agora/Agora/Bootstrap.hs Normal file
View file

@ -0,0 +1,67 @@
{- | Module : Agora.Bootstrap
Maintainer : connor@mlabs.city
Description: Initialize a governance system
Initialize a governance system
-}
module Agora.Bootstrap (agoraScripts) where
import Agora.AuthorityToken (AuthorityToken (..), authorityTokenPolicy)
import Agora.Governor (Governor (..))
import Agora.Governor.Scripts (governorPolicy, governorValidator)
import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
import Agora.Scripts (AgoraScripts (AgoraScripts))
import Agora.Scripts qualified as Scripts
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
import Agora.Treasury (treasuryValidator)
import Agora.Utils (
CompiledMintingPolicy (..),
CompiledValidator (..),
)
import Plutarch (Config)
import Plutarch.Api.V1 (
mintingPolicySymbol,
mkMintingPolicy,
mkValidator,
)
import PlutusLedgerApi.V1.Value (AssetClass (..))
{- | Parameterize and precompiled core scripts, given the
'Agora.Governor.Governor' parameters and plutarch configurations.
@since 0.2.0
-}
agoraScripts :: Config -> Governor -> AgoraScripts
agoraScripts conf gov = scripts
where
mkMintingPolicy' = mkMintingPolicy conf
mkValidator' = mkValidator conf
compiledGovernorPolicy = mkMintingPolicy' $ governorPolicy gov.gstOutRef
compiledGovernorValidator = mkValidator' $ governorValidator scripts
governorSymbol = mintingPolicySymbol compiledGovernorPolicy
governorAssetClass = AssetClass (governorSymbol, "")
authority = AuthorityToken governorAssetClass
compiledAuthorityPolicy = mkMintingPolicy' $ authorityTokenPolicy authority
authorityTokenSymbol = mintingPolicySymbol compiledAuthorityPolicy
compiledProposalPolicy = mkMintingPolicy' $ proposalPolicy governorAssetClass
compiledProposalValidator = mkValidator' $ proposalValidator scripts gov.maximumCosigners
compiledStakePolicy = mkMintingPolicy' $ stakePolicy gov.gtClassRef
compiledStakeValidator = mkValidator' $ stakeValidator scripts gov.gtClassRef
compiledTreasuryValidator = mkValidator' $ treasuryValidator authorityTokenSymbol
scripts =
AgoraScripts
{ Scripts.compiledGovernorPolicy = CompiledMintingPolicy compiledGovernorPolicy
, Scripts.compiledGovernorValidator = CompiledValidator compiledGovernorValidator
, Scripts.compiledStakePolicy = CompiledMintingPolicy compiledStakePolicy
, Scripts.compiledStakeValidator = CompiledValidator compiledStakeValidator
, Scripts.compiledProposalPolicy = CompiledMintingPolicy compiledProposalPolicy
, Scripts.compiledProposalValidator = CompiledValidator compiledProposalValidator
, Scripts.compiledTreasuryValidator = CompiledValidator compiledTreasuryValidator
, Scripts.compiledAuthorityTokenPolicy = CompiledMintingPolicy compiledAuthorityPolicy
}

13
agora/Agora/Effect.hs
View file

@ -8,7 +8,14 @@ Helpers for constructing effects.
module Agora.Effect (makeEffect) where
import Agora.AuthorityToken (singleAuthorityTokenBurned)
import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
import Plutarch.Api.V1 (
PCurrencySymbol,
PScriptPurpose (PSpending),
PTxInfo,
PTxOutRef,
PValidator,
PValue,
)
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
import Plutarch.TryFrom ()
import PlutusLedgerApi.V1.Value (CurrencySymbol)
@ -23,7 +30,7 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol)
-}
makeEffect ::
forall (datum :: PType).
(PIsData datum, PTryFrom PData (PAsData datum)) =>
(PTryFrom PData datum, PIsData datum) =>
CurrencySymbol ->
(forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
ClosedTerm PValidator
@ -34,7 +41,7 @@ makeEffect gatCs' f =
-- convert input datum, PData, into desierable type
-- the way this conversion is performed should be defined
-- by PTryFrom for each datum in effect script.
(pfromData -> datum', _) <- ptryFromC datum
(datum', _) <- ptryFromC datum
-- ensure purpose is Spending.
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose

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

@ -20,18 +20,12 @@ module Agora.Effect.GovernorMutation (
import Agora.Effect (makeEffect)
import Agora.Governor (
Governor,
GovernorDatum,
PGovernorDatum,
pisGovernorDatumValid,
)
import Agora.Governor.Scripts (
authorityTokenSymbolFromGovernor,
governorSTAssetClassFromGovernor,
)
import Agora.Plutarch.Orphans ()
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTAssetClass)
import Plutarch.Api.V1 (
PTxOutRef,
PValidator,
@ -42,7 +36,6 @@ import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pvalueOf)
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
)
import Plutarch.Extra.Maybe (
passertPDJust,
@ -66,8 +59,12 @@ data MutateGovernorDatum = MutateGovernorDatum
, newDatum :: GovernorDatum
-- ^ The new settings for the governor.
}
deriving stock (Show, GHC.Generic)
deriving anyclass (Generic)
deriving stock
( -- | @since 0.1.ç
Show
, -- | @since 0.1.ç
Generic
)
PlutusTx.makeIsDataIndexed ''MutateGovernorDatum [('MutateGovernorDatum, 0)]
@ -88,18 +85,10 @@ newtype PMutateGovernorDatum (s :: S)
)
)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
@ -109,7 +98,9 @@ newtype PMutateGovernorDatum (s :: S)
, -- | @since 0.1.0
PEq
)
via (PIsDataReprInstances PMutateGovernorDatum)
instance DerivePlutusType PMutateGovernorDatum where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0
instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernorDatum = MutateGovernorDatum
@ -118,7 +109,7 @@ instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernor
deriving via (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum) instance (PConstantDecl MutateGovernorDatum)
-- | @since 0.1.0
deriving via PAsData (PIsDataReprInstances PMutateGovernorDatum) instance PTryFrom PData (PAsData PMutateGovernorDatum)
deriving anyclass instance PTryFrom PData PMutateGovernorDatum
--------------------------------------------------------------------------------
@ -147,8 +138,11 @@ deriving via PAsData (PIsDataReprInstances PMutateGovernorDatum) instance PTryFr
@since 0.1.0
-}
mutateGovernorValidator :: Governor -> ClosedTerm PValidator
mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov) $
mutateGovernorValidator ::
-- | Lazy precompiled scripts. This is beacuse we need the symbol of GST.
AgoraScripts ->
ClosedTerm PValidator
mutateGovernorValidator as = makeEffect (authorityTokenSymbol as) $
\_gatCs (datum :: Term _ PMutateGovernorDatum) _ txInfo -> unTermCont $ do
datumF <- pletFieldsC @'["newDatum", "governorRef"] datum
txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums"] txInfo
@ -195,7 +189,7 @@ mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov)
plength # pfromData txInfoF.outputs #== 1
let govAddress = pfield @"address" #$ govInInfo.resolved
govOutput' = pfromData $ phead # pfromData txInfoF.outputs
govOutput' = phead # pfromData txInfoF.outputs
govOutput <- pletFieldsC @'["address", "value", "datumHash"] govOutput'
@ -208,8 +202,7 @@ mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov)
let governorOutputDatumHash =
passertPDJust # "Governor output doesn't have datum" # govOutput.datumHash
governorOutputDatum =
pfromData @PGovernorDatum $
passertPJust # "Governor output datum not found"
passertPJust @PGovernorDatum # "Governor output datum not found"
#$ ptryFindDatum # governorOutputDatumHash # txInfoF.datums
-- Ensure the output governor datum is what we want.
@ -222,4 +215,4 @@ mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov)
gstValueOf :: Term s (PValue _ _ :--> PInteger)
gstValueOf = phoistAcyclic $ plam $ \v -> pvalueOf # v # pconstant cs # pconstant tn
where
AssetClass (cs, tn) = governorSTAssetClassFromGovernor gov
AssetClass (cs, tn) = governorSTAssetClass as

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

@ -7,11 +7,9 @@ A dumb effect that only burns its GAT.
-}
module Agora.Effect.NoOp (noOpValidator, PNoOp) where
import Control.Applicative (Const)
import Agora.Effect (makeEffect)
import Agora.Plutarch.Orphans ()
import Plutarch.Api.V1 (PValidator)
import Plutarch.TryFrom (PTryFrom (..))
import PlutusLedgerApi.V1.Value (CurrencySymbol)
{- | Dummy datum for NoOp effect.
@ -19,22 +17,23 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol)
@since 0.1.0
-}
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
deriving
deriving stock
( -- | @since 0.2.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via (DerivePNewtype PNoOp PUnit)
-- | @since 0.1.0
instance PTryFrom PData (PAsData PNoOp) where
type PTryFromExcess PData (PAsData PNoOp) = Const ()
ptryFrom' _ cont =
-- JUSTIFICATION:
-- We don't care anything about data.
-- It should always be reduced to Unit.
cont (pdata $ pcon $ PNoOp (pconstant ()), ())
-- | @since 0.2.0
instance DerivePlutusType PNoOp where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.2.0
instance PTryFrom PData (PAsData PNoOp)
{- | Dummy effect which can only burn its GAT.
@ -42,4 +41,4 @@ instance PTryFrom PData (PAsData PNoOp) where
-}
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
noOpValidator curr = makeEffect curr $
\_ (_datum :: Term s PNoOp) _ _ -> popaque (pconstant ())
\_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())

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

@ -15,8 +15,6 @@ module Agora.Effect.TreasuryWithdrawal (
import Agora.Effect (makeEffect)
import Agora.Plutarch.Orphans ()
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (
AmountGuarantees (Positive),
KeyGuarantees (Sorted),
@ -31,7 +29,6 @@ import "plutarch" Plutarch.Api.V1.Value (pnormalize)
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (..),
)
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
@ -57,10 +54,6 @@ data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
@ -86,15 +79,9 @@ newtype PTreasuryWithdrawalDatum (s :: S)
)
deriving stock
( -- | @since 0.1.0
GHC.Generic
Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
@ -102,7 +89,9 @@ newtype PTreasuryWithdrawalDatum (s :: S)
, -- | @since 0.1.0
PDataFields
)
via PIsDataReprInstances PTreasuryWithdrawalDatum
instance DerivePlutusType PTreasuryWithdrawalDatum where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0
instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
@ -115,10 +104,7 @@ deriving via
(PConstantDecl TreasuryWithdrawalDatum)
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PTreasuryWithdrawalDatum)
instance
PTryFrom PData (PAsData PTreasuryWithdrawalDatum)
instance PTryFrom PData PTreasuryWithdrawalDatum
{- | Withdraws given list of values to specific target addresses.
It can be evoked by burning GAT. The transaction should have correct
@ -150,17 +136,17 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
pletC $
pmap
# plam
( \(pfromData -> txOut') -> unTermCont $ do
( \txOut' -> unTermCont $ do
txOut <- pletFieldsC @'["address", "value"] $ txOut'
let cred = pfield @"credential" # pfromData txOut.address
pure . pdata $ ptuple # cred # txOut.value
)
# txInfo.outputs
# pfromData txInfo.outputs
inputValues <-
pletC $
pmap
# plam
( \((pfield @"resolved" #) . pfromData -> txOut') -> unTermCont $ do
( \((pfield @"resolved" #) -> txOut') -> unTermCont $ do
txOut <- pletFieldsC @'["address", "value"] $ txOut'
let cred = pfield @"credential" # pfromData txOut.address
pure . pdata $ ptuple # cred # txOut.value
@ -189,7 +175,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
pnot #$ pany
# plam
( \x ->
effInput.address #== pfield @"address" # pfromData x
effInput.address #== pfield @"address" # x
)
# pfromData txInfo.outputs
inputsAreOnlyTreasuriesOrCollateral =

70
agora/Agora/Governor.hs
View file

@ -40,18 +40,15 @@ import Agora.Proposal.Time (
)
import Agora.SafeMoney (GTTag)
import Data.Tagged (Tagged (..))
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
)
import Plutarch.Extra.IsData (
DerivePConstantViaEnum (..),
EnumIsData (..),
PlutusTypeEnumData,
)
import Plutarch.Extra.Other (DerivePNewtype' (..))
import Plutarch.Extra.TermCont (pletFieldsC)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import PlutusLedgerApi.V1 (TxOutRef)
@ -78,7 +75,12 @@ data GovernorDatum = GovernorDatum
-- ^ The maximum number of unfinished proposals that a stake is allowed to be
-- associated to.
}
deriving stock (Show, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
@ -105,16 +107,12 @@ data GovernorRedeemer
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
Generic
, -- | @since 0.2.0
Enum
, -- | @since 0.2.0
Bounded
)
deriving anyclass
( -- | @since 0.2.0
Generic
)
deriving
( -- | @since 0.1.0
PlutusTx.ToData
@ -136,7 +134,12 @@ data Governor = Governor
-- ^ Arbitrary limit for maximum amount of cosigners on a proposal.
-- See `Agora.Proposal.proposalDatumValid`.
}
deriving stock (GHC.Generic)
deriving stock
( -- | @since 0.1.0
Generic
, -- | @since 0.2.0
Show
)
--------------------------------------------------------------------------------
@ -158,18 +161,10 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
)
}
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
@ -179,7 +174,10 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
, -- | @since 0.1.0
PEq
)
via PIsDataReprInstances PGovernorDatum
-- | @since 0.2.0
instance DerivePlutusType PGovernorDatum where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0
instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = GovernorDatum
@ -188,29 +186,39 @@ instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = Gove
deriving via (DerivePConstantViaData GovernorDatum PGovernorDatum) instance (PConstantDecl GovernorDatum)
-- | @since 0.1.0
deriving via PAsData (PIsDataReprInstances PGovernorDatum) instance PTryFrom PData (PAsData PGovernorDatum)
deriving anyclass instance PTryFrom PData PGovernorDatum
{- | Plutarch-level version of 'GovernorRedeemer'.
@since 0.1.0
-}
newtype PGovernorRedeemer (s :: S)
= PGovernorRedeemer (Term s PInteger)
data PGovernorRedeemer (s :: S)
= PCreateProposal
| PMintGATs
| PMutateGovernor
deriving stock
( -- | @since 0.1.0
GHC.Generic
Generic
, -- | @since 0.2.0
Enum
, -- | @since 0.2.0
Bounded
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.2.0
PEq
)
via (DerivePNewtype' PGovernorRedeemer)
-- | @since 0.2.0
instance PTryFrom PData (PAsData PGovernorRedeemer)
-- | @since 0.2.0
instance DerivePlutusType PGovernorRedeemer where
type DPTStrat _ = PlutusTypeEnumData
-- | @since 0.1.0
instance PUnsafeLiftDecl PGovernorRedeemer where type PLifted PGovernorRedeemer = GovernorRedeemer
@ -255,9 +263,9 @@ pisGovernorDatumValid = phoistAcyclic $
foldr1
(#&&)
[ ptraceIfFalse "thresholds valid" $
pisProposalThresholdsValid # datumF.proposalThresholds
pisProposalThresholdsValid # pfromData datumF.proposalThresholds
, ptraceIfFalse "timings valid" $
pisProposalTimingConfigValid # datumF.proposalTimings
pisProposalTimingConfigValid # pfromData datumF.proposalTimings
, ptraceIfFalse "time range valid" $
pisMaxTimeRangeWidthValid # datumF.createProposalTimeRangeMaxWidth
]

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

@ -12,33 +12,15 @@ module Agora.Governor.Scripts (
-- * Scripts
governorPolicy,
governorValidator,
-- * Bridges
governorSTSymbolFromGovernor,
governorSTAssetClassFromGovernor,
proposalSTAssetClassFromGovernor,
stakeSTSymbolFromGovernor,
stakeFromGovernor,
stakeValidatorHashFromGovernor,
proposalFromGovernor,
proposalValidatorHashFromGovernor,
proposalSTSymbolFromGovernor,
stakeSTAssetClassFromGovernor,
governorValidatorHash,
authorityTokenFromGovernor,
authorityTokenSymbolFromGovernor,
) where
--------------------------------------------------------------------------------
import Agora.AuthorityToken (
AuthorityToken (..),
authorityTokenPolicy,
authorityTokensValidIn,
singleAuthorityTokenBurned,
)
import Agora.Governor (
Governor (gstOutRef, gtClassRef, maximumCosigners),
GovernorRedeemer (..),
PGovernorDatum (PGovernorDatum),
pgetNextProposalId,
@ -46,7 +28,6 @@ import Agora.Governor (
)
import Agora.Proposal (
PProposalDatum (..),
Proposal (..),
ProposalStatus (Draft, Locked),
phasNeutralEffect,
pisEffectsVotesCompatible,
@ -54,25 +35,16 @@ import Agora.Proposal (
pneutralOption,
pwinner,
)
import Agora.Proposal.Scripts (
proposalPolicy,
proposalValidator,
)
import Agora.Proposal.Time (createProposalStartingTime)
import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTSymbol, proposalSTSymbol, proposalValidatoHash, stakeSTSymbol)
import Agora.Stake (
PProposalLock (..),
PStakeDatum (..),
Stake (..),
pnumCreatedProposals,
)
import Agora.Stake.Scripts (
stakePolicy,
stakeValidator,
)
import Agora.Utils (
mustFindDatum',
validatorHashToAddress,
validatorHashToTokenName,
)
import Plutarch.Api.V1 (
PAddress,
@ -84,24 +56,11 @@ import Plutarch.Api.V1 (
PTxOut,
PValidator,
PValidatorHash,
mintingPolicySymbol,
mkMintingPolicy,
mkValidator,
validatorHash,
)
import Plutarch.Api.V1.AssetClass (
passetClass,
passetClassValueOf,
)
import Plutarch.Extra.IsData (pmatchEnumFromData)
import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Map (
plookup,
plookup',
)
--------------------------------------------------------------------------------
import Plutarch.Api.V1.ScriptContext (
pfindOutputsToAddress,
pfindTxInByTxOutRef,
@ -112,17 +71,16 @@ import Plutarch.Api.V1.ScriptContext (
)
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (phasOnlyOneTokenOfCurrencySymbol, psymbolValueOf)
import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pisDJust)
import Plutarch.Extra.IsData (pmatchEnumFromData)
import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Map (
plookup,
plookup',
)
import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pfromJust, pisDJust)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
import PlutusLedgerApi.V1 (
CurrencySymbol (..),
MintingPolicy,
)
import PlutusLedgerApi.V1.Scripts (ValidatorHash (..))
import PlutusLedgerApi.V1.Value (
AssetClass (..),
)
import PlutusLedgerApi.V1 (TxOutRef)
--------------------------------------------------------------------------------
@ -153,10 +111,10 @@ import PlutusLedgerApi.V1.Value (
@since 0.1.0
-}
governorPolicy :: Governor -> ClosedTerm PMintingPolicy
governorPolicy gov =
governorPolicy :: TxOutRef -> ClosedTerm PMintingPolicy
governorPolicy initialSpend =
plam $ \_ ctx' -> unTermCont $ do
let oref = pconstant gov.gstOutRef
let oref = pconstant initialSpend
PMinting ((pfield @"_0" #) -> ownSymbol) <- pmatchC (pfromData $ pfield @"purpose" # ctx')
let ownAssetClass = passetClass # ownSymbol # pconstant ""
@ -177,12 +135,12 @@ governorPolicy gov =
# "Governor output not found"
#$ pfind
# plam
( \((pfield @"value" #) . pfromData -> value) ->
( \((pfield @"value" #) -> value) ->
psymbolValueOf # ownSymbol # value #== 1
)
# pfromData txInfoF.outputs
let datumHash = pfield @"datumHash" # pfromData govOutput
let datumHash = pfield @"datumHash" # govOutput
datum = mustFindDatum' @PGovernorDatum # datumHash # txInfoF.datums
pguardC "Governor output datum valid" $ pisGovernorDatumValid # datum
@ -275,8 +233,11 @@ governorPolicy gov =
@since 0.1.0
-}
governorValidator :: Governor -> ClosedTerm PValidator
governorValidator gov =
governorValidator ::
-- | Lazy precompiled scripts.
AgoraScripts ->
ClosedTerm PValidator
governorValidator as =
plam $ \datum' redeemer' ctx' -> unTermCont $ do
ctxF <- pletAllC ctx'
@ -292,7 +253,7 @@ governorValidator gov =
ownInputF <- pletFieldsC @'["address", "value"] ownInput
let ownAddress = pfromData $ ownInputF.address
(pfromData -> (oldGovernorDatum :: Term _ PGovernorDatum), _) <- ptryFromC datum'
(oldGovernorDatum :: Term _ PGovernorDatum, _) <- ptryFromC datum'
oldGovernorDatumF <- pletAllC oldGovernorDatum
-- Check that GST will be returned to the governor.
@ -314,7 +275,6 @@ governorValidator gov =
passertPDJust # "Governor output doesn't have datum" # ownOutput.datumHash
newGovernorDatum <-
pletC $
pfromData $
passertPJust # "Ouput governor state datum not found"
#$ ptryFindDatum # outputGovernorStateDatumHash # txInfoF.datums
@ -368,9 +328,9 @@ governorValidator gov =
pguardC "Stake input doesn't have datum" $
pisDJust # stakeInputF.datumHash
let stakeInputDatum = mustFindDatum' @PStakeDatum # stakeInputF.datumHash # txInfoF.datums
let stakeInputDatum = mustFindDatum' @(PAsData PStakeDatum) # stakeInputF.datumHash # txInfoF.datums
stakeInputDatumF <- pletAllC stakeInputDatum
stakeInputDatumF <- pletAllC $ pto $ pfromData stakeInputDatum
pguardC "Proposals created by the stake must not exceed the number stored in the governor." $
pnumCreatedProposals # stakeInputDatumF.lockedBy
@ -400,14 +360,14 @@ governorValidator gov =
proposalOutputDatum' <-
pletC $
mustFindDatum' @PProposalDatum
mustFindDatum' @(PAsData PProposalDatum)
# outputDatumHash
# txInfoF.datums
proposalOutputDatum <- pletAllC proposalOutputDatum'
proposalOutputDatum <- pletAllC $ pto $ pfromData proposalOutputDatum'
let expectedStartingTime =
createProposalStartingTime
pfromJust #$ createProposalStartingTime
# oldGovernorDatumF.createProposalTimeRangeMaxWidth
# txInfoF.validRange
@ -462,7 +422,7 @@ governorValidator gov =
#$ ptryFindDatum # stakeOutputDatumHash # txInfoF.datums
stakeOutputLocks =
pfromData $ pfield @"lockedBy" # stakeOutputDatum
pfromData $ pfield @"lockedBy" #$ pto $ pfromData stakeOutputDatum
-- The stake should be locked by the newly created proposal.
newLock =
@ -493,8 +453,7 @@ governorValidator gov =
proposalInputF <-
pletFieldsC @'["datumHash"] $
pfield @"resolved"
#$ pfromData
$ passertPJust
#$ passertPJust
# "Proposal input not found"
#$ pfind
# plam
@ -509,13 +468,13 @@ governorValidator gov =
proposalInputDatum <-
pletC $
mustFindDatum' @PProposalDatum
mustFindDatum' @(PAsData PProposalDatum)
# proposalInputF.datumHash
# txInfoF.datums
proposalInputDatumF <-
pletFieldsC @'["effects", "status", "thresholds", "votes"]
proposalInputDatum
pletFieldsC @'["effects", "status", "thresholds", "votes"] $
pto $ pfromData proposalInputDatum
-- Check that the proposal state is advanced so that a proposal cannot be executed twice.
@ -552,12 +511,12 @@ governorValidator gov =
pguardC "Output GATs is more than minted GATs" $
plength # outputsWithGAT #== gatCount
let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PAsData PTxOut :--> PBool)
let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PTxOut :--> PBool)
gatOutputValidator' =
phoistAcyclic $
plam
( \effects (pfromData -> output') -> unTermCont $ do
output <- pletFieldsC @'["address", "datumHash"] $ output'
( \effects output' -> unTermCont $ do
output <- pletFieldsC @'["address", "datumHash"] output'
let scriptHash =
passertPJust # "GAT receiver is not a script"
@ -608,160 +567,23 @@ governorValidator gov =
where
-- The currency symbol of authority token.
patSymbol :: Term s PCurrencySymbol
patSymbol = phoistAcyclic $ pconstant $ authorityTokenSymbolFromGovernor gov
patSymbol = pconstant $ authorityTokenSymbol as
-- The currency symbol of the proposal state token.
ppstSymbol :: Term s PCurrencySymbol
ppstSymbol =
let AssetClass (sym, _) = proposalSTAssetClassFromGovernor gov
in phoistAcyclic $ pconstant sym
ppstSymbol = pconstant $ proposalSTSymbol as
-- The address of the proposal validator.
pproposalValidatorAddress :: Term s PAddress
pproposalValidatorAddress =
let vh = proposalValidatorHashFromGovernor gov
in phoistAcyclic $ pconstant $ validatorHashToAddress vh
pconstant $
validatorHashToAddress $
proposalValidatoHash as
-- The currency symbol of the stake state token.
psstSymbol :: Term s PCurrencySymbol
psstSymbol =
let sym = stakeSTSymbolFromGovernor gov
in phoistAcyclic $ pconstant sym
psstSymbol = pconstant $ stakeSTSymbol as
-- The currency symbol of the governor state token.
pgstSymbol :: Term s PCurrencySymbol
pgstSymbol =
let sym = governorSTSymbolFromGovernor gov
in phoistAcyclic $ pconstant sym
--------------------------------------------------------------------------------
{- | Get the 'CurrencySymbol' of GST.
@since 0.1.0
-}
governorSTSymbolFromGovernor :: Governor -> CurrencySymbol
governorSTSymbolFromGovernor gov = mintingPolicySymbol policy
where
policy :: MintingPolicy
policy = mkMintingPolicy $ governorPolicy gov
{- | Get the 'AssetClass' of GST.
@since 0.1.0
-}
governorSTAssetClassFromGovernor :: Governor -> AssetClass
governorSTAssetClassFromGovernor gov = AssetClass (symbol, "")
where
symbol :: CurrencySymbol
symbol = governorSTSymbolFromGovernor gov
{- | Get the 'CurrencySymbol' of the proposal state token.
@since 0.1.0
-}
proposalSTSymbolFromGovernor :: Governor -> CurrencySymbol
proposalSTSymbolFromGovernor gov = symbol
where
gstAC = governorSTAssetClassFromGovernor gov
policy = mkMintingPolicy $ proposalPolicy gstAC
symbol = mintingPolicySymbol policy
{- | Get the 'AssetClass' of the proposal state token.
@since 0.1.0
-}
proposalSTAssetClassFromGovernor :: Governor -> AssetClass
proposalSTAssetClassFromGovernor gov = AssetClass (symbol, "")
where
symbol = proposalSTSymbolFromGovernor gov
{- | Get the 'CurrencySymbol' of the stake token/
@since 0.1.0
-}
stakeSTSymbolFromGovernor :: Governor -> CurrencySymbol
stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy
where
policy = mkMintingPolicy $ stakePolicy gov.gtClassRef
{- | Get the 'AssetClass' of the stake token.
Note that the token is tagged with the hash of the stake validator.
See 'Agora.Stake.Script.stakePolicy'.
@since 0.1.0
-}
stakeSTAssetClassFromGovernor :: Governor -> AssetClass
stakeSTAssetClassFromGovernor gov = AssetClass (symbol, tokenName)
where
symbol = stakeSTSymbolFromGovernor gov
-- Tag with the address where the token is being sent to.
tokenName = validatorHashToTokenName $ stakeValidatorHashFromGovernor gov
{- | Get the 'Stake' parameter, given the 'Governor' parameter.
@since 0.1.0
-}
stakeFromGovernor :: Governor -> Stake
stakeFromGovernor gov =
Stake gov.gtClassRef $
proposalSTAssetClassFromGovernor gov
{- | Get the hash of 'Agora.Stake.Script.stakePolicy'.
@since 0.1.0
-}
stakeValidatorHashFromGovernor :: Governor -> ValidatorHash
stakeValidatorHashFromGovernor gov = validatorHash validator
where
params = stakeFromGovernor gov
validator = mkValidator $ stakeValidator params
{- | Get the 'Proposal' parameter, given the 'Governor' parameter.
@since 0.1.0
-}
proposalFromGovernor :: Governor -> Proposal
proposalFromGovernor gov = Proposal gstAC sstAC mc
where
gstAC = governorSTAssetClassFromGovernor gov
mc = gov.maximumCosigners
sstAC = stakeSTAssetClassFromGovernor gov
{- | Get the hash of 'Agora.Proposal.proposalPolicy'.
@since 0.1.0
-}
proposalValidatorHashFromGovernor :: Governor -> ValidatorHash
proposalValidatorHashFromGovernor gov = validatorHash validator
where
params = proposalFromGovernor gov
validator = mkValidator $ proposalValidator params
{- | Get the hash of 'Agora.Proposal.proposalValidator'.
@since 0.1.0
-}
governorValidatorHash :: Governor -> ValidatorHash
governorValidatorHash gov = validatorHash validator
where
validator = mkValidator $ governorValidator gov
{- | Get the 'AuthorityToken' parameter given the 'Governor' parameter.
@since 0.1.0
-}
authorityTokenFromGovernor :: Governor -> AuthorityToken
authorityTokenFromGovernor gov = AuthorityToken $ governorSTAssetClassFromGovernor gov
{- | Get the 'CurrencySymbol' of the authority token.
@since 0.1.0
-}
authorityTokenSymbolFromGovernor :: Governor -> CurrencySymbol
authorityTokenSymbolFromGovernor gov = mintingPolicySymbol policy
where
policy = mkMintingPolicy $ authorityTokenPolicy params
params = authorityTokenFromGovernor gov
pgstSymbol = pconstant $ governorSTSymbol as

132
agora/Agora/Plutarch/Orphans.hs
View file

@ -3,133 +3,37 @@
{- FIXME: All of the following instances and
types ought to belong in either plutarch or
plutarch-extra.
A number of these have been "stolen" from Mango's
PR: https://github.com/Plutonomicon/plutarch/pull/438/
-}
module Agora.Plutarch.Orphans () where
import Control.Arrow (first)
import Plutarch.Api.V1 (PAddress, PCredential, PCurrencySymbol, PDatumHash, PMap, PMaybeData, PPOSIXTime, PPubKeyHash, PStakingCredential, PTokenName, PTxId, PTxOutRef, PValidatorHash, PValue)
import Plutarch.Builtin (PBuiltinMap)
import Plutarch.DataRepr (PIsDataReprInstances (..))
import Plutarch.Api.V1 (PDatumHash (..))
import Plutarch.Builtin (PIsData (..))
import Plutarch.Extra.TermCont (ptryFromC)
import Plutarch.Numeric.Additive (AdditiveSemigroup ((+)))
import Plutarch.Reducible (Reduce, Reducible)
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
import Plutarch.TryFrom (PTryFrom (..))
import Plutarch.Unsafe (punsafeCoerce)
import Prelude hiding ((+))
instance Reducible (f x y) => Reducible (Flip f y x) where
type Reduce (Flip f y x) = Reduce (f x y)
newtype Flip f a b = Flip (f b a)
-- | @since 0.1.0
instance PTryFrom PData (PAsData b) => PTryFrom PData (PAsData (DerivePNewtype c b)) where
type
PTryFromExcess PData (PAsData (DerivePNewtype c b)) =
PTryFromExcess PData (PAsData b)
ptryFrom' d k =
ptryFrom' @_ @(PAsData b) d $ k . first punsafeCoerce
-- | @since 0.1.0
instance PTryFrom PData (PAsData PPubKeyHash) where
type PTryFromExcess PData (PAsData PPubKeyHash) = Flip Term PPubKeyHash
ptryFrom' opq = runTermCont $ do
(wrapped :: Term _ (PAsData PByteString), unwrapped :: Term _ PByteString) <-
ptryFromC @(PAsData PByteString) opq
tcont $ \f -> pif (plengthBS # unwrapped #== 28) (f ()) (ptraceError "a PubKeyHash should be 28 bytes long")
pure (punsafeCoerce wrapped, punsafeCoerce unwrapped)
-- | @since 0.1.0
instance AdditiveSemigroup (Term s PPOSIXTime) where
(punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
-- | @since 0.1.0
deriving via
PAsData (DerivePNewtype PPOSIXTime PInteger)
instance
PTryFrom PData (PAsData PPOSIXTime)
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PTxId)
instance
PTryFrom PData (PAsData PTxId)
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PTxOutRef)
instance
PTryFrom PData (PAsData PTxOutRef)
-- | @since 0.1.0
deriving via
PAsData (DerivePNewtype (PMap g k v) (PBuiltinMap k v))
instance
( PTryFrom PData (PAsData k)
, PTryFrom PData (PAsData v)
) =>
PTryFrom PData (PAsData (PMap g k v))
-- | @since 0.1.0
instance PTryFrom PData (PAsData PValidatorHash) where
type PTryFromExcess PData (PAsData PValidatorHash) = Flip Term PValidatorHash
ptryFrom' opq = runTermCont $ do
(wrapped :: Term _ (PAsData PByteString), unwrapped :: Term _ PByteString) <-
ptryFromC @(PAsData PByteString) opq
tcont $ \f -> pif (plengthBS # unwrapped #== 28) (f ()) (ptraceError "a ValidatorHash should be 28 bytes long")
pure (punsafeCoerce wrapped, punsafeCoerce unwrapped)
newtype Flip f a b = Flip (f b a) deriving stock (Generic)
-- | @since 0.1.0
instance PTryFrom PData (PAsData PDatumHash) where
type PTryFromExcess PData (PAsData PDatumHash) = Flip Term PDatumHash
ptryFrom' opq = runTermCont $ do
(wrapped :: Term _ (PAsData PByteString), unwrapped :: Term _ PByteString) <-
tcont $ ptryFrom @(PAsData PByteString) opq
tcont $ \f -> pif (plengthBS # unwrapped #== 32) (f ()) (ptraceError "a DatumHash should be 32 bytes long")
pure (punsafeCoerce wrapped, punsafeCoerce unwrapped)
(pfromData -> unwrapped, _) <- ptryFromC @(PAsData PByteString) opq
-- | @since 0.1.0
deriving via
PAsData (DerivePNewtype PCurrencySymbol PByteString)
instance
PTryFrom PData (PAsData PCurrencySymbol)
tcont $ \f ->
pif
-- Blake2b_256 hash: 256 bits/32 bytes.
(plengthBS # unwrapped #== 32)
(f ())
(ptraceError "ptryFrom(PDatumHash): must be 32 bytes long")
-- | @since 0.1.0
deriving via
PAsData (DerivePNewtype PTokenName PByteString)
instance
PTryFrom PData (PAsData PTokenName)
pure (punsafeCoerce opq, pcon $ PDatumHash unwrapped)
-- | @since 0.1.0
deriving via
PAsData (DerivePNewtype (PValue k v) (PMap k PCurrencySymbol (PMap k PTokenName PInteger)))
instance
PTryFrom PData (PAsData (PValue k v))
-- | @since 0.2.0
instance PTryFrom PData (PAsData PUnit)
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances (PMaybeData a))
instance
PTryFrom PData (PAsData a) => PTryFrom PData (PAsData (PMaybeData a))
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PAddress)
instance
PTryFrom PData (PAsData PAddress)
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PCredential)
instance
PTryFrom PData (PAsData PCredential)
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PStakingCredential)
instance
PTryFrom PData (PAsData PStakingCredential)
-- | @since 0.2.0
instance (PIsData a) => PIsData (PAsData a) where
pfromDataImpl = punsafeCoerce
pdataImpl = pdataImpl . pfromData

218
agora/Agora/Proposal.hs
View file

@ -9,7 +9,8 @@ Proposal scripts encoding effects that operate on the system.
-}
module Agora.Proposal (
-- * Haskell-land
Proposal (..),
-- Proposal (..),
ProposalDatum (..),
ProposalRedeemer (..),
ProposalStatus (..),
@ -39,11 +40,11 @@ module Agora.Proposal (
pisProposalThresholdsValid,
) where
import Agora.Plutarch.Orphans ()
import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
import Agora.SafeMoney (GTTag)
import Data.Tagged (Tagged)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Generics.SOP qualified as SOP
import Plutarch.Api.V1 (
KeyGuarantees (Unsorted),
PDatumHash,
@ -52,7 +53,7 @@ import Plutarch.Api.V1 (
PValidatorHash,
)
import Plutarch.Api.V1.AssocMap qualified as PAssocMap
import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..))
import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields)
import Plutarch.Extra.Comonad (pextract)
import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.Function (pbuiltinUncurry)
@ -60,13 +61,13 @@ import Plutarch.Extra.IsData (
DerivePConstantViaDataList (..),
DerivePConstantViaEnum (..),
EnumIsData (..),
PlutusTypeEnumData,
ProductIsData (ProductIsData),
)
import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Map qualified as PM
import Plutarch.Extra.Map.Unsorted qualified as PUM
import Plutarch.Extra.Maybe (pfromJust)
import Plutarch.Extra.Other (DerivePNewtype' (..))
import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
import Plutarch.Lift (
DerivePConstantViaNewtype (..),
@ -76,7 +77,6 @@ import Plutarch.Lift (
import Plutarch.SafeMoney (PDiscrete (..))
import Plutarch.Show (PShow (..))
import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
import PlutusLedgerApi.V1.Value (AssetClass)
import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap
@ -92,6 +92,14 @@ import PlutusTx.AssocMap qualified as AssocMap
@since 0.1.0
-}
newtype ProposalId = ProposalId {proposalTag :: Integer}
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
Generic
)
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
@ -100,14 +108,6 @@ newtype ProposalId = ProposalId {proposalTag :: Integer}
, -- | @since 0.1.0
PlutusTx.UnsafeFromData
)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
{- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
@ -127,7 +127,7 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
, -- | @since 0.1.0
Ord
, -- | @since 0.1.0
GHC.Generic
Generic
)
deriving newtype
( -- | @since 0.1.0
@ -186,7 +186,7 @@ data ProposalStatus
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
Generic
, -- | @since 0.2.0
Enum
, -- | @since 0.2.0
@ -194,7 +194,7 @@ data ProposalStatus
)
deriving anyclass
( -- | @since 0.2.0
Generic
SOP.Generic
)
deriving
( -- | @since 0.1.0
@ -230,9 +230,8 @@ data ProposalThresholds = ProposalThresholds
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
Generic
)
deriving anyclass (Generic)
PlutusTx.makeIsDataIndexed 'ProposalThresholds [('ProposalThresholds, 0)]
@ -252,19 +251,19 @@ PlutusTx.makeIsDataIndexed 'ProposalThresholds [('ProposalThresholds, 0)]
newtype ProposalVotes = ProposalVotes
{ getProposalVotes :: AssocMap.Map ResultTag Integer
}
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
Generic
)
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
)
{- | Create a 'ProposalVotes' that has the same shape as the 'effects' field.
@ -307,9 +306,12 @@ data ProposalDatum = ProposalDatum
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
Generic
)
deriving anyclass
( -- | @since 0.2.0
SOP.Generic
)
deriving anyclass (Generic)
deriving
( -- | @since 0.1.0
PlutusTx.ToData
@ -367,7 +369,7 @@ data ProposalRedeemer
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
Generic
)
-- | @since 0.1.0
@ -379,25 +381,6 @@ PlutusTx.makeIsDataIndexed
, ('AdvanceProposal, 3)
]
{- | Parameters that identify the Proposal validator script.
@since 0.1.0
-}
data Proposal = Proposal
{ governorSTAssetClass :: AssetClass
, stakeSTAssetClass :: AssetClass
, maximumCosigners :: Integer
-- ^ Arbitrary limit for maximum amount of cosigners on a proposal.
}
deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Eq
, -- | @since 0.1.0
GHC.Generic
)
--------------------------------------------------------------------------------
-- Plutarch-land
@ -406,19 +389,31 @@ data Proposal = Proposal
@since 0.1.0
-}
newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
deriving
( -- | @since 0.1.0
deriving stock
( -- | @since 0.2.0
Generic
)
deriving anyclass
( -- @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.2.0
PPartialOrd
, -- | @since 0.1.0
POrd
, -- | @since 0.2.0
PShow
)
via (DerivePNewtype PResultTag PInteger)
-- | @since 0.2.0
instance DerivePlutusType PResultTag where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0
instance PTryFrom PData (PAsData PResultTag)
-- | @since 0.1.0
instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag
@ -429,36 +424,36 @@ deriving via
instance
(PConstantDecl ResultTag)
-- | @since 0.1.0
deriving via
PAsData (DerivePNewtype PResultTag PInteger)
instance
PTryFrom PData (PAsData PResultTag)
{- | Plutarch-level version of 'PProposalId'.
@since 0.1.0
-}
newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
deriving
deriving stock
( -- | @since 0.2.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.2.0
PPartialOrd
, -- | @since 0.1.0
POrd
, -- | @since 0.2.0
PShow
)
via (DerivePNewtype PProposalId PInteger)
-- | @since 0.2.0
instance DerivePlutusType PProposalId where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0
deriving via
PAsData (DerivePNewtype PProposalId PInteger)
instance
PTryFrom PData (PAsData PProposalId)
instance PTryFrom PData (PAsData PProposalId)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
@ -473,16 +468,24 @@ deriving via
@since 0.1.0
-}
newtype PProposalStatus (s :: S) = PProposalStatus (Term s PInteger)
data PProposalStatus (s :: S)
= -- | @since 0.2.0
PDraft
| -- | @since 0.2.0
PVoting
| -- | @since 0.2.0
PLocked
| -- | @since 0.2.0
PFinished
deriving stock
( -- | @since 0.1.0
GHC.Generic
Generic
, -- | @since 0.2.0
Bounded
, -- | @since 0.2.0
Enum
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
@ -490,13 +493,16 @@ newtype PProposalStatus (s :: S) = PProposalStatus (Term s PInteger)
, -- | @since 0.1.0
PEq
)
via (DerivePNewtype' PProposalStatus)
-- | @since 0.2.0
instance DerivePlutusType PProposalStatus where
type DPTStrat _ = PlutusTypeEnumData
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
-- | @since 0.1.0
deriving via PAsData (DerivePNewtype' PProposalStatus) instance PTryFrom PData (PAsData PProposalStatus)
instance PTryFrom PData (PAsData PProposalStatus)
-- | @since 0.1.0
deriving via (DerivePConstantViaEnum ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus)
@ -517,18 +523,10 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
)
}
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
@ -536,13 +534,13 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
, -- | @since 0.1.0
PDataFields
)
via (PIsDataReprInstances PProposalThresholds)
-- | @since 0.2.0
instance DerivePlutusType PProposalThresholds where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PProposalThresholds)
instance
PTryFrom PData (PAsData PProposalThresholds)
instance PTryFrom PData PProposalThresholds
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
@ -559,19 +557,23 @@ deriving via
-}
newtype PProposalVotes (s :: S)
= PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger))
deriving
deriving stock
( -- | @since 0.2.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
-- | @since 0.2.0
instance DerivePlutusType PProposalVotes where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0
deriving via
PAsData (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
instance
PTryFrom PData (PAsData PProposalVotes)
instance PTryFrom PData (PAsData PProposalVotes)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes
@ -603,31 +605,23 @@ newtype PProposalDatum (s :: S) = PProposalDatum
)
}
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0
PEq
)
via (DerivePNewtype' PProposalDatum)
-- | @since 0.1.0
deriving via PAsData (DerivePNewtype' PProposalDatum) instance PTryFrom PData (PAsData PProposalDatum)
-- | @since 0.2.0
instance DerivePlutusType PProposalDatum where
type DPTStrat _ = PlutusTypeNewtype
instance PTryFrom PData (PAsData PProposalDatum)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
@ -645,30 +639,22 @@ data PProposalRedeemer (s :: S)
| PUnlock (Term s (PDataRecord '[]))
| PAdvanceProposal (Term s (PDataRecord '[]))
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via PIsDataReprInstances PProposalRedeemer
-- | @since 0.2.0
instance DerivePlutusType PProposalRedeemer where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PProposalRedeemer)
instance
PTryFrom PData (PAsData PProposalRedeemer)
instance PTryFrom PData PProposalRedeemer
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer

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

@ -14,7 +14,6 @@ import Agora.Proposal (
PProposalDatum (PProposalDatum),
PProposalRedeemer (..),
PProposalVotes (PProposalVotes),
Proposal (..),
ProposalStatus (..),
pretractVotes,
pwinner',
@ -26,6 +25,7 @@ import Agora.Proposal.Time (
isLockingPeriod,
isVotingPeriod,
)
import Agora.Scripts (AgoraScripts, governorSTSymbol, proposalSTSymbol, stakeSTAssetClass)
import Agora.Stake (
PProposalLock (..),
PStakeDatum (..),
@ -37,7 +37,6 @@ import Agora.Stake (
pisVoter,
)
import Agora.Utils (
getMintingPolicySymbol,
mustFindDatum',
pltAsData,
)
@ -75,7 +74,7 @@ import Plutarch.Extra.TermCont (
)
import Plutarch.SafeMoney (PDiscrete (..))
import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass, unAssetClass))
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
{- | Policy for Proposals.
@ -152,8 +151,13 @@ proposalPolicy (AssetClass (govCs, govTn)) =
@since 0.1.0
-}
proposalValidator :: Proposal -> ClosedTerm PValidator
proposalValidator proposal =
proposalValidator ::
-- | Lazy precompiled scripts.
AgoraScripts ->
-- | See 'Agora.Governor.Governor.maximumCosigners'.
Integer ->
ClosedTerm PValidator
proposalValidator as maximumCosigners =
plam $ \datum redeemer ctx' -> unTermCont $ do
PScriptContext ctx' <- pmatchC ctx'
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
@ -174,12 +178,10 @@ proposalValidator proposal =
PJust ((pfield @"resolved" #) -> txOut) <- pmatchC $ pfindTxInByTxOutRef # txOutRef # txInfoF.inputs
txOutF <- pletFieldsC @'["address", "value"] $ txOut
(pfromData -> proposalDatum, _) <-
ptryFromC @(PAsData PProposalDatum) datum
(pfromData -> proposalRedeemer, _) <-
ptryFromC @(PAsData PProposalRedeemer) redeemer
proposalDatum <- pfromData . fst <$> ptryFromC @(PAsData PProposalDatum) datum
proposalRedeemer <- fst <$> ptryFromC @PProposalRedeemer redeemer
proposalF <- pletAllC proposalDatum
proposalF <- pletAllC $ pto proposalDatum
ownAddress <- pletC $ txOutF.address
@ -187,8 +189,7 @@ proposalValidator proposal =
currentStatus <- pletC $ pfromData $ proposalF.status
let stCurrencySymbol =
pconstant $ getMintingPolicySymbol (proposalPolicy proposal.governorSTAssetClass)
let stCurrencySymbol = pconstant $ proposalSTSymbol as
signedBy <- pletC $ ptxSignedBy # txInfoF.signatories
@ -211,11 +212,12 @@ proposalValidator proposal =
-- TODO: this is highly inefficient: O(n) for every output,
-- Maybe we can cache the sorted datum map?
let datum =
mustFindDatum' @PProposalDatum
pfromData $
mustFindDatum' @(PAsData PProposalDatum)
# inputF.datumHash
# txInfoF.datums
proposalId = pfield @"proposalId" # datum
proposalId = pfield @"proposalId" # pto datum
pure $
inputF.address #== ownAddress
@ -226,7 +228,8 @@ proposalValidator proposal =
proposalOut <-
pletC $
mustFindDatum' @PProposalDatum
pfromData $
mustFindDatum' @(PAsData PProposalDatum)
# (pfield @"datumHash" # ownOutput)
# txInfoF.datums
@ -235,12 +238,10 @@ proposalValidator proposal =
proposalOutStatus <-
pletC $
pfromData $
pfield @"status" # proposalOut
pfield @"status" # pto proposalOut
onlyStatusChanged <-
pletC $
-- Only the status of proposals is updated.
-- Only the status of proposals is updated.
proposalOut
#== mkRecordConstr
@ -259,13 +260,13 @@ proposalValidator proposal =
-- Find the stake inputs/outputs by SST.
let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
let AssetClass (stakeSym, stakeTn) = stakeSTAssetClass as
stakeSTAssetClass <-
pletC $ passetClass # pconstant stakeSym # pconstant stakeTn
filterStakeDatumHash :: Term _ (PAsData PTxOut :--> PMaybe (PAsData PDatumHash)) <-
filterStakeDatumHash :: Term _ (PTxOut :--> PMaybe (PAsData PDatumHash)) <-
pletC $
plam $ \(pfromData -> txOut) -> unTermCont $ do
plam $ \txOut -> unTermCont $ do
txOutF <- pletFieldsC @'["value", "datumHash"] txOut
pure $
pif
@ -333,12 +334,11 @@ proposalValidator proposal =
let stake =
pfromData $
pfromJust
#$ ptryFindDatum
@(PAsData PStakeDatum)
#$ ptryFindDatum @(PAsData PStakeDatum)
# pfromData dh
# txInfoF.datums
stakeF <- pletFieldsC @'["stakedAmount", "owner"] stake
stakeF <- pletFieldsC @'["stakedAmount", "owner"] $ pto stake
PPair amount owners <- pmatchC l
@ -369,14 +369,10 @@ proposalValidator proposal =
stakeOutputHash <- pletC $ pfromData $ phead # stakeOutputDatumHashes
stakeIn :: Term _ PStakeDatum <-
pletC $
pfromData $
pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums
pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums
stakeOut :: Term _ PStakeDatum <-
pletC $
pfromData $
pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums
pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums
stakeUnchanged <- pletC $ stakeInputHash #== stakeOutputHash
@ -391,7 +387,7 @@ proposalValidator proposal =
withSingleStake val =
withSingleStake' #$ plam $ \stakeIn stakeOut stakeUnchange -> unTermCont $ do
stakeInF <- pletAllC stakeIn
stakeInF <- pletAllC $ pto stakeIn
val stakeInF stakeOut stakeUnchange
@ -414,7 +410,7 @@ proposalValidator proposal =
# proposalF.cosigners
pguardC "Less cosigners than maximum limit" $
plength # updatedSigs #< pconstant proposal.maximumCosigners
plength # updatedSigs #< pconstant maximumCosigners
pguardC "Cosigners are unique" $
pisUniq' # updatedSigs
@ -449,6 +445,7 @@ proposalValidator proposal =
pguardC "Proposal time should be wthin the voting period" $
isVotingPeriod # proposalF.timingConfig
# proposalF.startingTime
#$ pfromJust
# currentTime
-- Ensure the transaction is voting to a valid 'ResultTag'(outcome).
@ -581,7 +578,7 @@ proposalValidator proposal =
$ ptraceIfFalse "Proposal unchanged" proposalUnchanged
-- At last, we ensure that all locks belong to this proposal will be removed.
stakeOutputLocks <- pletC $ pfield @"lockedBy" # stakeOut
stakeOutputLocks <- pletC $ pfield @"lockedBy" # pto stakeOut
let templateStakeOut =
mkRecordConstr
@ -603,8 +600,9 @@ proposalValidator proposal =
----------------------------------------------------------------------
PAdvanceProposal _ ->
let fromDraft = withMultipleStakes $ \totalStakedAmount sortedStakeOwners ->
pmatchC (isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime) >>= \case
let currentTime' = pfromJust # currentTime
fromDraft = withMultipleStakes $ \totalStakedAmount sortedStakeOwners ->
pmatchC (isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime') >>= \case
PTrue -> do
pguardC "More cosigns than minimum amount" $
punsafeCoerce (pfromData thresholdsF.vote) #< totalStakedAmount
@ -629,9 +627,9 @@ proposalValidator proposal =
"Only status changes in the output proposal"
onlyStatusChanged
inVotingPeriod <- pletC $ isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
inExecutionPeriod <- pletC $ isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
inVotingPeriod <- pletC $ isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
inExecutionPeriod <- pletC $ isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
proposalStatus <- pletC $ pto $ pfromData proposalF.status
@ -652,23 +650,19 @@ proposalValidator proposal =
pguardC "Cannot advance ahead of time" notTooEarly
pguardC "Finished proposals cannot be advanced" $ pnot # isFinished
let gstSymbol =
pconstant $
fst $
unAssetClass proposal.governorSTAssetClass
let gstSymbol = pconstant $ governorSTSymbol as
gstMoved <-
pletC $
pany
# plam
( \( (pfield @"value" #)
. (pfield @"resolved" #)
. pfromData ->
. (pfield @"resolved" #) ->
value
) ->
psymbolValueOf # gstSymbol # value #== 1
)
# txInfoF.inputs
# pfromData txInfoF.inputs
let toFailedState = unTermCont $ do
pguardC "Proposal should fail: not on time" $

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

@ -30,9 +30,7 @@ module Agora.Proposal.Time (
pisMaxTimeRangeWidthValid,
) where
import Agora.Plutarch.Orphans ()
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, HasDatatypeInfo, I (I))
import Control.Composition ((.*))
import Plutarch.Api.V1 (
PExtended (PFinite),
PInterval (PInterval),
@ -44,19 +42,19 @@ import Plutarch.Api.V1 (
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (..),
)
import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.TermCont (pguardC, pmatchC)
import Plutarch.Extra.Applicative (PApply (pliftA2))
import Plutarch.Extra.Field (pletAll, pletAllC)
import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
import Plutarch.Extra.TermCont (pmatchC)
import Plutarch.Lift (
DerivePConstantViaNewtype (..),
PConstantDecl,
PUnsafeLiftDecl (..),
)
import Plutarch.Numeric.Additive (AdditiveSemigroup ((+)))
import PlutusLedgerApi.V1.Time (POSIXTime)
import PlutusLedgerApi.V1 (POSIXTime)
import PlutusTx qualified
import Prelude hiding ((+))
import Prelude
--------------------------------------------------------------------------------
@ -67,8 +65,22 @@ import Prelude hiding ((+))
newtype ProposalStartingTime = ProposalStartingTime
{ getProposalStartingTime :: POSIXTime
}
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
deriving stock (Eq, Show, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
Generic
)
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
, -- | @since 0.1.0
PlutusTx.UnsafeFromData
)
{- | Configuration of proposal timings.
@ -92,9 +104,8 @@ data ProposalTimingConfig = ProposalTimingConfig
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
Generic
)
deriving anyclass (Generic)
PlutusTx.makeIsDataIndexed 'ProposalTimingConfig [('ProposalTimingConfig, 0)]
@ -108,7 +119,7 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
, -- | @since 0.1.0
Ord
, -- | @since 0.1.0
GHC.Generic
Generic
)
deriving newtype
( -- | @since 0.1.0
@ -154,41 +165,41 @@ data PProposalTime (s :: S) = PProposalTime
}
deriving stock
( -- | @since 0.1.0
GHC.Generic
Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
HasDatatypeInfo
, -- | @since 0.1.0
PEq
)
instance DerivePlutusType PProposalTime where
type DPTStrat _ = PlutusTypeScott
-- | Plutarch-level version of 'ProposalStartingTime'.
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
deriving
deriving stock
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.1.0
POrd
)
via (DerivePNewtype PProposalStartingTime PPOSIXTime)
instance DerivePlutusType PProposalStartingTime where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalStartingTime where
type PLifted PProposalStartingTime = ProposalStartingTime
deriving via
PAsData (DerivePNewtype PProposalStartingTime PPOSIXTime)
instance
PTryFrom PData (PAsData PProposalStartingTime)
instance PTryFrom PData (PAsData PProposalStartingTime)
-- | @since 0.1.0
deriving via
@ -213,18 +224,10 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
)
}
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
@ -232,10 +235,12 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
, -- | @since 0.1.0
PDataFields
)
via (PIsDataReprInstances PProposalTimingConfig)
instance DerivePlutusType PProposalTimingConfig where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0
deriving via PAsData (PIsDataReprInstances PProposalTimingConfig) instance PTryFrom PData (PAsData PProposalTimingConfig)
instance PTryFrom PData PProposalTimingConfig
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalTimingConfig where
@ -250,20 +255,28 @@ deriving via
-- | Plutarch-level version of 'MaxTimeRangeWidth'.
newtype PMaxTimeRangeWidth (s :: S)
= PMaxTimeRangeWidth (Term s PPOSIXTime)
deriving
deriving stock
( -- | @since 0.2.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.2.0
PPartialOrd
, -- | @since 0.1.0
POrd
)
via (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime)
instance DerivePlutusType PMaxTimeRangeWidth where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0
deriving via PAsData (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime) instance PTryFrom PData (PAsData PMaxTimeRangeWidth)
instance PTryFrom PData (PAsData PMaxTimeRangeWidth)
-- | @since 0.1.0
instance PUnsafeLiftDecl PMaxTimeRangeWidth where type PLifted PMaxTimeRangeWidth = MaxTimeRangeWidth
@ -319,23 +332,33 @@ pisMaxTimeRangeWidthValid =
@since 0.1.0
-}
createProposalStartingTime :: forall (s :: S). Term s (PMaxTimeRangeWidth :--> PPOSIXTimeRange :--> PProposalStartingTime)
createProposalStartingTime ::
forall (s :: S).
Term
s
( PMaxTimeRangeWidth
:--> PPOSIXTimeRange
:--> PMaybe PProposalStartingTime
)
createProposalStartingTime = phoistAcyclic $
plam $ \(pto -> maxDuration) iv -> unTermCont $ do
currentTimeF <- pmatchC $ currentProposalTime # iv
plam $ \(pto -> maxDuration) iv ->
let ct = currentProposalTime # iv
-- Use the middle of the current time range as the starting time.
let duration = currentTimeF.upperBound - currentTimeF.lowerBound
f :: Term _ (PProposalTime :--> PMaybe PProposalStartingTime)
f = plam $
flip pmatch $ \(PProposalTime lb ub) ->
let duration = ub - lb
startingTime =
pdiv
# (currentTimeF.lowerBound + currentTimeF.upperBound)
# 2
pguardC "createProposalStartingTime: given time range should be tight enough" $
duration #<= maxDuration
pure $ pcon $ PProposalStartingTime startingTime
startingTime = pdiv # (lb + ub) # 2
in pif
(duration #<= maxDuration)
(pjust #$ pcon $ PProposalStartingTime startingTime)
( ptrace
"createProposalStartingTime: given time range should be tight enough"
pnothing
)
in -- TODO: PMonad when?
pmaybe # pnothing # f # ct
{- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
@ -344,33 +367,30 @@ createProposalStartingTime = phoistAcyclic $
@since 0.1.0
-}
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime)
currentProposalTime = phoistAcyclic $
plam $ \iv -> unTermCont $ do
PInterval iv' <- pmatchC iv
ivf <- pletAllC iv'
PLowerBound lb <- pmatchC ivf.from
PUpperBound ub <- pmatchC ivf.to
lbf <- pletAllC lb
ubf <- pletAllC ub
pure $
pcon $
PProposalTime
{ lowerBound =
pmatch
lbf._0
( \case
PFinite ((pfield @"_0" #) -> d) -> d
_ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
let getBound = phoistAcyclic $
plam $
flip pletAll $ \f ->
pif
f._1
( pmatch f._0 $ \case
PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d
_ -> ptrace "currentProposalTime: time range should be bounded" pnothing
)
, upperBound =
pmatch
ubf._0
( \case
PFinite ((pfield @"_0" #) -> d) -> d
_ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
)
}
(ptrace "currentProposalTime: time range should be inclusive" pnothing)
lowerBound = getBound # lb
upperBound = getBound # ub
mkTime = phoistAcyclic $ plam $ pcon .* PProposalTime
pure $ pliftA2 # mkTime # lowerBound # upperBound
{- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.

138
agora/Agora/Scripts.hs Normal file
View file

@ -0,0 +1,138 @@
{- | Module : Agora.Scripts
Maintainer : connor@mlabs.city
Description: Precompiled core scripts and utilities
Precompiled core scripts and utilities
-}
module Agora.Scripts (
AgoraScripts (..),
governorSTSymbol,
governorSTAssetClass,
governorValidatorHash,
proposalSTSymbol,
proposalSTAssetClass,
proposalValidatoHash,
stakeSTSymbol,
stakeSTAssetClass,
stakeValidatorHash,
authorityTokenSymbol,
treasuryValidatorHash,
) where
import Agora.Governor (GovernorDatum, GovernorRedeemer)
import Agora.Proposal (ProposalDatum, ProposalRedeemer)
import Agora.Stake (StakeDatum, StakeRedeemer)
import Agora.Treasury (TreasuryRedeemer)
import Agora.Utils (CompiledMintingPolicy (..), CompiledValidator (..), validatorHashToTokenName)
import Plutarch.Api.V1 (mintingPolicySymbol, validatorHash)
import PlutusLedgerApi.V1 (CurrencySymbol)
import PlutusLedgerApi.V1.Scripts (ValidatorHash)
import PlutusLedgerApi.V1.Value (AssetClass (..))
{- | Precompiled core scripts.
Including:
- Governor policy
- Governor validator
- Proposal policy
- Proposal validator
- Stake policy
- Stake validator
- Treasury validator
- Authority token policy
@since 0.2.0
-}
data AgoraScripts = AgoraScripts
{ compiledGovernorPolicy :: CompiledMintingPolicy ()
, compiledGovernorValidator :: CompiledValidator GovernorDatum GovernorRedeemer
, compiledStakePolicy :: CompiledMintingPolicy ()
, compiledStakeValidator :: CompiledValidator StakeDatum StakeRedeemer
, compiledProposalPolicy :: CompiledMintingPolicy ()
, compiledProposalValidator :: CompiledValidator ProposalDatum ProposalRedeemer
, compiledTreasuryValidator :: CompiledValidator () TreasuryRedeemer
, compiledAuthorityTokenPolicy :: CompiledMintingPolicy ()
}
{- | Get the currency symbol of the governor state token.
@since 0.2.0
-}
governorSTSymbol :: AgoraScripts -> CurrencySymbol
governorSTSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledGovernorPolicy
{- | Get the asset class of the governor state token.
@since 0.2.0
-}
governorSTAssetClass :: AgoraScripts -> AssetClass
governorSTAssetClass as = AssetClass (governorSTSymbol as, "")
{- | Get the script hash of the governor validator.
@since 0.2.0
-}
governorValidatorHash :: AgoraScripts -> ValidatorHash
governorValidatorHash = validatorHash . getCompiledValidator . compiledGovernorValidator
{- | Get the currency symbol of the propsoal state token.
@since 0.2.0
-}
proposalSTSymbol :: AgoraScripts -> CurrencySymbol
proposalSTSymbol as = mintingPolicySymbol $ getCompiledMintingPolicy as.compiledProposalPolicy
{- | Get the asset class of the governor state token.
@since 0.2.0
-}
proposalSTAssetClass :: AgoraScripts -> AssetClass
proposalSTAssetClass as = AssetClass (proposalSTSymbol as, "")
{- | Get the script hash of the proposal validator.
@since 0.2.0
-}
proposalValidatoHash :: AgoraScripts -> ValidatorHash
proposalValidatoHash = validatorHash . getCompiledValidator . compiledProposalValidator
{- | Get the script hash of the governor validator.
@since 0.2.0
-}
stakeSTSymbol :: AgoraScripts -> CurrencySymbol
stakeSTSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledStakePolicy
{- | Get the asset class of the stake state token.
Note that this token is tagged with the hash of the stake validator.
See 'Agora.Stake.Script.stakePolicy'.
@since 0.2.0
-}
stakeSTAssetClass :: AgoraScripts -> AssetClass
stakeSTAssetClass as =
let tn = validatorHashToTokenName $ stakeValidatorHash as
in AssetClass (stakeSTSymbol as, tn)
{- | Get the script hash of the stake validator.
@since 0.2.0
-}
stakeValidatorHash :: AgoraScripts -> ValidatorHash
stakeValidatorHash = validatorHash . getCompiledValidator . compiledStakeValidator
{- | Get the currency symbol of the authority token.
@since 0.2.0
-}
authorityTokenSymbol :: AgoraScripts -> CurrencySymbol
authorityTokenSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledAuthorityTokenPolicy
{- | Get the script hash of the treasury validator.
@since 0.2.0
-}
treasuryValidatorHash :: AgoraScripts -> ValidatorHash
treasuryValidatorHash = validatorHash . getCompiledValidator . compiledTreasuryValidator

129
agora/Agora/Stake.hs
View file

@ -11,7 +11,6 @@ module Agora.Stake (
-- * Haskell-land
StakeDatum (..),
StakeRedeemer (..),
Stake (..),
ProposalLock (..),
-- * Plutarch-land
@ -31,20 +30,16 @@ module Agora.Stake (
pisIrrelevant,
) where
import Agora.Plutarch.Orphans ()
import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..))
import Agora.SafeMoney (GTTag)
import Data.Tagged (Tagged (..))
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, HasDatatypeInfo, I (I))
import Generics.SOP qualified as SOP
import Plutarch.Api.V1 (
PMaybeData,
PPubKeyHash,
)
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
)
import Plutarch.Extra.Field (pletAll)
import Plutarch.Extra.IsData (
@ -52,33 +47,17 @@ import Plutarch.Extra.IsData (
ProductIsData (ProductIsData),
)
import Plutarch.Extra.List (pnotNull)
import Plutarch.Extra.Other (DerivePNewtype' (..))
import Plutarch.Extra.Sum (PSum (..))
import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import Plutarch.SafeMoney (PDiscrete)
import Plutarch.Show (PShow (..))
import PlutusLedgerApi.V1 (PubKeyHash)
import PlutusLedgerApi.V1.Value (AssetClass)
import PlutusTx qualified
import Prelude hiding (Num (..))
--------------------------------------------------------------------------------
{- | Parameters for creating Stake scripts.
@since 0.1.0
-}
data Stake = Stake
{ gtClassRef :: Tagged GTTag AssetClass
-- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
, proposalSTClass :: AssetClass
}
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
{- | Locks that are stored in the stake datums for various purposes.
NOTE: Due to retracting votes always being possible,
@ -133,10 +112,6 @@ data ProposalLock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
@ -176,7 +151,12 @@ data StakeRedeemer
DelegateTo PubKeyHash
| -- | Revoke the existing delegation.
ClearDelegate
deriving stock (Show, GHC.Generic)
deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Generic
)
PlutusTx.makeIsDataIndexed
''StakeRedeemer
@ -208,8 +188,16 @@ data StakeDatum = StakeDatum
-- ^ The current proposals locking this stake. This field must be empty
-- for the stake to be usable for deposits and withdrawals.
}
deriving stock (Show, GHC.Generic)
deriving anyclass (Generic)
deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
SOP.Generic
)
deriving
( -- | @since 0.1.0
PlutusTx.ToData
@ -231,34 +219,26 @@ newtype PStakeDatum (s :: S) = PStakeDatum
( PDataRecord
'[ "stakedAmount" ':= PDiscrete GTTag
, "owner" ':= PPubKeyHash
, "delegatedTo" ':= PMaybeData PPubKeyHash
, "delegatedTo" ':= PMaybeData (PAsData PPubKeyHash)
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
]
)
}
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0
PEq
)
via (DerivePNewtype' PStakeDatum)
instance DerivePlutusType PStakeDatum where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PStakeDatum where
@ -271,10 +251,7 @@ deriving via
(Plutarch.Lift.PConstantDecl StakeDatum)
-- | @since 0.1.0
deriving via
PAsData (DerivePNewtype' PStakeDatum)
instance
PTryFrom PData (PAsData PStakeDatum)
instance PTryFrom PData (PAsData PStakeDatum)
{- | Plutarch-level redeemer for Stake scripts.
@ -291,30 +268,23 @@ data PStakeRedeemer (s :: S)
| PDelegateTo (Term s (PDataRecord '["pkh" ':= PPubKeyHash]))
| PClearDelegate (Term s (PDataRecord '[]))
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
SOP.Generic
, -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via PIsDataReprInstances PStakeRedeemer
instance DerivePlutusType PStakeRedeemer where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PStakeRedeemer)
instance
PTryFrom PData (PAsData PStakeRedeemer)
instance PTryFrom PData PStakeRedeemer
-- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PStakeRedeemer where
@ -331,7 +301,13 @@ deriving via
@since 0.2.0
-}
data PProposalLock (s :: S)
= PCreated (Term s (PDataRecord '["created" ':= PProposalId]))
= PCreated
( Term
s
( PDataRecord
'["created" ':= PProposalId]
)
)
| PVoted
( Term
s
@ -342,20 +318,10 @@ data PProposalLock (s :: S)
)
)
deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
HasDatatypeInfo
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
@ -363,13 +329,15 @@ data PProposalLock (s :: S)
, -- | @since 0.1.0
PEq
)
via (PIsDataReprInstances PProposalLock)
instance DerivePlutusType PProposalLock where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0
deriving via
PAsData (PIsDataReprInstances PProposalLock)
instance
PTryFrom PData (PAsData PProposalLock)
instance PTryFrom PData PProposalLock
-- | @since 0.2.0
instance PTryFrom PData (PAsData PProposalLock)
-- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PProposalLock where
@ -399,9 +367,7 @@ instance PShow PProposalLock where
pstakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
pstakeLocked = phoistAcyclic $
plam $ \stakeDatum ->
let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
locks = pfield @"lockedBy" # stakeDatum
in pnotNull # locks
pnotNull #$ pfield @"lockedBy" @(PBuiltinList _) # pto stakeDatum
{- | Get the number of *alive* proposals that were created by the given stake.
@ -439,19 +405,18 @@ data PStakeRole (s :: S)
PIrrelevant
deriving stock
( -- | @since 0.2.0
GHC.Generic
Generic
)
deriving anyclass
( -- | @since 0.2.0
Generic
, -- | @since 0.2.0
PlutusType
, -- | @since 0.2.0
HasDatatypeInfo
, -- | @since 0.2.0
PEq
)
instance DerivePlutusType PStakeRole where
type DPTStrat _ = PlutusTypeScott
{- | Retutn true if the stake was used to voted on the proposal.
@since 0.2.0

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

@ -8,19 +8,15 @@ Plutus Scripts for Stakes.
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts, proposalSTAssetClass, stakeSTSymbol)
import Agora.Stake (
PStakeDatum (PStakeDatum),
PStakeRedeemer (..),
Stake (gtClassRef, proposalSTClass),
StakeRedeemer (WitnessStake),
pstakeLocked,
)
import Agora.Utils (
mustFindDatum',
pdjust,
pdnothing,
pmaybeData,
pvalidatorHashToTokenName,
)
import Data.Function (on)
import Data.Tagged (Tagged (..), untag)
@ -35,23 +31,21 @@ import Plutarch.Api.V1 (
PTxOut,
PValidator,
PValue,
mintingPolicySymbol,
mkMintingPolicy,
)
import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf, pvalueOf)
import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, ptxSignedBy, pvalueSpent)
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pgeqByClass', pgeqBySymbol, psymbolValueOf)
import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.List (pmapMaybe, pmsortBy)
import Plutarch.Extra.Maybe (passertPJust, pfromDJust)
import Plutarch.Extra.Maybe (passertPJust, pdjust, pdnothing, pfromDJust, pmaybeData)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
import Plutarch.Internal (punsafeCoerce)
import Plutarch.Numeric.Additive (AdditiveMonoid (zero), AdditiveSemigroup ((+)))
import Plutarch.SafeMoney (
pdiscreteValue',
pvalueDiscrete',
)
import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
import Prelude hiding (Num (..))
@ -106,7 +100,11 @@ stakePolicy gtClassRef =
pure $
pif
(psymbolValueOf # ownSymbol # txOutF.value #== 1)
( let datum = mustFindDatum' @PStakeDatum # txOutF.datumHash # txInfoF.datums
( let datum =
pfromData $
mustFindDatum' @(PAsData PStakeDatum)
# txOutF.datumHash
# txInfoF.datums
in pnot # (pstakeLocked # datum)
)
(pconstant False)
@ -137,7 +135,7 @@ stakePolicy gtClassRef =
PPubKeyCredential _ -> pcon PFalse
PScriptCredential ((pfield @"_0" #) -> validatorHash) ->
let tn :: Term _ PTokenName
tn = pvalidatorHashToTokenName validatorHash
tn = punsafeCoerce $ pfromData validatorHash
in pvalueOf # outputF.value # ownSymbol # tn #== 1
)
# pfromData txInfoF.outputs
@ -146,7 +144,9 @@ stakePolicy gtClassRef =
pletFieldsC @'["value", "address", "datumHash"] scriptOutputWithStakeST
datumF <-
pletFieldsC @'["owner", "stakedAmount"] $
mustFindDatum' @PStakeDatum # outputF.datumHash # txInfoF.datums
pto $
pfromData $
mustFindDatum' @(PAsData PStakeDatum) # outputF.datumHash # txInfoF.datums
let hasExpectedStake =
ptraceIfFalse "Stake ouput has expected amount of stake token" $
@ -217,8 +217,13 @@ stakePolicy gtClassRef =
@since 0.1.0
-}
stakeValidator :: Stake -> ClosedTerm PValidator
stakeValidator stake =
stakeValidator ::
-- | Lazy precompiled scripts.
AgoraScripts ->
-- | See 'Agora.Governor.Governor.gtClassRef'.
Tagged GTTag AssetClass ->
ClosedTerm PValidator
stakeValidator as gtClassRef =
plam $ \datum redeemer ctx' -> unTermCont $ do
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
txInfo <- pletC $ pfromData ctx.txInfo
@ -232,12 +237,10 @@ stakeValidator stake =
]
txInfo
(pfromData -> stakeRedeemer, _) <- ptryFromC redeemer
stakeRedeemer <- fst <$> ptryFromC redeemer
-- TODO: Use PTryFrom
let stakeDatum' :: Term _ PStakeDatum
stakeDatum' = pfromData $ punsafeCoerce datum
stakeDatum <- pletAllC stakeDatum'
stakeDatum' <- pfromData . fst <$> ptryFromC datum
stakeDatum <- pletAllC $ pto stakeDatum'
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
@ -252,17 +255,14 @@ stakeValidator stake =
signedBy <- pletC $ ptxSignedBy # txInfoF.signatories
ownerSignsTransaction <- pletC $ signedBy # stakeDatum.owner
delegateSignsTransaction <-
pletC $
pmaybeData # pconstant False
# plam ((signedBy #) . pdata)
# signedBy
# stakeDatum.delegatedTo
stCurrencySymbol <-
pletC $
pconstant $
mintingPolicySymbol $
mkMintingPolicy (stakePolicy stake.gtClassRef)
stCurrencySymbol <- pletC $ pconstant $ stakeSTSymbol as
mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
valueSpent <- pletC $ pvalueSpent # txInfoF.inputs
spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent
@ -288,7 +288,7 @@ stakeValidator stake =
-- Handle redeemers that require own stake output.
_ -> unTermCont $ do
let AssetClass (propCs, propTn) = stake.proposalSTClass
let AssetClass (propCs, propTn) = proposalSTAssetClass as
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
spentProposalST = passetClassValueOf # valueSpent # proposalSTClass
@ -340,10 +340,10 @@ stakeValidator stake =
)
# pfromData txInfoF.inputs
sortTxOuts :: Term _ (PBuiltinList (PAsData PTxOut) :--> PBuiltinList (PAsData PTxOut))
sortTxOuts :: Term _ (PBuiltinList PTxOut :--> PBuiltinList PTxOut)
sortTxOuts = phoistAcyclic $ plam (pmsortBy # plam ((#<) `on` (getDatumHash #)) #)
where
getDatumHash :: Term _ (PAsData PTxOut :--> PDatumHash)
getDatumHash :: Term _ (PTxOut :--> PDatumHash)
getDatumHash = phoistAcyclic $ plam ((pfromDJust #) . pfromData . (pfield @"datumHash" #))
sortedOwnInputs = sortTxOuts # ownInputs
@ -360,11 +360,12 @@ stakeValidator stake =
pguardC "ST at inputs must be 1" $
spentST #== 1
ownOutput <- pletC $ pfromData $ phead # ownOutputs
ownOutput <- pletC $ phead # ownOutputs
stakeOut <-
pletC $
mustFindDatum' @PStakeDatum
pfromData $
mustFindDatum' @(PAsData PStakeDatum)
# (pfield @"datumHash" # ownOutput)
# txInfoF.datums
@ -384,7 +385,7 @@ stakeValidator stake =
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= pfield @"lockedBy" # stakeOut
.& #lockedBy .= pfield @"lockedBy" # pto stakeOut
)
in stakeOut #== templateStakeDatum
@ -489,7 +490,7 @@ stakeValidator stake =
datumCorrect = stakeOut #== expectedDatum
let valueDelta :: Term _ (PValue _ 'Positive)
valueDelta = pdiscreteValue' stake.gtClassRef # delta
valueDelta = pdiscreteValue' gtClassRef # delta
expectedValue =
resolvedF.value <> valueDelta
@ -500,7 +501,7 @@ stakeValidator stake =
[ pgeqByClass' (AssetClass ("", ""))
# ownOutputValue
# expectedValue
, pgeqByClass' (untag stake.gtClassRef)
, pgeqByClass' (untag gtClassRef)
# ownOutputValue
# expectedValue
, pgeqBySymbol
@ -524,7 +525,7 @@ stakeValidator stake =
pguardC "Cannot delegate to the owner" $
pnot #$ stakeDatum.owner #== pkh
pure $ setDelegate #$ pdjust # pkh
pure $ setDelegate #$ pdjust # pdata pkh
------------------------------------------------------------
PClearDelegate _ ->

32
agora/Agora/Treasury.hs
View file

@ -11,14 +11,16 @@ treasury.
module Agora.Treasury (module Agora.Treasury) where
import Agora.AuthorityToken (singleAuthorityTokenBurned)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic)
import Generics.SOP qualified as SOP
import Plutarch.Api.V1 (PValidator)
import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
import "plutarch" Plutarch.Api.V1.Value (PValue)
import Plutarch.Builtin (pforgetData)
import Plutarch.Extra.IsData (DerivePConstantViaEnum (..), EnumIsData (..))
import Plutarch.Extra.Other (DerivePNewtype' (..))
import Plutarch.Extra.IsData (
DerivePConstantViaEnum (..),
EnumIsData (..),
PlutusTypeEnumData,
)
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
import Plutarch.TryFrom ()
@ -38,7 +40,7 @@ data TreasuryRedeemer
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
Generic
, -- | @since 0.2.0
Enum
, -- | @since 0.2.0
@ -46,7 +48,7 @@ data TreasuryRedeemer
)
deriving anyclass
( -- | @since 0.2.0
Generic
SOP.Generic
)
deriving
( -- | @since 0.1.0
@ -63,23 +65,25 @@ data TreasuryRedeemer
@since 0.1.0
-}
newtype PTreasuryRedeemer (s :: S)
= PTreasuryRedeemer (Term s PInteger)
data PTreasuryRedeemer (s :: S)
= PSpendTreasuryGAT
deriving stock
( -- | @since 0.1.0
GHC.Generic
Generic
, -- | @since 0.2.0
Bounded
, -- | @since 0.2.0
Enum
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via (DerivePNewtype' PTreasuryRedeemer)
instance DerivePlutusType PTreasuryRedeemer where
type DPTStrat _ = PlutusTypeEnumData
-- | @since 0.1.0
instance PUnsafeLiftDecl PTreasuryRedeemer where

215
agora/Agora/Utils.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE QuantifiedConstraints #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{- |
Module : Agora.Utils
@ -8,56 +9,32 @@ Description: Plutarch utility functions that should be upstreamed or don't belon
Plutarch utility functions that should be upstreamed or don't belong anywhere else.
-}
module Agora.Utils (
scriptHashFromAddress,
findOutputsToAddress,
findTxOutDatum,
validatorHashToTokenName,
pvalidatorHashToTokenName,
getMintingPolicySymbol,
hasOnlyOneTokenOfCurrencySymbol,
mustFindDatum',
mustBePJust,
mustBePDJust,
validatorHashToAddress,
isScriptAddress,
isPubKey,
pltAsData,
pon,
withBuiltinPairAsData,
pmaybeData,
pmaybe,
pdjust,
pdnothing,
CompiledValidator (..),
CompiledMintingPolicy (..),
CompiledEffect (..),
) where
import Plutarch.Api.V1 (
AmountGuarantees,
KeyGuarantees,
PAddress,
PCredential (PScriptCredential),
PCurrencySymbol,
PDatum,
PDatumHash,
PMaybeData (PDJust, PDNothing),
PMintingPolicy,
PTokenName (PTokenName),
PMaybeData,
PTuple,
PTxOut,
PValidatorHash,
PValue,
mintingPolicySymbol,
mkMintingPolicy,
)
import Plutarch.Api.V1.ScriptContext (pfindDatum)
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (psymbolValueOf)
import Plutarch.Builtin (pforgetData)
import Plutarch.Extra.List (plookupTuple)
import Plutarch.Extra.TermCont (pletC, pmatchC, ptryFromC)
import Plutarch.Extra.Maybe (passertPDJust, passertPJust)
import Plutarch.Extra.TermCont (ptryFromC)
import PlutusLedgerApi.V1 (
Address (..),
Credential (..),
CurrencySymbol,
MintingPolicy,
TokenName (..),
Validator,
ValidatorHash (..),
)
@ -65,60 +42,6 @@ import PlutusLedgerApi.V1 (
All of these functions are quite inefficient.
-}
{- | Get script hash from an Address.
@since 0.1.0
-}
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
{- | Return true if the given address is a script address.
@since 0.1.0
-}
isScriptAddress :: Term s (PAddress :--> PBool)
isScriptAddress = phoistAcyclic $
plam $ \addr -> pnot #$ isPubKey #$ pfromData $ pfield @"credential" # addr
{- | Return true if the given credential is a pub-key-hash.
@since 0.1.0
-}
isPubKey :: Term s (PCredential :--> PBool)
isPubKey = phoistAcyclic $
plam $ \cred ->
pmatch cred $ \case
PScriptCredential _ -> pconstant False
_ -> pconstant True
{- | Find all TxOuts sent to an Address
@since 0.1.0
-}
findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut))
findOutputsToAddress = phoistAcyclic $
plam $ \outputs address' -> unTermCont $ do
address <- pletC $ pdata address'
pure $
pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address)
# outputs
{- | Find the data corresponding to a TxOut, if there is one
@since 0.1.0
-}
findTxOutDatum :: Term s (PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PTxOut :--> PMaybe PDatum)
findTxOutDatum = phoistAcyclic $
plam $ \datums out -> unTermCont $ do
datumHash' <- pmatchC $ pfromData $ pfield @"datumHash" # out
pure $ 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.
@ -127,39 +50,13 @@ findTxOutDatum = phoistAcyclic $
validatorHashToTokenName :: ValidatorHash -> TokenName
validatorHashToTokenName (ValidatorHash hash) = TokenName hash
{- | Plutarch level 'validatorHashToTokenName'.
@since 0.1.0
-}
pvalidatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName
pvalidatorHashToTokenName vh = pcon (PTokenName (pto vh))
{- | Get the CurrencySymbol of a PMintingPolicy.
@since 0.1.0
-}
getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v
{- | The entire value only contains one token of the given currency symbol.
@since 0.1.0
-}
hasOnlyOneTokenOfCurrencySymbol ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s (PCurrencySymbol :--> PValue keys amounts :--> PBool)
hasOnlyOneTokenOfCurrencySymbol = phoistAcyclic $
plam $ \cs vs -> P.do
psymbolValueOf # cs # vs #== 1
#&& (plength #$ pto $ pto $ pto vs) #== 1
{- | Find datum given a maybe datum hash
@since 0.1.0
-}
mustFindDatum' ::
forall (datum :: PType).
(PIsData datum, PTryFrom PData (PAsData datum)) =>
(PIsData datum, PTryFrom PData datum) =>
forall s.
Term
s
@ -169,32 +66,10 @@ mustFindDatum' ::
)
mustFindDatum' = phoistAcyclic $
plam $ \mdh datums -> unTermCont $ do
let dh = mustBePDJust # "Given TxOut dones't have a datum" # mdh
dt = mustBePJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums
let dh = passertPDJust # "Given TxOut dones't have a datum" # mdh
dt = passertPJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums
(d, _) <- ptryFromC $ pforgetData $ pdata dt
pure $ pfromData d
{- | Extract the value stored in a PMaybe container.
If there's no value, throw an error with the given message.
@since 0.1.0
-}
mustBePJust :: forall a s. Term s (PString :--> PMaybe a :--> a)
mustBePJust = phoistAcyclic $
plam $ \emsg mv' -> pmatch mv' $ \case
PJust v -> v
_ -> ptraceError emsg
{- | Extract the value stored in a PMaybeData container.
If there's no value, throw an error with the given message.
@since 0.1.0
-}
mustBePDJust :: forall a s. (PIsData a) => Term s (PString :--> PMaybeData a :--> a)
mustBePDJust = phoistAcyclic $
plam $ \emsg mv' -> pmatch mv' $ \case
PDJust ((pfield @"_0" #) -> v) -> v
_ -> ptraceError emsg
pure d
{- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
@ -215,19 +90,6 @@ pltAsData = phoistAcyclic $
plam $
\(pfromData -> l) (pfromData -> r) -> l #< r
{- | Plutarch level 'Data.Function.on'.
@since 0.2.0
-}
pon ::
forall (a :: PType) (b :: PType) (c :: PType) (s :: S).
Term s ((b :--> b :--> c) :--> (a :--> b) :--> a :--> a :--> c)
pon = phoistAcyclic $
plam $ \f g x y ->
let a = g # x
b = g # y
in f # a # b
{- | Extract data stored in a 'PBuiltinPair' and call a function to process it.
@since 0.2.0
@ -245,53 +107,26 @@ withBuiltinPairAsData f p =
b = pfromData $ psndBuiltin # p
in f a b
{- | Plutarch version of 'Data.Maybe.maybe'. Take a default value and a function
@f@. If the given 'PMaybe' value is @'PJust' x@, apply the function @f@ to
@x@, otherewise the default value will be retuned.
{- | Type-safe wrapper for compiled plutus validator.
@since 0.2.0
-}
pmaybe ::
forall (a :: PType) (b :: PType) (s :: S).
Term s (b :--> (a :--> b) :--> PMaybe a :--> b)
pmaybe = phoistAcyclic $
plam $ \n f m -> pmatch m $ \case
PJust x -> f # x
_ -> n
newtype CompiledValidator (datum :: Type) (redeemer :: Type) = CompiledValidator
{ getCompiledValidator :: Validator
}
{- | Special version of 'pmaybe' that works with 'PMaybedata'.
{- | Type-safe wrapper for compiled plutus miting policy.
@since 0.2.0
-}
pmaybeData ::
forall (a :: PType) (b :: PType) (s :: S).
PIsData a =>
Term s (b :--> (a :--> b) :--> PMaybeData a :--> b)
pmaybeData = phoistAcyclic $
plam $ \n f m -> pmatch m $ \case
PDJust ((pfield @"_0" #) -> x) -> f # x
_ -> n
newtype CompiledMintingPolicy (redeemer :: Type) = CompiledMintingPolicy
{ getCompiledMintingPolicy :: MintingPolicy
}
{- Construct a 'PDJust' value.
{- | Type-safe wrapper for compiled plutus effect.
@since 0.2.0
-}
pdjust ::
forall (a :: PType) (s :: S).
(PIsData a) =>
Term s (a :--> PMaybeData a)
pdjust = phoistAcyclic $
plam $ \x ->
pcon $
PDJust $
pdcons @"_0" # pdata x #$ pdnil
{- Construct a 'PDNothing' value.
@since 0.2.0
-}
pdnothing ::
forall (a :: PType) (s :: S).
(PIsData a) =>
Term s (PMaybeData a)
pdnothing = phoistAcyclic $ pcon $ PDNothing pdnil
newtype CompiledEffect (datum :: Type) = CompiledEffect
{ getCompiledEffect :: Validator
}

1162
bench.csv
View file

File diff suppressed because it is too large Load diff

3
cabal.project
View file

@ -3,7 +3,4 @@ packages: ./.
benchmarks: true
tests: true
package plutarch
flags: +development
test-show-details: direct

6893
flake.lock generated
View file

File diff suppressed because it is too large Load diff

326
flake.nix
View file

@ -1,263 +1,109 @@
{
description = "agora";
inputs.nixpkgs.follows = "plutarch/nixpkgs";
inputs.haskell-nix.follows = "plutarch/haskell-nix";
inputs.nixpkgs-latest.url = "github:NixOS/nixpkgs?rev=a0a69be4b5ee63f1b5e75887a406e9194012b492";
inputs = {
nixpkgs.follows = "plutarch/nixpkgs";
nixpkgs-latest.url = "github:NixOS/nixpkgs?rev=cf63df0364f67848083ff75bc8ac9b7ca7aa5a01";
# temporary fix for nix versions that have the transitive follows bug
# see https://github.com/NixOS/nix/issues/6013
inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };
nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };
haskell-nix-extra-hackage.follows = "plutarch/haskell-nix-extra-hackage";
haskell-nix.follows = "plutarch/haskell-nix";
iohk-nix.follows = "plutarch/iohk-nix";
haskell-language-server.follows = "plutarch/haskell-language-server";
# Plutarch and its friends
inputs.plutarch.url =
"github:liqwid-labs/plutarch?rev=e7ef565645146e26e75ec29fe97122a74e52c6b7";
inputs.plutarch.inputs.emanote.follows =
"plutarch/haskell-nix/nixpkgs-unstable";
inputs.plutarch.inputs.nixpkgs.follows =
"plutarch/haskell-nix/nixpkgs-unstable";
plutarch = {
url = "github:Plutonomicon/plutarch-plutus?ref=staging";
inputs.liqwid-plutarch-extra.url =
"github:Liqwid-Labs/liqwid-plutarch-extra?ref=seungheonoh/agoraUtils";
inputs.plutarch-numeric.url =
inputs.emanote.follows =
"plutarch/haskell-nix/nixpkgs-unstable";
inputs.nixpkgs.follows =
"plutarch/haskell-nix/nixpkgs-unstable";
};
plutarch-numeric.url =
"github:Liqwid-Labs/plutarch-numeric?ref=main";
inputs.plutarch-safe-money.url =
"github:Liqwid-Labs/plutarch-safe-money?rev=9f968b80189c7e4b335527cd5b103dc26952f667";
inputs.plutarch-script-export.url =
plutarch-safe-money.url =
"github:Liqwid-Labs/plutarch-safe-money?ref=main";
liqwid-plutarch-extra.url =
"github:Liqwid-Labs/liqwid-plutarch-extra?ref=plutus-v1";
plutarch-quickcheck.url =
"github:liqwid-labs/plutarch-quickcheck?ref=staging";
plutarch-context-builder.url =
"github:Liqwid-Labs/plutarch-context-builder?ref=plutus-v1";
plutarch-script-export.url =
"github:Liqwid-Labs/plutarch-script-export?ref=main";
# Testing
inputs.plutarch-quickcheck.url =
"github:liqwid-labs/plutarch-quickcheck?ref=staging";
liqwid-nix.url = "github:Liqwid-Labs/liqwid-nix?ref=main";
};
# PCB Rev is locked until Agora test have explicit Minting CS. Check PCB PR #12
inputs.plutarch-context-builder.url =
"github:Liqwid-Labs/plutarch-context-builder?ref=2a2ca72ff310788e531cbbe379ef7b0c4cb42dc9";
outputs = inputs@{ self, nixpkgs, nixpkgs-latest, haskell-nix, plutarch, ... }:
outputs = inputs@{ liqwid-nix, ... }:
let
supportedSystems = nixpkgs-latest.lib.systems.flakeExposed;
perSystem = nixpkgs.lib.genAttrs supportedSystems;
pkgsFor = system: import nixpkgs {
inherit system;
overlays = [ haskell-nix.overlay (import "${plutarch.inputs.iohk-nix}/overlays/crypto") ];
# This only does bad things for us...
# inherit (haskell-nix) config;
benchCheckOverlay = self: super: {
toFlake =
let
inherit (self) inputs perSystem pkgsFor';
flake = super.toFlake or { };
name = "benchCheck";
in
flake // {
checks = perSystem (system:
flake.checks.${system} // {
${name} =
let
pkgs' = pkgsFor' system;
bench = flake.packages.${system}."agora:bench:agora-bench";
in
pkgs'.runCommand name
{
nativeBuildInputs = [ pkgs'.diffutils ];
} ''
export LC_CTYPE=C.UTF-8
export LC_ALL=C.UTF-8
export LANG=C.UTF-8
cd ${inputs.self}
${bench}/bin/agora-bench | diff bench.csv - \
|| (echo "bench.csv is outdated"; exit 1)
mkdir "$out"
'';
});
};
pkgsFor' = system: import nixpkgs-latest { inherit system; };
fourmoluFor = system: (pkgsFor' system).haskell.packages.ghc922.fourmolu_0_6_0_0;
defaultGhcVersion = "ghc923";
nonReinstallablePkgs = [
"array"
"array"
"base"
"binary"
"bytestring"
"Cabal"
"containers"
"deepseq"
"directory"
"exceptions"
"filepath"
"ghc"
"ghc-bignum"
"ghc-boot"
"ghc-boot"
"ghc-boot-th"
"ghc-compact"
"ghc-heap"
# "ghci"
# "haskeline"
"ghcjs-prim"
"ghcjs-th"
"ghc-prim"
"ghc-prim"
"hpc"
"integer-gmp"
"integer-simple"
"mtl"
"parsec"
"pretty"
"process"
"rts"
"stm"
"template-haskell"
"terminfo"
"text"
"time"
"transformers"
"unix"
"Win32"
"xhtml"
];
haskellModules = [
({ config, pkgs, hsPkgs, ... }: {
inherit nonReinstallablePkgs; # Needed for a lot of different things
packages = {
cardano-binary.doHaddock = false;
cardano-binary.ghcOptions = [ "-Wwarn" ];
cardano-crypto-class.components.library.pkgconfig = pkgs.lib.mkForce [ [ pkgs.libsodium-vrf ] ];
cardano-crypto-class.doHaddock = false;
cardano-crypto-class.ghcOptions = [ "-Wwarn" ];
cardano-crypto-praos.components.library.pkgconfig = pkgs.lib.mkForce [ [ pkgs.libsodium-vrf ] ];
cardano-prelude.doHaddock = false; # somehow above options are not applied?
cardano-prelude.ghcOptions = [ "-Wwarn" ];
# Workaround missing support for build-tools:
# https://github.com/input-output-hk/haskell.nix/issues/231
plutarch-test.components.exes.plutarch-test.build-tools = [
config.hsPkgs.hspec-discover
];
};
})
];
myhackage = system: compiler-nix-name: plutarch.inputs.haskell-nix-extra-hackage.mkHackageFor system compiler-nix-name (
in
(liqwid-nix.buildProject
{
inherit inputs;
src = ./.;
}
[
"${inputs.plutarch.inputs.flat}"
"${inputs.plutarch.inputs.protolude}"
"${inputs.plutarch.inputs.cardano-prelude}/cardano-prelude"
"${inputs.plutarch.inputs.cardano-crypto}"
"${inputs.plutarch.inputs.cardano-base}/binary"
"${inputs.plutarch.inputs.cardano-base}/cardano-crypto-class"
"${inputs.plutarch.inputs.plutus}/plutus-core"
"${inputs.plutarch.inputs.plutus}/plutus-ledger-api"
"${inputs.plutarch.inputs.plutus}/plutus-tx"
"${inputs.plutarch.inputs.plutus}/prettyprinter-configurable"
"${inputs.plutarch.inputs.plutus}/word-array"
"${inputs.plutarch.inputs.secp256k1-haskell}"
"${inputs.plutarch.inputs.plutus}/plutus-tx-plugin" # necessary for FFI tests
# Custom deps as a consumer
"${inputs.plutarch}"
"${inputs.plutarch}/plutarch-extra"
"${inputs.liqwid-plutarch-extra}"
liqwid-nix.haskellProject
liqwid-nix.plutarchProject
(liqwid-nix.addDependencies [
"${inputs.plutarch-numeric}"
"${inputs.plutarch-safe-money}"
"${inputs.plutarch-quickcheck}"
"${inputs.plutarch-context-builder}"
"${inputs.liqwid-plutarch-extra}"
"${inputs.plutarch-script-export}"
])
(liqwid-nix.enableFormatCheck [
"-XQuasiQuotes"
"-XTemplateHaskell"
"-XTypeApplications"
"-XImportQualifiedPost"
"-XPatternSynonyms"
"-XOverloadedRecordDot"
])
liqwid-nix.enableLintCheck
liqwid-nix.enableCabalFormatCheck
liqwid-nix.enableNixFormatCheck
liqwid-nix.addBuildChecks
(liqwid-nix.addCommandLineTools (pkgs: _: [
pkgs.haskellPackages.hasktags
]))
benchCheckOverlay
]
);
applyDep = pkgs: o:
let
h = myhackage pkgs.system o.compiler-nix-name;
o' = (plutarch.applyPlutarchDep pkgs o);
in
o' // rec {
modules = haskellModules ++ [ h.module ] ++ (o'.modules or [ ]);
extra-hackages = [ (import h.hackageNix) ] ++ (o'.extra-hackages or [ ]);
extra-hackage-tarballs = { _xNJUd_plutarch-hackage = h.hackageTarball; };
cabalProjectLocal = (o'.cabalProjectLocal or "") + " , cache >= 0.1.3.0 ";
};
projectForGhc = compiler-nix-name: system:
let pkgs = pkgsFor system; in
let pkgs' = pkgsFor' system; in
let pkgSet = pkgs.haskell-nix.cabalProject' (applyDep pkgs {
src = ./.;
inherit compiler-nix-name;
modules = [ ];
shell = {
withHoogle = true;
exactDeps = true;
# We use the ones from Nixpkgs, since they are cached reliably.
# Eventually we will probably want to build these with haskell.nix.
nativeBuildInputs = [
pkgs'.cabal-install
pkgs'.hlint
pkgs'.haskellPackages.cabal-fmt
(fourmoluFor system)
pkgs'.nixpkgs-fmt
(plutarch.hlsFor compiler-nix-name system)
];
};
}); in
pkgSet;
projectFor = projectForGhc defaultGhcVersion;
formatCheckFor = system:
let
pkgs' = pkgsFor' system;
in
pkgs'.runCommand "format-check"
{
nativeBuildInputs = [ pkgs'.haskellPackages.cabal-fmt pkgs'.nixpkgs-fmt (fourmoluFor system) pkgs'.hlint ];
} ''
export LC_CTYPE=C.UTF-8
export LC_ALL=C.UTF-8
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
''
;
benchCheckFor = system: agora-bench:
let
pkgs = pkgsFor system;
pkgs' = pkgsFor' system;
in
pkgs.runCommand "bench-check"
{
bench = "${agora-bench}/bin/agora-bench";
nativeBuildInputs = [
pkgs'.diffutils
];
} ''
export LC_CTYPE=C.UTF-8
export LC_ALL=C.UTF-8
export LANG=C.UTF-8
cd ${self}
make bench_check || (echo " Please run 'make bench'" ; exit 1)
mkdir $out
'';
in
{
project = perSystem projectFor;
flake = perSystem (system: (projectFor system).flake { });
packages = perSystem (system:
self.flake.${system}.packages // {
haddock =
let
agora-doc = self.flake.${system}.packages."agora:lib:agora".doc;
pkgs = pkgsFor 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:
self.flake.${system}.checks // {
formatCheck = formatCheckFor system;
# benchCheck = benchCheckFor system self.flake.${system}.packages."agora:bench:agora-bench";
agora = self.flake.${system}.packages."agora:lib:agora";
agora-test = self.flake.${system}.packages."agora:test:agora-test";
benchCheck = benchCheckFor system self.flake.${system}.packages."agora:bench:agora-bench";
});
check = perSystem (system:
(pkgsFor system).runCommand "combined-test"
{
checksss = builtins.attrValues self.checks.${system};
} ''
echo $checksss
touch $out
'');
devShell = perSystem (system: self.flake.${system}.devShell);
};
).toFlake;
}