diff --git a/agora-purescript-bridge/AgoraTypes.hs b/agora-purescript-bridge/AgoraTypes.hs index 253f5de..21a41d9 100644 --- a/agora-purescript-bridge/AgoraTypes.hs +++ b/agora-purescript-bridge/AgoraTypes.hs @@ -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 diff --git a/agora-scripts/Main.hs b/agora-scripts/Main.hs index 5191b85..64ee8c3 100644 --- a/agora-scripts/Main.hs +++ b/agora-scripts/Main.hs @@ -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,44 +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 def $ - governorPolicy governor - ) - "" - - proposal :: Proposal - proposal = proposalFromGovernor governor - - stake :: Stake - stake = stakeFromGovernor governor + scripts = Bootstrap.agoraScripts plutarchConfig governor {- | Params required for creating script export. @@ -162,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 diff --git a/agora.cabal b/agora.cabal index 5fb6e63..b2c18f1 100644 --- a/agora.cabal +++ b/agora.cabal @@ -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 diff --git a/agora/Agora/Bootstrap.hs b/agora/Agora/Bootstrap.hs new file mode 100644 index 0000000..17d97d3 --- /dev/null +++ b/agora/Agora/Bootstrap.hs @@ -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 + } diff --git a/agora/Agora/Effect.hs b/agora/Agora/Effect.hs index 84557cd..96a7b32 100644 --- a/agora/Agora/Effect.hs +++ b/agora/Agora/Effect.hs @@ -23,7 +23,7 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol) -} makeEffect :: forall (datum :: PType). - (PTryFrom PData 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 diff --git a/agora/Agora/Effect/GovernorMutation.hs b/agora/Agora/Effect/GovernorMutation.hs index 8e3383a..ce26a40 100644 --- a/agora/Agora/Effect/GovernorMutation.hs +++ b/agora/Agora/Effect/GovernorMutation.hs @@ -20,16 +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 Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTAssetClass) import Generics.SOP qualified as SOP import Plutarch.Api.V1 ( PTxOutRef, @@ -149,8 +145,11 @@ deriving anyclass instance PTryFrom PData PMutateGovernorDatum @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 @@ -223,4 +222,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 diff --git a/agora/Agora/Governor/Scripts.hs b/agora/Agora/Governor/Scripts.hs index db65911..683815e 100644 --- a/agora/Agora/Governor/Scripts.hs +++ b/agora/Agora/Governor/Scripts.hs @@ -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,27 +35,17 @@ 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 Data.Default (def) import Plutarch.Api.V1 ( PAddress, PCurrencySymbol, @@ -85,10 +56,6 @@ import Plutarch.Api.V1 ( PTxOut, PValidator, PValidatorHash, - mintingPolicySymbol, - mkMintingPolicy, - mkValidator, - validatorHash, ) import Plutarch.Api.V1.AssetClass ( passetClass, @@ -110,17 +77,10 @@ import Plutarch.Extra.Map ( plookup, plookup', ) -import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pisDJust) +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) -------------------------------------------------------------------------------- @@ -151,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 "" @@ -273,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' @@ -404,7 +367,7 @@ governorValidator gov = proposalOutputDatum <- pletAllC $ pto $ pfromData proposalOutputDatum' let expectedStartingTime = - createProposalStartingTime + pfromJust #$ createProposalStartingTime # oldGovernorDatumF.createProposalTimeRangeMaxWidth # txInfoF.validRange @@ -604,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 def $ 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 def $ 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 def $ 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 def $ 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 def $ proposalValidator params - -{- | Get the hash of 'Agora.Proposal.proposalValidator'. - - @since 0.1.0 --} -governorValidatorHash :: Governor -> ValidatorHash -governorValidatorHash gov = validatorHash validator - where - validator = mkValidator def $ 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 def $ authorityTokenPolicy params - params = authorityTokenFromGovernor gov + pgstSymbol = pconstant $ governorSTSymbol as diff --git a/agora/Agora/Plutarch/Orphans.hs b/agora/Agora/Plutarch/Orphans.hs index a1ccae3..57778e6 100644 --- a/agora/Agora/Plutarch/Orphans.hs +++ b/agora/Agora/Plutarch/Orphans.hs @@ -1,15 +1,39 @@ {-# OPTIONS_GHC -Wno-orphans #-} +{- FIXME: All of the following instances and + types ought to belong in either plutarch or + plutarch-extra. +-} + module Agora.Plutarch.Orphans () where -import Plutarch.Api.V1 (PDatumHash) +import Plutarch.Api.V1 (PDatumHash (..)) import Plutarch.Builtin (PIsData (..)) +import Plutarch.Extra.TermCont (ptryFromC) +import Plutarch.TryFrom (PTryFrom (..)) +import Plutarch.Unsafe (punsafeCoerce) --- TODO: add checks -instance PTryFrom PData (PAsData PDatumHash) +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 + (pfromData -> unwrapped, _) <- ptryFromC @(PAsData PByteString) opq + + tcont $ \f -> + pif + -- Blake2b_256 hash: 256 bits/32 bytes. + (plengthBS # unwrapped #== 32) + (f ()) + (ptraceError "ptryFrom(PDatumHash): must be 32 bytes long") + + pure (punsafeCoerce opq, pcon $ PDatumHash unwrapped) + +-- | @since 0.2.0 instance PTryFrom PData (PAsData PUnit) +-- | @since 0.2.0 instance (PIsData a) => PIsData (PAsData a) where - pfromDataImpl = pfromData + pfromDataImpl = punsafeCoerce pdataImpl = pdataImpl . pfromData diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 917d581..eee62f8 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -9,7 +9,8 @@ Proposal scripts encoding effects that operate on the system. -} module Agora.Proposal ( -- * Haskell-land - Proposal (..), + + -- Proposal (..), ProposalDatum (..), ProposalRedeemer (..), ProposalStatus (..), @@ -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 @@ -398,29 +398,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 - Generic - ) - deriving anyclass - ( -- | @since 0.2.0 - SOP.Generic - ) - -------------------------------------------------------------------------------- -- Plutarch-land diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 7e897e5..1da4178 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -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' @@ -185,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 @@ -239,20 +242,6 @@ proposalValidator proposal = onlyStatusChanged <- pletC $ - -- Only the status of proposals is updated. - - -- Only the status of proposals is updated. - - -- Only the status of proposals is updated. - - -- Only the status of proposals is updated. - - -- Only the status of proposals is updated. - - -- Only the status of proposals is updated. - - -- Only the status of proposals is updated. - -- Only the status of proposals is updated. proposalOut #== mkRecordConstr @@ -271,7 +260,7 @@ 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 @@ -421,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 @@ -456,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). @@ -610,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 @@ -636,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 @@ -659,10 +650,7 @@ 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 $ diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index c6da780..f50c3a3 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -30,6 +30,7 @@ module Agora.Proposal.Time ( pisMaxTimeRangeWidthValid, ) where +import Control.Composition ((.*)) import Generics.SOP qualified as SOP import Plutarch.Api.V1 ( PExtended (PFinite), @@ -43,14 +44,16 @@ import Plutarch.DataRepr ( DerivePConstantViaData (..), PDataFields, ) -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 PlutusLedgerApi.V1.Time (POSIXTime) +import PlutusLedgerApi.V1 (POSIXTime) import PlutusTx qualified import Prelude @@ -344,23 +347,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. @@ -369,33 +382,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. diff --git a/agora/Agora/Scripts.hs b/agora/Agora/Scripts.hs new file mode 100644 index 0000000..9a76167 --- /dev/null +++ b/agora/Agora/Scripts.hs @@ -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 diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 70a5f2c..094fc54 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -11,7 +11,6 @@ module Agora.Stake ( -- * Haskell-land StakeDatum (..), StakeRedeemer (..), - Stake (..), ProposalLock (..), -- * Plutarch-land @@ -54,26 +53,11 @@ 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 - Generic - ) - {- | Locks that are stored in the stake datums for various purposes. NOTE: Due to retracting votes always being possible, diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index cc40a7d..1dc9a19 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -8,20 +8,17 @@ 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, pvalidatorHashToTokenName, ) -import Data.Default (def) import Data.Function (on) import Data.Tagged (Tagged (..), untag) import Plutarch.Api.V1 ( @@ -35,18 +32,15 @@ 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', @@ -223,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 @@ -240,9 +239,7 @@ stakeValidator stake = stakeRedeemer <- fst <$> ptryFromC redeemer - -- TODO: Use PTryFrom - let stakeDatum' :: Term _ PStakeDatum - stakeDatum' = pfromData $ punsafeCoerce datum + stakeDatum' <- pfromData . fst <$> ptryFromC datum stakeDatum <- pletAllC $ pto stakeDatum' PSpending txOutRef <- pmatchC $ pfromData ctx.purpose @@ -258,17 +255,14 @@ stakeValidator stake = signedBy <- pletC $ ptxSignedBy # txInfoF.signatories ownerSignsTransaction <- pletC $ signedBy # stakeDatum.owner - delegateSignsTransaction <- - pletC $ pconstant False - -- pmaybeData # pconstant False - -- # plam (signedBy #) - -- # stakeDatum.delegatedTo - stCurrencySymbol <- + delegateSignsTransaction <- pletC $ - pconstant $ - mintingPolicySymbol $ - mkMintingPolicy def (stakePolicy stake.gtClassRef) + pmaybeData # pconstant False + # signedBy + # stakeDatum.delegatedTo + + stCurrencySymbol <- pletC $ pconstant $ stakeSTSymbol as mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint valueSpent <- pletC $ pvalueSpent # txInfoF.inputs spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent @@ -294,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 @@ -496,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 @@ -507,7 +501,7 @@ stakeValidator stake = [ pgeqByClass' (AssetClass ("", "")) # ownOutputValue # expectedValue - , pgeqByClass' (untag stake.gtClassRef) + , pgeqByClass' (untag gtClassRef) # ownOutputValue # expectedValue , pgeqBySymbol diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 6406b0c..8b7ffb6 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -9,57 +9,35 @@ 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 Data.Default (Default (def)) import Plutarch.Api.V1 ( - AmountGuarantees, - KeyGuarantees, - PAddress, - PCredential (PScriptCredential), - PCurrencySymbol, PDatum, PDatumHash, - PMaybeData (PDJust, PDNothing), - PMintingPolicy, + PMaybeData, PTokenName (PTokenName), 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 (..), ) @@ -67,60 +45,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. @@ -136,25 +60,6 @@ validatorHashToTokenName (ValidatorHash hash) = TokenName hash 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 def 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 @@ -171,33 +76,11 @@ 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 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 - {- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'. @since 0.1.0 @@ -217,19 +100,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 @@ -247,53 +117,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 + @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 + }