From 21b4f1c35a12a57c1837c4fe7dc38acd03f55bd1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Mon, 6 Jan 2025 19:13:39 +0000 Subject: [PATCH] Add script target parameter (debug / production) (#37) * Add ScriptTarget flag * Add build target in one place * WIP - script dependencies * Fix build error * Use scripts from env everywhere * Parameterise tests by script target * Delete node params (not required anymore) * Add filter for NFT to globalParamsNode * 10x ex units and memory for testing * Rename workflow * github action: Fix concurrency group --- .github/workflows/ci-compiled-scripts.yaml | 4 +- src/lib/SmartTokens/Core/Scripts.hs | 36 +++- src/lib/Wst/Cli.hs | 3 +- src/lib/Wst/Offchain/BuildTx/DirectorySet.hs | 17 +- .../Wst/Offchain/BuildTx/ProgrammableLogic.hs | 78 ++------ .../Wst/Offchain/BuildTx/ProtocolParams.hs | 17 +- src/lib/Wst/Offchain/BuildTx/TransferLogic.hs | 18 +- src/lib/Wst/Offchain/Endpoints/Deployment.hs | 25 ++- src/lib/Wst/Offchain/Env.hs | 152 +++++++++++---- src/lib/Wst/Offchain/Query.hs | 15 +- src/lib/Wst/Offchain/Scripts.hs | 89 ++++----- src/lib/Wst/Server.hs | 29 +-- src/lib/Wst/Server/Endpoints.hs | 31 --- src/test/unit/Wst/Test/UnitTest.hs | 183 +++++++++--------- src/wst-poc.cabal | 1 - 15 files changed, 352 insertions(+), 346 deletions(-) delete mode 100644 src/lib/Wst/Server/Endpoints.hs diff --git a/.github/workflows/ci-compiled-scripts.yaml b/.github/workflows/ci-compiled-scripts.yaml index 77270ee..e997d0f 100644 --- a/.github/workflows/ci-compiled-scripts.yaml +++ b/.github/workflows/ci-compiled-scripts.yaml @@ -1,4 +1,4 @@ -name: ci-linux +name: ci-check-generated-code on: push: branches: @@ -6,7 +6,7 @@ on: pull_request: concurrency: - group: ${{ github.ref }} + group: "check-generated-code ${{ github.ref }}" cancel-in-progress: true jobs: diff --git a/src/lib/SmartTokens/Core/Scripts.hs b/src/lib/SmartTokens/Core/Scripts.hs index 6fcad66..96202af 100644 --- a/src/lib/SmartTokens/Core/Scripts.hs +++ b/src/lib/SmartTokens/Core/Scripts.hs @@ -1,18 +1,46 @@ module SmartTokens.Core.Scripts ( + -- * Build targets + ScriptTarget(..), + targetConfig, + + -- * Compile functions tryCompile, tryCompileTracingAndBinds, tryCompileNoTracing, ) where +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) import Plutarch -tryCompile :: Config -> ClosedTerm a -> Script -tryCompile cfg x = case compile cfg x of +{-| Script target environment +-} +data ScriptTarget + = Debug -- ^ Include debug symbols + | Production -- ^ No debug symbols + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +{-| The plutarch 'Config' for the target +-} +targetConfig :: ScriptTarget -> Config +targetConfig = \case + Debug -> tracingAndBindsConfig + Production -> prodConfig + +tryCompile :: ScriptTarget -> ClosedTerm a -> Script +tryCompile tgt x = case compile (targetConfig tgt) x of Left e -> error $ "Compilation failed: " <> show e Right s -> s tryCompileTracingAndBinds :: ClosedTerm a -> Script -tryCompileTracingAndBinds = tryCompile (Tracing LogInfo DoTracingAndBinds) +tryCompileTracingAndBinds = tryCompile Debug tryCompileNoTracing :: ClosedTerm a -> Script -tryCompileNoTracing = tryCompile NoTracing +tryCompileNoTracing = tryCompile Production + +tracingAndBindsConfig :: Config +tracingAndBindsConfig = Tracing LogInfo DoTracingAndBinds + +prodConfig :: Config +prodConfig = NoTracing diff --git a/src/lib/Wst/Cli.hs b/src/lib/Wst/Cli.hs index 81070cf..aa7db85 100644 --- a/src/lib/Wst/Cli.hs +++ b/src/lib/Wst/Cli.hs @@ -12,6 +12,7 @@ import Data.Proxy (Proxy) import Data.String (IsString (..)) import Options.Applicative (customExecParser, disambiguate, helper, idm, info, prefs, showHelpOnEmpty, showHelpOnError) +import SmartTokens.Core.Scripts (ScriptTarget (Production)) import Wst.App (runWstApp) import Wst.Cli.Command (Command (..), ManageCommand (StartServer, Status), parseCommand) @@ -32,7 +33,7 @@ runCommand com = do result <- case com of Deploy config -> runWstApp env (deploy config) Manage txIn com_ -> do - let env' = Env.addDirectoryEnvFor txIn env + let env' = Env.addDirectoryEnvFor (Env.DirectoryScriptRoot txIn Production) env runWstApp env' $ case com_ of Status -> do -- TODO: status check (call the query endpoints and print out a summary of the results) diff --git a/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs b/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs index 17c6923..39dab87 100644 --- a/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs +++ b/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs @@ -36,8 +36,7 @@ import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query (UTxODat (..)) -import Wst.Offchain.Scripts (directoryNodeMintingScript, - directoryNodeSpendingScript, scriptPolicyIdV3) +import Wst.Offchain.Scripts (scriptPolicyIdV3) _unused :: String _unused = _printTerm $ unsafeEvalTerm NoTracing (pconstantData initialNode) @@ -57,22 +56,21 @@ initialNode = DirectorySetNode initDirectorySet :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m () initDirectorySet = Utils.inBabbage @era $ do - txIn <- asks (Env.dsTxIn . Env.directoryEnv) - paramsPolicyId <- asks (Env.protocolParamsPolicyId . Env.directoryEnv) netId <- queryNetworkId - let mintingScript = directoryNodeMintingScript txIn + directoryMintingScript <- asks (Env.dsDirectoryMintingScript . Env.directoryEnv) + directorySpendingScript <- asks (Env.dsDirectorySpendingScript . Env.directoryEnv) - mintPlutus mintingScript InitDirectory (unTransAssetName directoryNodeToken) 1 + mintPlutus directoryMintingScript InitDirectory (unTransAssetName directoryNodeToken) 1 let val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra - $ fromList [(C.AssetId (scriptPolicyIdV3 mintingScript) (unTransAssetName directoryNodeToken), 1)] + $ fromList [(C.AssetId (scriptPolicyIdV3 directoryMintingScript) (unTransAssetName directoryNodeToken), 1)] addr = C.makeShelleyAddressInEra C.shelleyBasedEra netId - (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 $ directoryNodeSpendingScript paramsPolicyId) + (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 directorySpendingScript) C.NoStakeAddress dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData initialNode @@ -95,7 +93,6 @@ data InsertNodeArgs = insertDirectoryNode :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => UTxODat era ProgrammableLogicGlobalParams -> UTxODat era DirectorySetNode -> InsertNodeArgs -> m () insertDirectoryNode UTxODat{uIn=paramsRef} UTxODat{uIn, uOut=firstTxOut, uDatum=firstTxData} InsertNodeArgs{inaNewKey, inaTransferLogic, inaIssuerLogic} = Utils.inBabbage @era $ do netId <- queryNetworkId - paramsPolicyId <- asks (Env.protocolParamsPolicyId . Env.directoryEnv) directorySpendingScript <- asks (Env.dsDirectorySpendingScript . Env.directoryEnv) directoryMintingScript <- asks (Env.dsDirectoryMintingScript . Env.directoryEnv) let @@ -115,7 +112,7 @@ insertDirectoryNode UTxODat{uIn=paramsRef} UTxODat{uIn, uOut=firstTxOut, uDatum= C.makeShelleyAddressInEra C.shelleyBasedEra netId - (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 $ directoryNodeSpendingScript paramsPolicyId ) + (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 directorySpendingScript) C.NoStakeAddress dsn = DirectorySetNode diff --git a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs index 0eae8de..6ec25f2 100644 --- a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs @@ -6,13 +6,7 @@ {-# HLINT ignore "Use second" #-} module Wst.Offchain.BuildTx.ProgrammableLogic - ( - IssueNewTokenArgs (..), - alwaysSucceedsArgs, - fromTransferEnv, - programmableTokenMintingScript, - programmableTokenAssetId, - issueProgrammableToken, + ( issueProgrammableToken, transferProgrammableToken, seizeProgrammableToken, ) @@ -21,6 +15,7 @@ where import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C import Control.Lens ((^.)) +import Control.Monad (unless) import Control.Monad.Reader (MonadReader, asks) import Convex.BuildTx (MonadBuildTx, addReference, addWithdrawalWithTxBody, buildScriptWitness, findIndexReference, @@ -28,10 +23,8 @@ import Convex.BuildTx (MonadBuildTx, addReference, addWithdrawalWithTxBody, spendPlutusInlineDatum) import Convex.CardanoApi.Lenses as L import Convex.Class (MonadBlockchain (queryNetworkId)) -import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential, - unTransPolicyId) +import Convex.PlutusLedger.V1 (transPolicyId) import Convex.Utils qualified as Utils -import Data.Either (fromRight) import Data.Foldable (find, maximumBy, traverse_) import Data.Function (on) import Data.List (partition) @@ -48,59 +41,26 @@ import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..), import Wst.Offchain.Env (TransferLogicEnv (..)) import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query (UTxODat (..)) -import Wst.Offchain.Scripts (alwaysSucceedsScript, - programmableLogicMintingScript) - -data IssueNewTokenArgs = IssueNewTokenArgs - { intaMintingLogic :: C.PlutusScript C.PlutusScriptV3, -- TODO: We could add a parameter for the script 'lang' instead of fixing it to PlutusV3 - intaTransferLogic :: C.PlutusScript C.PlutusScriptV3, - intaIssuerLogic :: C.PlutusScript C.PlutusScriptV3 - } - -{-| 'IssueNewTokenArgs' for the policy that always succeeds (no checks) --} -alwaysSucceedsArgs :: IssueNewTokenArgs -alwaysSucceedsArgs = - IssueNewTokenArgs - { intaMintingLogic = alwaysSucceedsScript - , intaTransferLogic = alwaysSucceedsScript - , intaIssuerLogic = alwaysSucceedsScript - } - -{-| 'IssueNewTokenArgs' for the transfer logic --} -fromTransferEnv :: TransferLogicEnv -> IssueNewTokenArgs -fromTransferEnv TransferLogicEnv{tleMintingScript, tleTransferScript, tleIssuerScript} = - IssueNewTokenArgs - { intaMintingLogic = tleMintingScript - , intaTransferLogic = tleTransferScript - , intaIssuerLogic = tleIssuerScript - } - -{-| The minting script for a programmable token that uses the global parameters --} -programmableTokenMintingScript :: ProgrammableLogicGlobalParams -> IssueNewTokenArgs -> C.PlutusScript C.PlutusScriptV3 -programmableTokenMintingScript ProgrammableLogicGlobalParams {progLogicCred, directoryNodeCS} IssueNewTokenArgs{intaMintingLogic} = - let progLogicScriptCredential = fromRight (error "could not parse protocol params") $ unTransCredential progLogicCred - directoryNodeSymbol = fromRight (error "could not parse protocol params") $ unTransPolicyId directoryNodeCS - in programmableLogicMintingScript progLogicScriptCredential (C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaMintingLogic) directoryNodeSymbol - -{-| 'C.AssetId' of the programmable tokens --} -programmableTokenAssetId :: ProgrammableLogicGlobalParams -> IssueNewTokenArgs -> C.AssetName -> C.AssetId -programmableTokenAssetId params inta = - C.AssetId - (C.scriptPolicyId $ C.PlutusScript C.plutusScriptVersion $ programmableTokenMintingScript params inta) - {- Issue a programmable token and register it in the directory set if necessary. The caller should ensure that the specific minting logic stake script witness is included in the final transaction. - If the programmable token is not in the directory, then it is registered - If the programmable token is in the directory, then it is minted -} -issueProgrammableToken :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> IssueNewTokenArgs -> [UTxODat era DirectorySetNode] -> m C.PolicyId -issueProgrammableToken paramsTxOut (an, q) inta@IssueNewTokenArgs{intaTransferLogic, intaIssuerLogic} directoryList = Utils.inBabbage @era $ do - let mintingScript = programmableTokenMintingScript (uDatum paramsTxOut) inta +issueProgrammableToken :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> [UTxODat era DirectorySetNode] -> m C.PolicyId +issueProgrammableToken paramsTxOut (an, q) directoryList = Utils.inBabbage @era $ do + inta@TransferLogicEnv{tleTransferScript, tleIssuerScript} <- asks Env.transferLogicEnv + glParams <- asks (Env.globalParams . Env.directoryEnv) + dir <- asks Env.directoryEnv + + -- The global params in the UTxO need to match those in our 'DirectoryEnv'. + -- If they don't, we get a script error when trying to balance the transaction. + -- To avoid this we check for equality here and fail early. + unless (glParams == uDatum paramsTxOut) $ + -- FIXME: Error handling + error "Global params do not match" + + let mintingScript = Env.programmableTokenMintingScript dir inta issuedPolicyId = C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript issuedSymbol = transPolicyId issuedPolicyId @@ -115,8 +75,8 @@ issueProgrammableToken paramsTxOut (an, q) inta@IssueNewTokenArgs{intaTransferLo let nodeArgs = InsertNodeArgs { inaNewKey = issuedSymbol - , inaTransferLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaTransferLogic - , inaIssuerLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaIssuerLogic + , inaTransferLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion tleTransferScript + , inaIssuerLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion tleIssuerScript } mintPlutus mintingScript RegisterPToken an q diff --git a/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs b/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs index 79efd70..a66254d 100644 --- a/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs +++ b/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} module Wst.Offchain.BuildTx.ProtocolParams ( mintProtocolParams, getProtocolParamsGlobalInline @@ -15,9 +16,9 @@ import Convex.Utils qualified as Utils import GHC.Exts (IsList (..)) import SmartTokens.Types.Constants (protocolParamsToken) import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) +import Wst.Offchain.Env (DirectoryEnv (..)) import Wst.Offchain.Env qualified as Env -import Wst.Offchain.Scripts (protocolParamsMintingScript, - protocolParamsSpendingScript, scriptPolicyIdV3) +import Wst.Offchain.Scripts (scriptPolicyIdV3) protocolParamsTokenC :: C.AssetName protocolParamsTokenC = unTransAssetName protocolParamsToken @@ -26,13 +27,11 @@ protocolParamsTokenC = unTransAssetName protocolParamsToken -} mintProtocolParams :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => m () mintProtocolParams = Utils.inBabbage @era $ do - txIn <- asks (Env.dsTxIn . Env.directoryEnv) + txIn <- asks (Env.srTxIn . Env.dsScriptRoot . Env.directoryEnv) params <- asks (Env.globalParams . Env.directoryEnv) netId <- queryNetworkId - let - mintingScript = protocolParamsMintingScript txIn - - policyId = scriptPolicyIdV3 mintingScript + DirectoryEnv{dsProtocolParamsMintingScript, dsProtocolParamsSpendingScript} <- asks Env.directoryEnv + let policyId = scriptPolicyIdV3 dsProtocolParamsMintingScript val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra $ fromList [(C.AssetId policyId protocolParamsTokenC, 1)] @@ -41,7 +40,7 @@ mintProtocolParams = Utils.inBabbage @era $ do C.makeShelleyAddressInEra C.shelleyBasedEra netId - (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 protocolParamsSpendingScript) + (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 dsProtocolParamsSpendingScript) C.NoStakeAddress -- Should contain directoryNodeCS and progLogicCred fields @@ -51,7 +50,7 @@ mintProtocolParams = Utils.inBabbage @era $ do output = C.TxOut addr val dat C.ReferenceScriptNone spendPublicKeyOutput txIn - mintPlutus mintingScript () protocolParamsTokenC 1 + mintPlutus dsProtocolParamsMintingScript () protocolParamsTokenC 1 prependTxOut output getProtocolParamsGlobalInline :: C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe ProgrammableLogicGlobalParams diff --git a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs index bf080f8..6455c53 100644 --- a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs @@ -44,24 +44,13 @@ import SmartTokens.Types.ProtocolParams import SmartTokens.Types.PTokenDirectory (BlacklistNode (..), DirectorySetNode (..)) import Wst.AppError (AppError (TransferBlacklistedCredential)) -import Wst.Offchain.BuildTx.ProgrammableLogic (IssueNewTokenArgs (..), - issueProgrammableToken, +import Wst.Offchain.BuildTx.ProgrammableLogic (issueProgrammableToken, seizeProgrammableToken, transferProgrammableToken) import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query (UTxODat (..)) import Wst.Offchain.Scripts (scriptPolicyIdV3) -intaFromEnv :: forall env m. (MonadReader env m, Env.HasTransferLogicEnv env)=> m IssueNewTokenArgs -intaFromEnv = do - Env.TransferLogicEnv{Env.tleIssuerScript, Env.tleMintingScript, Env.tleTransferScript} <- asks Env.transferLogicEnv - pure $ IssueNewTokenArgs - { intaTransferLogic= tleTransferScript - , intaMintingLogic= tleMintingScript - , intaIssuerLogic= tleIssuerScript - } - - {- >>> _printTerm $ unsafeEvalTerm NoTracing (pconstant blacklistInitialNode) "program\n 1.0.0\n (List [B #, B #ffffffffffffffffffffffffffffffffffffffffffffffffffffffff])" @@ -157,10 +146,7 @@ paySmartTokensToDestination (an, q) issuedPolicyId destinationCred = Utils.inBab issueSmartTokens :: forall era env m. (MonadReader env m, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m, Env.HasOperatorEnv era env) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> [UTxODat era DirectorySetNode] -> C.PaymentCredential -> m C.AssetId issueSmartTokens paramsTxOut (an, q) directoryList destinationCred = Utils.inBabbage @era $ do - inta <- intaFromEnv - issuedPolicyId <- issueProgrammableToken paramsTxOut (an, q) inta directoryList - - + issuedPolicyId <- issueProgrammableToken paramsTxOut (an, q) directoryList addIssueWitness -- payToAddress addr value paySmartTokensToDestination (an, q) issuedPolicyId destinationCred diff --git a/src/lib/Wst/Offchain/Endpoints/Deployment.hs b/src/lib/Wst/Offchain/Endpoints/Deployment.hs index 58c7c91..0c74a95 100644 --- a/src/lib/Wst/Offchain/Endpoints/Deployment.hs +++ b/src/lib/Wst/Offchain/Endpoints/Deployment.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-| Deploy the directory and global params -} module Wst.Offchain.Endpoints.Deployment( @@ -22,6 +23,7 @@ import Convex.Class (MonadBlockchain, MonadUtxoQuery) import Convex.CoinSelection qualified import Data.Foldable (maximumBy) import Data.Function (on) +import SmartTokens.Core.Scripts (ScriptTarget (..)) import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) import Wst.AppError (AppError) import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (inaNewKey)) @@ -29,6 +31,7 @@ import Wst.Offchain.BuildTx.DirectorySet qualified as BuildTx import Wst.Offchain.BuildTx.ProgrammableLogic qualified as BuildTx import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx import Wst.Offchain.BuildTx.TransferLogic qualified as BuildTx +import Wst.Offchain.Env (DirectoryScriptRoot (..)) import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query (UTxODat (..)) import Wst.Offchain.Query qualified as Query @@ -36,14 +39,15 @@ import Wst.Offchain.Query qualified as Query {-| Build a transaction that deploys the directory and global params. Returns the transaction and the 'TxIn' that was selected for the one-shot NFTs. -} -deployTx :: (MonadReader env m, Env.HasOperatorEnv era env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era) => m (C.Tx era, C.TxIn) -deployTx = do +deployTx :: (MonadReader env m, Env.HasOperatorEnv era env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era) => ScriptTarget -> m (C.Tx era, DirectoryScriptRoot) +deployTx target = do (txi, _) <- Env.selectOperatorOutput opEnv <- asks Env.operatorEnv - (tx, _) <- Env.withEnv $ Env.withOperator opEnv $ Env.withDirectoryFor txi + let root = DirectoryScriptRoot txi target + (tx, _) <- Env.withEnv $ Env.withOperator opEnv $ Env.withDirectoryFor root $ Env.balanceTxEnv_ $ BuildTx.mintProtocolParams >> BuildTx.initDirectorySet - pure (Convex.CoinSelection.signBalancedTxBody [] tx, txi) + pure (Convex.CoinSelection.signBalancedTxBody [] tx, root) {-| Build a transaction that inserts a node into the directory -} @@ -68,25 +72,26 @@ issueProgrammableTokenTx :: forall era env m. ( MonadReader env m , Env.HasOperatorEnv era env , Env.HasDirectoryEnv env + , Env.HasTransferLogicEnv env , MonadBlockchain era m , MonadError (AppError era) m , C.IsBabbageBasedEra era , C.HasScriptLanguageInEra C.PlutusScriptV3 era , MonadUtxoQuery m ) - => BuildTx.IssueNewTokenArgs -- ^ credentials of the token - -> C.AssetName -- ^ Name of the asset + => C.AssetName -- ^ Name of the asset -> Quantity -- ^ Amount of tokens to be minted -> m (C.Tx era) -issueProgrammableTokenTx issueTokenArgs assetName quantity = do +issueProgrammableTokenTx assetName quantity = do directory <- Query.registryNodes @era paramsNode <- Query.globalParamsNode @era + Env.TransferLogicEnv{Env.tleMintingScript} <- asks Env.transferLogicEnv (tx, _) <- Env.balanceTxEnv_ $ do - polId <- BuildTx.issueProgrammableToken paramsNode (assetName, quantity) issueTokenArgs directory + polId <- BuildTx.issueProgrammableToken paramsNode (assetName, quantity) directory Env.operatorPaymentCredential >>= BuildTx.paySmartTokensToDestination (assetName, quantity) polId - let hsh = C.hashScript (C.PlutusScript C.plutusScriptVersion $ BuildTx.intaMintingLogic issueTokenArgs) - BuildTx.addScriptWithdrawal hsh 0 $ BuildTx.buildScriptWitness (BuildTx.intaMintingLogic issueTokenArgs) C.NoScriptDatumForStake () + let hsh = C.hashScript (C.PlutusScript C.plutusScriptVersion tleMintingScript) + BuildTx.addScriptWithdrawal hsh 0 $ BuildTx.buildScriptWitness tleMintingScript C.NoScriptDatumForStake () pure (Convex.CoinSelection.signBalancedTxBody [] tx) deployBlacklistTx :: (MonadReader env m, Env.HasOperatorEnv era env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era, Env.HasDirectoryEnv env) => m (C.Tx era) diff --git a/src/lib/Wst/Offchain/Env.hs b/src/lib/Wst/Offchain/Env.hs index 2555a6e..f653e77 100644 --- a/src/lib/Wst/Offchain/Env.hs +++ b/src/lib/Wst/Offchain/Env.hs @@ -19,10 +19,13 @@ module Wst.Offchain.Env( balanceTxEnv, balanceTxEnv_, - -- * Directory environment + -- * On-chain scripts + + -- ** Directory environment + DirectoryScriptRoot(..), + mkDirectoryEnv, HasDirectoryEnv(..), DirectoryEnv(..), - mkDirectoryEnv, programmableLogicStakeCredential, programmableLogicBaseCredential, directoryNodePolicyId, @@ -30,15 +33,22 @@ module Wst.Offchain.Env( globalParams, getGlobalParams, - -- * Transfer logic environment + -- ** Transfer logic environment + BlacklistTransferLogicScriptRoot(..), + mkTransferLogicEnv, TransferLogicEnv(..), + transferLogicForDirectory, + alwaysSucceedsTransferLogic, HasTransferLogicEnv(..), - mkTransferLogicEnv, addTransferEnv, withTransfer, withTransferFor, withTransferFromOperator, + -- ** Minting tokens + programmableTokenMintingScript, + programmableTokenAssetId, + -- * Runtime data RuntimeEnv(..), HasRuntimeEnv(..), @@ -76,26 +86,32 @@ import Convex.BuildTx qualified as BuildTx import Convex.Class (MonadBlockchain, MonadUtxoQuery (..), queryProtocolParameters, utxosByPaymentCredential) import Convex.CoinSelection qualified as CoinSelection -import Convex.PlutusLedger.V1 (transCredential, transPolicyId) +import Convex.PlutusLedger.V1 (transCredential, transPolicyId, + unTransCredential, unTransPolicyId) import Convex.Utils (mapError) import Convex.Utxos (BalanceChanges) import Convex.Utxos qualified as Utxos import Convex.Wallet.Operator (returnOutputFor) +import Data.Either (fromRight) import Data.Functor.Identity (Identity (..)) import Data.Map qualified as Map import Data.Maybe (listToMaybe) import Data.Proxy (Proxy (..)) import Data.Text qualified as Text +import SmartTokens.Core.Scripts (ScriptTarget) import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams (..)) import System.Environment qualified import Wst.AppError (AppError (..)) -import Wst.Offchain.Scripts (blacklistMintingScript, blacklistSpendingScript, +import Wst.Offchain.Scripts (alwaysSucceedsScript, blacklistMintingScript, + blacklistSpendingScript, directoryNodeMintingScript, directoryNodeSpendingScript, freezeTransferScript, permissionedTransferScript, programmableLogicBaseScript, programmableLogicGlobalScript, - protocolParamsMintingScript, scriptPolicyIdV3) + programmableLogicMintingScript, + protocolParamsMintingScript, + protocolParamsSpendingScript, scriptPolicyIdV3) {-| Environments that have an 'OperatorEnv' -} @@ -164,6 +180,16 @@ balanceTxEnv btx = do (balBody, balChanges) <- mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange) pure ((balBody, balChanges), r) +{-| Data that completely determines the on-chain scripts of the programmable +token directory, and their hashes. Any information that results in different +script hashes should go in here. We should be able to write a function +'DirectoryScriptRoot -> script' for all of the directory scripts. +-} +data DirectoryScriptRoot = + DirectoryScriptRoot + { srTxIn :: C.TxIn + , srTarget :: ScriptTarget + } class HasDirectoryEnv e where directoryEnv :: e -> DirectoryEnv @@ -176,25 +202,28 @@ All of the scripts and their hashes are determined by the 'TxIn'. -} data DirectoryEnv = DirectoryEnv - { dsTxIn :: C.TxIn -- ^ The 'txIn' that we spend when deploying the protocol params and directory set + { dsScriptRoot :: DirectoryScriptRoot , dsDirectoryMintingScript :: PlutusScript PlutusScriptV3 , dsDirectorySpendingScript :: PlutusScript PlutusScriptV3 , dsProtocolParamsMintingScript :: PlutusScript PlutusScriptV3 + , dsProtocolParamsSpendingScript :: PlutusScript PlutusScriptV3 , dsProgrammableLogicBaseScript :: PlutusScript PlutusScriptV3 , dsProgrammableLogicGlobalScript :: PlutusScript PlutusScriptV3 } -mkDirectoryEnv :: C.TxIn -> DirectoryEnv -mkDirectoryEnv dsTxIn = - let dsDirectoryMintingScript = directoryNodeMintingScript dsTxIn - dsProtocolParamsMintingScript = protocolParamsMintingScript dsTxIn - dsDirectorySpendingScript = directoryNodeSpendingScript (protocolParamsPolicyId result) - dsProgrammableLogicBaseScript = programmableLogicBaseScript (programmableLogicStakeCredential result) -- Parameterized by the stake cred of the global script - dsProgrammableLogicGlobalScript = programmableLogicGlobalScript (protocolParamsPolicyId result) -- Parameterized by the CS holding protocol params datum +mkDirectoryEnv :: DirectoryScriptRoot -> DirectoryEnv +mkDirectoryEnv dsScriptRoot@DirectoryScriptRoot{srTxIn, srTarget} = + let dsDirectoryMintingScript = directoryNodeMintingScript srTarget srTxIn + dsProtocolParamsMintingScript = protocolParamsMintingScript srTarget srTxIn + dsProtocolParamsSpendingScript = protocolParamsSpendingScript srTarget + dsDirectorySpendingScript = directoryNodeSpendingScript srTarget (protocolParamsPolicyId result) + dsProgrammableLogicBaseScript = programmableLogicBaseScript srTarget (programmableLogicStakeCredential result) -- Parameterized by the stake cred of the global script + dsProgrammableLogicGlobalScript = programmableLogicGlobalScript srTarget (protocolParamsPolicyId result) -- Parameterized by the CS holding protocol params datum result = DirectoryEnv - { dsTxIn + { dsScriptRoot , dsDirectoryMintingScript , dsProtocolParamsMintingScript + , dsProtocolParamsSpendingScript , dsProgrammableLogicBaseScript , dsProgrammableLogicGlobalScript , dsDirectorySpendingScript @@ -230,11 +259,23 @@ getGlobalParams = asks (globalParams . directoryEnv) data TransferLogicEnv = TransferLogicEnv - { tleBlacklistMintingScript :: PlutusScript PlutusScriptV3 + { tleBlacklistMintingScript :: PlutusScript PlutusScriptV3 , tleBlacklistSpendingScript :: PlutusScript PlutusScriptV3 - , tleMintingScript :: PlutusScript PlutusScriptV3 - , tleTransferScript :: PlutusScript PlutusScriptV3 - , tleIssuerScript :: PlutusScript PlutusScriptV3 + , tleMintingScript :: PlutusScript PlutusScriptV3 + , tleTransferScript :: PlutusScript PlutusScriptV3 + , tleIssuerScript :: PlutusScript PlutusScriptV3 + } + +{-| 'IssueNewTokenArgs' for the policy that always succeeds (no checks) +-} +alwaysSucceedsTransferLogic :: ScriptTarget -> TransferLogicEnv +alwaysSucceedsTransferLogic target = + TransferLogicEnv + { tleBlacklistMintingScript = alwaysSucceedsScript target + , tleBlacklistSpendingScript = alwaysSucceedsScript target + , tleMintingScript = alwaysSucceedsScript target + , tleTransferScript = alwaysSucceedsScript target + , tleIssuerScript = alwaysSucceedsScript target } class HasTransferLogicEnv e where @@ -243,20 +284,31 @@ class HasTransferLogicEnv e where instance HasTransferLogicEnv TransferLogicEnv where transferLogicEnv = id -{-| The 'TransferLogicEnv' with scripts that allow the given payment credential -to manage the blacklist and issue / burn tokens +{-| Data that completely determines the on-chain scripts of the blacklist +transfer logic, and their hashes. Any information that results in different +script hashes should go in here. We should be able to write a function +'BlacklistTransferLogicScriptRoot -> script' for all of the blacklist transfer +logic scripts. -} -mkTransferLogicEnv :: C.PaymentCredential -> C.Hash C.PaymentKey -> TransferLogicEnv -mkTransferLogicEnv progLogicBaseCred cred = - let blacklistMinting = blacklistMintingScript cred +data BlacklistTransferLogicScriptRoot = + BlacklistTransferLogicScriptRoot + { tlrTarget :: ScriptTarget + , tlrDirEnv :: DirectoryEnv + , tlrIssuer :: C.Hash C.PaymentKey + } + +mkTransferLogicEnv :: BlacklistTransferLogicScriptRoot -> TransferLogicEnv +mkTransferLogicEnv BlacklistTransferLogicScriptRoot{tlrTarget, tlrDirEnv, tlrIssuer} = + let blacklistMinting = blacklistMintingScript tlrTarget tlrIssuer blacklistPolicy = scriptPolicyIdV3 blacklistMinting + progLogicBaseCred = programmableLogicBaseCredential tlrDirEnv in TransferLogicEnv { tleBlacklistMintingScript = blacklistMinting - , tleBlacklistSpendingScript = blacklistSpendingScript cred - , tleMintingScript = permissionedTransferScript cred - , tleTransferScript = freezeTransferScript progLogicBaseCred blacklistPolicy - , tleIssuerScript = permissionedTransferScript cred + , tleBlacklistSpendingScript = blacklistSpendingScript tlrTarget tlrIssuer + , tleMintingScript = permissionedTransferScript tlrTarget tlrIssuer + , tleTransferScript = freezeTransferScript tlrTarget progLogicBaseCred blacklistPolicy + , tleIssuerScript = permissionedTransferScript tlrTarget tlrIssuer } blacklistNodePolicyId :: TransferLogicEnv -> C.PolicyId @@ -333,8 +385,8 @@ instance HasLogger (CombinedEnv o d t Identity era) where {-| Add a 'DirectoryEnv' for the 'C.TxIn' in to the environment -} -addDirectoryEnvFor :: C.TxIn -> CombinedEnv o d t r era -> CombinedEnv o Identity t r era -addDirectoryEnvFor txi = addDirectoryEnv (mkDirectoryEnv txi) +addDirectoryEnvFor :: DirectoryScriptRoot -> CombinedEnv o d t r era -> CombinedEnv o Identity t r era +addDirectoryEnvFor = addDirectoryEnv . mkDirectoryEnv {-| Add a 'DirectoryEnv' for the 'C.TxIn' in to the environment -} @@ -347,8 +399,8 @@ withDirectory dir action = do asks (addDirectoryEnv dir) >>= runReaderT action -withDirectoryFor :: MonadReader (CombinedEnv o d t r era) m => C.TxIn -> ReaderT (CombinedEnv o Identity t r era) m a -> m a -withDirectoryFor txi = withDirectory (mkDirectoryEnv txi) +withDirectoryFor :: MonadReader (CombinedEnv o d t r era) m => DirectoryScriptRoot -> ReaderT (CombinedEnv o Identity t r era) m a -> m a +withDirectoryFor = withDirectory . mkDirectoryEnv {-| Add a 'TransferLogicEnv' for the 'C.Hash C.PaymentKey' corresponding to the admin hash @@ -362,15 +414,41 @@ withTransfer dir action = do asks (addTransferEnv dir) >>= runReaderT action -withTransferFor :: MonadReader (CombinedEnv o Identity t r era) m => C.PaymentCredential -> C.Hash C.PaymentKey -> ReaderT (CombinedEnv o Identity Identity r era) m a -> m a -withTransferFor plbBaseCred opPKH = withTransfer $ mkTransferLogicEnv plbBaseCred opPKH +withTransferFor :: MonadReader (CombinedEnv o Identity t r era) m => BlacklistTransferLogicScriptRoot -> ReaderT (CombinedEnv o Identity Identity r era) m a -> m a +withTransferFor = withTransfer . mkTransferLogicEnv + +{-| Transfer logic scripts for the blacklist managed by the given 'C.PaymentKey' hash +-} +transferLogicForDirectory :: (HasDirectoryEnv env, MonadReader env m) => C.Hash C.PaymentKey -> m TransferLogicEnv +transferLogicForDirectory pkh = do + env <- ask + let dirEnv = directoryEnv env + pure (mkTransferLogicEnv $ BlacklistTransferLogicScriptRoot (srTarget $ dsScriptRoot dirEnv) dirEnv pkh) withTransferFromOperator :: (MonadReader (CombinedEnv Identity Identity t r era) m) => ReaderT (CombinedEnv Identity Identity Identity r era) m a -> m a withTransferFromOperator action = do env <- ask let opPkh = fst . bteOperator . operatorEnv $ env - programmableBaseLogicCred = programmableLogicBaseCredential . directoryEnv $ env - runReaderT action (addTransferEnv (mkTransferLogicEnv programmableBaseLogicCred opPkh) env) + root <- transferLogicForDirectory opPkh + runReaderT action (addTransferEnv root env) + +{-| The minting script for a programmable token that uses the global parameters +-} +programmableTokenMintingScript :: DirectoryEnv -> TransferLogicEnv -> C.PlutusScript C.PlutusScriptV3 +programmableTokenMintingScript dirEnv@DirectoryEnv{dsScriptRoot} TransferLogicEnv{tleMintingScript} = + let ProgrammableLogicGlobalParams {progLogicCred, directoryNodeCS} = globalParams dirEnv + DirectoryScriptRoot{srTarget} = dsScriptRoot + progLogicScriptCredential = fromRight (error "could not parse protocol params") $ unTransCredential progLogicCred + directoryNodeSymbol = fromRight (error "could not parse protocol params") $ unTransPolicyId directoryNodeCS + in programmableLogicMintingScript srTarget progLogicScriptCredential (C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion tleMintingScript) directoryNodeSymbol + +{-| 'C.AssetId' of the programmable tokens +-} +programmableTokenAssetId :: DirectoryEnv -> TransferLogicEnv -> C.AssetName -> C.AssetId +programmableTokenAssetId dirEnv inta = + C.AssetId + (C.scriptPolicyId $ C.PlutusScript C.plutusScriptVersion $ programmableTokenMintingScript dirEnv inta) + {-| Add a 'DirectoryEnv' for the 'C.TxIn' in to the environment and run the action with the modified environment diff --git a/src/lib/Wst/Offchain/Query.hs b/src/lib/Wst/Offchain/Query.hs index 788cab9..d293e3e 100644 --- a/src/lib/Wst/Offchain/Query.hs +++ b/src/lib/Wst/Offchain/Query.hs @@ -34,12 +34,11 @@ import PlutusTx qualified import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) import SmartTokens.Types.PTokenDirectory (BlacklistNode, DirectorySetNode (..)) import Wst.AppError (AppError (GlobalParamsNodeNotFound)) -import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript, dsProgrammableLogicBaseScript), - HasDirectoryEnv (directoryEnv), +import Wst.Offchain.Env (DirectoryEnv (..), HasDirectoryEnv (directoryEnv), HasTransferLogicEnv (transferLogicEnv), TransferLogicEnv (tleBlacklistSpendingScript), - blacklistNodePolicyId, directoryNodePolicyId) -import Wst.Offchain.Scripts (protocolParamsSpendingScript) + blacklistNodePolicyId, directoryNodePolicyId, + protocolParamsPolicyId) -- TODO: We should probably filter the UTxOs to check that they have the correct NFTs @@ -83,11 +82,13 @@ userProgrammableOutputs userCred = do {-| Find the UTxO with the global params -} -globalParamsNode :: forall era m. (MonadUtxoQuery m, C.IsBabbageBasedEra era, MonadError (AppError era) m) => m (UTxODat era ProgrammableLogicGlobalParams) +globalParamsNode :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era, MonadError (AppError era) m) => m (UTxODat era ProgrammableLogicGlobalParams) globalParamsNode = do - let cred = C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 $ protocolParamsSpendingScript + env@DirectoryEnv{dsProtocolParamsSpendingScript} <- asks directoryEnv + let cred = C.PaymentCredentialByScript . C.hashScript $ C.PlutusScript C.PlutusScriptV3 dsProtocolParamsSpendingScript + hasNft = utxoHasPolicyId (protocolParamsPolicyId env) utxosByPaymentCredential cred - >>= maybe (throwError GlobalParamsNodeNotFound) pure . listToMaybe . extractUTxO @era + >>= maybe (throwError GlobalParamsNodeNotFound) pure . listToMaybe . filter hasNft . extractUTxO @era {-| Outputs that are locked by the programmable logic base script. -} diff --git a/src/lib/Wst/Offchain/Scripts.hs b/src/lib/Wst/Offchain/Scripts.hs index 995911e..a815cd0 100644 --- a/src/lib/Wst/Offchain/Scripts.hs +++ b/src/lib/Wst/Offchain/Scripts.hs @@ -3,6 +3,7 @@ {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Wst.Offchain.Scripts ( + -- * Core scripts protocolParamsMintingScript, protocolParamsSpendingScript, directoryNodeMintingScript, @@ -11,7 +12,7 @@ module Wst.Offchain.Scripts ( programmableLogicBaseScript, programmableLogicGlobalScript, - -- Transfer logic + -- * Transfer logic permissionedTransferScript, freezeTransferScript, blacklistMintingScript, @@ -30,7 +31,7 @@ import Cardano.Api.Shelley qualified as C import Convex.PlutusLedger.V1 (transCredential, transPolicyId, transPubKeyHash, transStakeCredential) import Convex.PlutusLedger.V3 (transTxOutRef) -import Plutarch (ClosedTerm, Config (..), LogLevel (..), TracingMode (..), (#)) +import Plutarch (ClosedTerm, (#)) import Plutarch.Builtin (pdata, pforgetData) import Plutarch.ByteString (PByteString) import Plutarch.Lift (pconstant) @@ -44,94 +45,86 @@ import SmartTokens.Contracts.ProgrammableLogicBase (mkProgrammableLogicBase, import SmartTokens.Contracts.ProtocolParams (alwaysFailScript, mkPermissionedMinting, mkProtocolParametersMinting) -import SmartTokens.Core.Scripts (tryCompile) +import SmartTokens.Core.Scripts (ScriptTarget (..)) +import SmartTokens.Core.Scripts qualified as Scripts import SmartTokens.LinkedList.MintDirectory (mkDirectoryNodeMP) import SmartTokens.LinkedList.SpendDirectory (pmkDirectorySpending) -tracingConfig :: Config -tracingConfig = Tracing LogInfo DoTracing - -tracingAndBindsConfig :: Config -tracingAndBindsConfig = Tracing LogInfo DoTracingAndBinds - -prodConfig :: Config -prodConfig = NoTracing - -- Protocol params -- | The minting script for the protocol parameters NFT, takes initial TxIn for -- one shot mint -protocolParamsMintingScript :: C.TxIn -> C.PlutusScript C.PlutusScriptV3 -protocolParamsMintingScript txIn = - let script = tryCompile tracingConfig $ mkProtocolParametersMinting # pdata (pconstant $ transTxOutRef txIn) +protocolParamsMintingScript :: ScriptTarget -> C.TxIn -> C.PlutusScript C.PlutusScriptV3 +protocolParamsMintingScript target txIn = + let script = Scripts.tryCompile target $ mkProtocolParametersMinting # pdata (pconstant $ transTxOutRef txIn) in C.PlutusScriptSerialised $ serialiseScript script -- | The spending script for the protocol parameters NFT parameterized by "" -- nonce -protocolParamsSpendingScript :: C.PlutusScript C.PlutusScriptV3 -protocolParamsSpendingScript = - let script = tryCompile tracingConfig $ alwaysFailScript # pforgetData (pdata (pconstant "" :: ClosedTerm PByteString)) +protocolParamsSpendingScript :: ScriptTarget -> C.PlutusScript C.PlutusScriptV3 +protocolParamsSpendingScript target = + let script = Scripts.tryCompile target $ alwaysFailScript # pforgetData (pdata (pconstant "" :: ClosedTerm PByteString)) in C.PlutusScriptSerialised $ serialiseScript script -- | The minting script for the directory node tokens, takes initial TxIn for -- symbol uniqueness across instances -directoryNodeMintingScript :: C.TxIn -> C.PlutusScript C.PlutusScriptV3 -directoryNodeMintingScript txIn = - let script = tryCompile tracingConfig $ mkDirectoryNodeMP # pdata (pconstant $ transTxOutRef txIn) +directoryNodeMintingScript :: ScriptTarget -> C.TxIn -> C.PlutusScript C.PlutusScriptV3 +directoryNodeMintingScript target txIn = + let script = Scripts.tryCompile target $ mkDirectoryNodeMP # pdata (pconstant $ transTxOutRef txIn) in C.PlutusScriptSerialised $ serialiseScript script -- | The spending script for the directory node tokens, parameterized by the -- policy id of the protocol parameters NFT. -directoryNodeSpendingScript :: C.PolicyId -> C.PlutusScript C.PlutusScriptV3 -directoryNodeSpendingScript paramsPolId = - let script = tryCompile tracingConfig $ pmkDirectorySpending # pdata (pconstant $ transPolicyId paramsPolId) +directoryNodeSpendingScript :: ScriptTarget -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3 +directoryNodeSpendingScript target paramsPolId = + let script = Scripts.tryCompile target $ pmkDirectorySpending # pdata (pconstant $ transPolicyId paramsPolId) in C.PlutusScriptSerialised $ serialiseScript script -- TODO: can we change the signature to just take the param policy id? -programmableLogicMintingScript :: C.PaymentCredential -> C.StakeCredential -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3 -programmableLogicMintingScript progLogicBaseSpndingCred mintingCred nodePolId = - let script = tryCompile tracingConfig +programmableLogicMintingScript :: ScriptTarget -> C.PaymentCredential -> C.StakeCredential -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3 +programmableLogicMintingScript target progLogicBaseSpndingCred mintingCred nodePolId = + let script = Scripts.tryCompile target $ mkProgrammableLogicMinting # pdata (pconstant $ transCredential progLogicBaseSpndingCred) # pdata (pconstant $ transPolicyId nodePolId) # pdata (pconstant $ transStakeCredential mintingCred) in C.PlutusScriptSerialised $ serialiseScript script -programmableLogicBaseScript :: C.StakeCredential -> C.PlutusScript C.PlutusScriptV3 -- Parameterized by the stake cred of the global script -programmableLogicBaseScript globalCred = - let script = tryCompile tracingConfig $ mkProgrammableLogicBase # pdata (pconstant $ transStakeCredential globalCred) +programmableLogicBaseScript :: ScriptTarget -> C.StakeCredential -> C.PlutusScript C.PlutusScriptV3 -- Parameterized by the stake cred of the global script +programmableLogicBaseScript target globalCred = + let script = Scripts.tryCompile target $ mkProgrammableLogicBase # pdata (pconstant $ transStakeCredential globalCred) in C.PlutusScriptSerialised $ serialiseScript script -programmableLogicGlobalScript :: C.PolicyId -> C.PlutusScript C.PlutusScriptV3 -- Parameterized by the CS holding protocol params datum -programmableLogicGlobalScript paramsPolId = - let script = tryCompile tracingConfig $ mkProgrammableLogicGlobal # pdata (pconstant $ transPolicyId paramsPolId) +programmableLogicGlobalScript :: ScriptTarget -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3 -- Parameterized by the CS holding protocol params datum +programmableLogicGlobalScript target paramsPolId = + let script = Scripts.tryCompile target $ mkProgrammableLogicGlobal # pdata (pconstant $ transPolicyId paramsPolId) in C.PlutusScriptSerialised $ serialiseScript script -permissionedTransferScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3 -permissionedTransferScript cred = - let script = tryCompile tracingConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred) +permissionedTransferScript :: ScriptTarget -> C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3 +permissionedTransferScript target cred = + let script = Scripts.tryCompile target $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred) in C.PlutusScriptSerialised $ serialiseScript script -freezeTransferScript :: C.PaymentCredential -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3 -freezeTransferScript progLogicBaseSpndingCred blacklistPolicyId = - let script = tryCompile tracingConfig $ mkFreezeAndSeizeTransfer # pdata (pconstant $ transCredential progLogicBaseSpndingCred) # pdata (pconstant $ transPolicyId blacklistPolicyId) +freezeTransferScript :: ScriptTarget -> C.PaymentCredential -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3 +freezeTransferScript target progLogicBaseSpndingCred blacklistPolicyId = + let script = Scripts.tryCompile target $ mkFreezeAndSeizeTransfer # pdata (pconstant $ transCredential progLogicBaseSpndingCred) # pdata (pconstant $ transPolicyId blacklistPolicyId) in C.PlutusScriptSerialised $ serialiseScript script -blacklistMintingScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3 -blacklistMintingScript cred = - let script = tryCompile tracingConfig $ mkPermissionedMinting # pdata (pconstant $ transPubKeyHash cred) +blacklistMintingScript :: ScriptTarget -> C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3 +blacklistMintingScript target cred = + let script = Scripts.tryCompile target $ mkPermissionedMinting # pdata (pconstant $ transPubKeyHash cred) in C.PlutusScriptSerialised $ serialiseScript script -blacklistSpendingScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3 -blacklistSpendingScript cred = - let script = tryCompile tracingConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred) +blacklistSpendingScript :: ScriptTarget -> C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3 +blacklistSpendingScript target cred = + let script = Scripts.tryCompile target $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred) in C.PlutusScriptSerialised $ serialiseScript script {-| 'C.PlutusScript C.PlutusScriptV3' that always succeeds. Can be used for minting, withdrawal, spending, etc. -} -alwaysSucceedsScript :: C.PlutusScript C.PlutusScriptV3 -alwaysSucceedsScript = - C.PlutusScriptSerialised $ serialiseScript $ tryCompile tracingConfig palwaysSucceed +alwaysSucceedsScript :: ScriptTarget -> C.PlutusScript C.PlutusScriptV3 +alwaysSucceedsScript target = + C.PlutusScriptSerialised $ serialiseScript $ Scripts.tryCompile target palwaysSucceed -- Utilities scriptPolicyIdV3 :: C.PlutusScript C.PlutusScriptV3 -> C.PolicyId diff --git a/src/lib/Wst/Server.hs b/src/lib/Wst/Server.hs index f3cdcc7..35b3c39 100644 --- a/src/lib/Wst/Server.hs +++ b/src/lib/Wst/Server.hs @@ -24,9 +24,6 @@ import Servant.Server (hoistServer, serve) import SmartTokens.Types.PTokenDirectory (blnKey) import Wst.App (WstApp, runWstAppServant) import Wst.AppError (AppError) -import Wst.Offchain.BuildTx.ProgrammableLogic (alwaysSucceedsArgs, - fromTransferEnv, - programmableTokenAssetId) import Wst.Offchain.Endpoints.Deployment qualified as Endpoints import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query (UTxODat (uDatum)) @@ -90,9 +87,8 @@ queryBlacklistedNodes :: forall era env m. -> SerialiseAddress (C.Address C.ShelleyAddr) -> m [C.Hash C.PaymentKey] queryBlacklistedNodes _ (SerialiseAddress addr) = do - programmableBaseLogicCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) - let transferLogic = Env.mkTransferLogicEnv programmableBaseLogicCred (paymentKeyHashFromAddress addr) - getHash = + transferLogic <- Env.transferLogicForDirectory (paymentKeyHashFromAddress addr) + let getHash = either (error "deserialiseFromRawBytes failed") id . C.deserialiseFromRawBytes (C.proxyToAsType $ Proxy @(C.Hash C.PaymentKey)) . P.fromBuiltin @@ -139,11 +135,9 @@ issueProgrammableTokenEndpoint :: forall era env m. issueProgrammableTokenEndpoint IssueProgrammableTokenArgs{itaAssetName, itaQuantity, itaIssuer} = do operatorEnv <- Env.loadOperatorEnvFromAddress itaIssuer dirEnv <- asks Env.directoryEnv - - -- FIXME: Replace alwaysSucceedsArgs with blacklist monetary policy as soon as it is finished - let tokenArgs = alwaysSucceedsArgs - Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ do - TextEnvelopeJSON <$> Endpoints.issueProgrammableTokenTx tokenArgs itaAssetName itaQuantity + logic <- Env.transferLogicForDirectory (paymentKeyHashFromAddress itaIssuer) + Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer logic $ do + TextEnvelopeJSON <$> Endpoints.issueProgrammableTokenTx itaAssetName itaQuantity paymentCredentialFromAddress :: C.Address C.ShelleyAddr -> C.PaymentCredential paymentCredentialFromAddress = \case @@ -167,10 +161,9 @@ transferProgrammableTokenEndpoint :: forall era env m. transferProgrammableTokenEndpoint TransferProgrammableTokenArgs{ttaSender, ttaRecipient, ttaAssetName, ttaQuantity, ttaIssuer} = do operatorEnv <- Env.loadOperatorEnvFromAddress ttaSender dirEnv <- asks Env.directoryEnv - programmableBaseLogicCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) - let transferLogic = Env.mkTransferLogicEnv programmableBaseLogicCred (paymentKeyHashFromAddress ttaIssuer) - assetId <- programmableTokenAssetId <$> Env.getGlobalParams <*> pure (fromTransferEnv transferLogic) <*> pure ttaAssetName - Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer transferLogic $ do + logic <- Env.transferLogicForDirectory (paymentKeyHashFromAddress ttaIssuer) + assetId <- Env.programmableTokenAssetId dirEnv <$> Env.transferLogicForDirectory (paymentKeyHashFromAddress ttaIssuer) <*> pure ttaAssetName + Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer logic $ do TextEnvelopeJSON <$> Endpoints.transferSmartTokensTx assetId ttaQuantity (paymentCredentialFromAddress ttaRecipient) addToBlacklistEndpoint :: forall era env m. @@ -187,8 +180,7 @@ addToBlacklistEndpoint AddToBlacklistArgs{atbIssuer, atbBlacklistAddress} = do let badCred = paymentCredentialFromAddress atbBlacklistAddress operatorEnv <- Env.loadOperatorEnvFromAddress atbIssuer dirEnv <- asks Env.directoryEnv - programmableBaseLogicCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) - let transferLogic = Env.mkTransferLogicEnv programmableBaseLogicCred (paymentKeyHashFromAddress atbIssuer) + transferLogic <- Env.transferLogicForDirectory (paymentKeyHashFromAddress atbIssuer) Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer transferLogic $ do TextEnvelopeJSON <$> Endpoints.blacklistCredentialTx badCred @@ -206,7 +198,6 @@ seizeAssetsEndpoint SeizeAssetsArgs{saIssuer, saTarget} = do let badCred = paymentCredentialFromAddress saTarget operatorEnv <- Env.loadOperatorEnvFromAddress saIssuer dirEnv <- asks Env.directoryEnv - programmableBaseLogicCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) - let transferLogic = Env.mkTransferLogicEnv programmableBaseLogicCred (paymentKeyHashFromAddress saIssuer) + transferLogic <- Env.transferLogicForDirectory (paymentKeyHashFromAddress saIssuer) Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer transferLogic $ do TextEnvelopeJSON <$> Endpoints.seizeCredentialAssetsTx badCred diff --git a/src/lib/Wst/Server/Endpoints.hs b/src/lib/Wst/Server/Endpoints.hs deleted file mode 100644 index 8949dfd..0000000 --- a/src/lib/Wst/Server/Endpoints.hs +++ /dev/null @@ -1,31 +0,0 @@ - -{- | This module contains the endpoints of the server. --} -module Wst.Server.Endpoints ( - healthcheck, - -- * Query endpoints - queryGlobalParams, - - -- * Build tx endpoints - issueProgrammableTokens -) where - -import Cardano.Api qualified as C -import Control.Monad.Except (MonadError) -import Convex.Class (MonadUtxoQuery) -import Servant (Handler) -import Servant.API (NoContent (..)) -import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) -import Wst.AppError (AppError) -import Wst.Offchain.Query (UTxODat) -import Wst.Offchain.Query qualified as Query -import Wst.Server.Types (IssueProgrammableTokenArgs, TextEnvelopeJSON) - -healthcheck :: Handler NoContent -healthcheck = pure NoContent - -queryGlobalParams :: forall era m. (MonadUtxoQuery m, C.IsBabbageBasedEra era, MonadError (AppError era) m) => m (UTxODat era ProgrammableLogicGlobalParams) -queryGlobalParams = Query.globalParamsNode - -issueProgrammableTokens :: forall era m. IssueProgrammableTokenArgs -> m (TextEnvelopeJSON (C.Tx era)) -issueProgrammableTokens = undefined diff --git a/src/test/unit/Wst/Test/UnitTest.hs b/src/test/unit/Wst/Test/UnitTest.hs index 73a5f2c..708adb3 100644 --- a/src/test/unit/Wst/Test/UnitTest.hs +++ b/src/test/unit/Wst/Test/UnitTest.hs @@ -6,124 +6,112 @@ module Wst.Test.UnitTest( import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C import Cardano.Ledger.Api qualified as Ledger -import Cardano.Ledger.Plutus.ExUnits qualified as Ledger +import Cardano.Ledger.Plutus.ExUnits (ExUnits (..)) import Cardano.Ledger.Shelley.TxCert qualified as TxCert -import Control.Exception (try) -import Control.Lens (set, (%~), (&), (^.)) +import Control.Lens ((%~), (&), (^.)) import Control.Monad (void) -import Control.Monad.Reader (asks) -import Control.Monad.Reader.Class (MonadReader) +import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT), asks) import Convex.BuildTx (MonadBuildTx, addCertificate) import Convex.BuildTx qualified as BuildTx import Convex.Class (MonadBlockchain (queryProtocolParameters, sendTx), MonadMockchain, MonadUtxoQuery) import Convex.CoinSelection (ChangeOutputPosition (TrailingChange)) -import Convex.MockChain +import Convex.MockChain (MockchainT) import Convex.MockChain.CoinSelection (tryBalanceAndSubmit) import Convex.MockChain.Defaults qualified as Defaults -import Convex.MockChain.Utils (mockchainFails, mockchainSucceeds) +import Convex.MockChain.Utils (mockchainFails, mockchainSucceedsWith) import Convex.NodeParams (NodeParams, ledgerProtocolParameters, protocolParameters) import Convex.Utils (failOnError) import Convex.Wallet.MockWallet qualified as Wallet import Convex.Wallet.Operator (signTxOperator) +import Convex.Wallet.Operator qualified as Operator import Data.List (isPrefixOf) -import Data.Word (Word32) +import Data.String (IsString (..)) import GHC.Exception (SomeException, throw) +import SmartTokens.Core.Scripts (ScriptTarget (Debug, Production)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase) import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..)) -import Wst.Offchain.BuildTx.ProgrammableLogic (alwaysSucceedsArgs) import Wst.Offchain.Endpoints.Deployment qualified as Endpoints +import Wst.Offchain.Env (DirectoryScriptRoot) import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query qualified as Query import Wst.Offchain.Scripts qualified as Scripts import Wst.Test.Env (admin, asAdmin, asWallet, user) -testTxSize :: Word32 -testTxSize = 16384 - -testNodeParams :: NodeParams C.ConwayEra -testNodeParams = - -- restrict script bugdet to current value on mainnet - let newExUnits = Ledger.ExUnits {Ledger.exUnitsSteps = 10_000_000_000, Ledger.exUnitsMem = 14_000_000} - npsTx = Defaults.nodeParams & set (ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxSizeL) testTxSize - in npsTx & set (ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxExUnitsL) newExUnits - --- | Run the 'Mockchain' action with modified node parameters to allow larger-than-usual --- transactions. This is useful for showing debug output from the scripts and fail if there is an error -mockchainSucceedsWithLargeTx :: MockchainIO C.ConwayEra a -> Assertion -mockchainSucceedsWithLargeTx action = - let params' = testNodeParams & ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxSizeL %~ (*10) - in try @SomeException (runMockchain0IOWith Wallet.initialUTxOs params' action) >>= \case - Right{} -> pure () - Left err -> fail (show err) - tests :: TestTree tests = testGroup "unit tests" - [ testCase "deploy directory and global params" (mockchainSucceedsWithLargeTx deployDirectorySet) - , testCase "insert directory node" (mockchainSucceeds insertDirectoryNode) - , testGroup "issue programmable tokens" - [ testCase "always succeeds validator" (mockchainSucceeds issueAlwaysSucceedsValidator) - , testCase "smart token issuance" (mockchainSucceeds issueSmartTokensScenario) - , testCase "smart token transfer" (mockchainSucceeds transferSmartTokens) - , testCase "blacklist credential" (mockchainSucceeds (void blacklistCredential)) - , testCase "blacklisted transfer" (mockchainFails blacklistTransfer assertBlacklistedAddressException) - , testCase "seize user output" (mockchainSucceeds seizeUserOutput) - ] + [ scriptTargetTests Debug + , scriptTargetTests Production ] -deployDirectorySet :: (MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => m C.TxIn -deployDirectorySet = failOnError $ Env.withEnv $ asAdmin @C.ConwayEra $ do - (tx, txI) <- Endpoints.deployTx - void $ sendTx $ signTxOperator admin tx - Env.withDirectoryFor txI $ do - Query.registryNodes @C.ConwayEra - >>= void . expectSingleton "registry output" - void $ Query.globalParamsNode @C.ConwayEra - pure txI - -insertDirectoryNode :: (MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => m () -insertDirectoryNode = failOnError $ Env.withEnv $ do - txI <- deployDirectorySet - asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ do +scriptTargetTests :: ScriptTarget -> TestTree +scriptTargetTests target = + testGroup (fromString $ show target) + [ testCase "deploy directory and global params" (mockchainSucceedsWithTarget target deployDirectorySet) + , testCase "insert directory node" (mockchainSucceedsWithTarget target $ deployDirectorySet >>= insertDirectoryNode) + , testGroup "issue programmable tokens" + [ testCase "always succeeds validator" (mockchainSucceedsWithTarget target $ deployDirectorySet >>= issueAlwaysSucceedsValidator) + , testCase "smart token issuance" (mockchainSucceedsWithTarget target issueSmartTokensScenario) + , testCase "smart token transfer" (mockchainSucceedsWithTarget target $ deployDirectorySet >>= transferSmartTokens) + , testCase "blacklist credential" (mockchainSucceedsWithTarget target $ void $ deployDirectorySet >>= blacklistCredential) + , testCase "blacklisted transfer" (mockchainFails blacklistTransfer assertBlacklistedAddressException) + , testCase "seize user output" (mockchainSucceedsWithTarget target $ deployDirectorySet >>= seizeUserOutput) + ] + ] + +deployDirectorySet :: (MonadReader ScriptTarget m, MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => m DirectoryScriptRoot +deployDirectorySet = do + target <- ask + failOnError $ Env.withEnv $ asAdmin @C.ConwayEra $ do + (tx, scriptRoot) <- Endpoints.deployTx target + void $ sendTx $ signTxOperator admin tx + Env.withDirectoryFor scriptRoot $ do + Query.registryNodes @C.ConwayEra + >>= void . expectSingleton "registry output" + void $ Query.globalParamsNode @C.ConwayEra + pure scriptRoot + +insertDirectoryNode :: (MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => DirectoryScriptRoot -> m () +insertDirectoryNode scriptRoot = failOnError $ Env.withEnv $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ do Endpoints.insertNodeTx dummyNodeArgs >>= void . sendTx . signTxOperator admin Query.registryNodes @C.ConwayEra >>= void . expectN 2 "registry outputs" {-| Issue some tokens with the "always succeeds" validator -} -issueAlwaysSucceedsValidator :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () -issueAlwaysSucceedsValidator = failOnError $ Env.withEnv $ do +issueAlwaysSucceedsValidator :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => DirectoryScriptRoot -> m () +issueAlwaysSucceedsValidator scriptRoot = failOnError $ Env.withEnv $ do -- Register the stake validator -- Oddly, the tests passes even if we don't do this. -- But I'll leave it in because it seems right. registerAlwaysSucceedsStakingCert - txI <- deployDirectorySet - asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ do - Endpoints.issueProgrammableTokenTx alwaysSucceedsArgs "dummy asset" 100 + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransfer (Env.alwaysSucceedsTransferLogic Production) $ do + Endpoints.issueProgrammableTokenTx "dummy asset" 100 >>= void . sendTx . signTxOperator admin Query.registryNodes @C.ConwayEra >>= void . expectN 2 "registry outputs" Query.programmableLogicOutputs @C.ConwayEra >>= void . expectN 1 "programmable logic outputs" -issueSmartTokensScenario :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m C.AssetId +issueSmartTokensScenario :: (MonadReader ScriptTarget m, MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m C.AssetId issueSmartTokensScenario = deployDirectorySet >>= issueTransferLogicProgrammableToken {-| Issue some tokens with the smart stabelcoin transfer logic validator -} -issueTransferLogicProgrammableToken :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => C.TxIn -> m C.AssetId -issueTransferLogicProgrammableToken txI = failOnError $ Env.withEnv $ do +issueTransferLogicProgrammableToken :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => DirectoryScriptRoot -> m C.AssetId +issueTransferLogicProgrammableToken scriptRoot = failOnError $ Env.withEnv $ do - asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) -- register programmable global stake script void $ registerTransferScripts opPkh - asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) (balTx, aid) <- Endpoints.issueSmartTokensTx "dummy asset" 100 (C.PaymentCredentialByKey opPkh) @@ -137,20 +125,19 @@ issueTransferLogicProgrammableToken txI = failOnError $ Env.withEnv $ do {-| Issue some tokens with the smart stabelcoin transfer logic validator -} -transferSmartTokens :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () -transferSmartTokens = failOnError $ Env.withEnv $ do +transferSmartTokens :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => DirectoryScriptRoot -> m () +transferSmartTokens scriptRoot = failOnError $ Env.withEnv $ do userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv) - txI <- deployDirectorySet - asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do Endpoints.deployBlacklistTx >>= void . sendTx . signTxOperator admin Query.blacklistNodes @C.ConwayEra >>= void . expectSingleton "blacklist output" - aid <- issueTransferLogicProgrammableToken txI + aid <- issueTransferLogicProgrammableToken scriptRoot - asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) Endpoints.transferSmartTokensTx aid 80 (C.PaymentCredentialByKey userPkh) @@ -163,20 +150,18 @@ transferSmartTokens = failOnError $ Env.withEnv $ do Query.userProgrammableOutputs (C.PaymentCredentialByKey opPkh) >>= void . expectN 1 "user programmable outputs" -blacklistCredential :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m C.PaymentCredential -blacklistCredential = failOnError $ Env.withEnv $ do +blacklistCredential :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => DirectoryScriptRoot -> m C.PaymentCredential +blacklistCredential scriptRoot = failOnError $ Env.withEnv $ do userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv) let paymentCred = C.PaymentCredentialByKey userPkh - txIn <- deployDirectorySet - - asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do Endpoints.deployBlacklistTx >>= void . sendTx . signTxOperator admin Query.blacklistNodes @C.ConwayEra >>= void . expectSingleton "blacklist output" - asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do Endpoints.blacklistCredentialTx paymentCred >>= void . sendTx . signTxOperator admin @@ -187,47 +172,44 @@ blacklistCredential = failOnError $ Env.withEnv $ do blacklistTransfer :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () blacklistTransfer = failOnError $ Env.withEnv $ do + scriptRoot <- runReaderT deployDirectorySet Production userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv) let userPaymentCred = C.PaymentCredentialByKey userPkh - txIn <- deployDirectorySet - aid <- issueTransferLogicProgrammableToken txIn + aid <- issueTransferLogicProgrammableToken scriptRoot - asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do Endpoints.deployBlacklistTx >>= void . sendTx . signTxOperator admin - opPkh <- asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + opPkh <- asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) Endpoints.transferSmartTokensTx aid 50 (C.PaymentCredentialByKey userPkh) >>= void . sendTx . signTxOperator admin pure opPkh - progLogicCred <- asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do - cred <- asks Env.directoryEnv - pure $ Env.programmableLogicBaseCredential cred + transferLogic <- Env.withDirectoryFor scriptRoot $ Env.transferLogicForDirectory (C.verificationKeyHash . Operator.verificationKey . Operator.oPaymentKey $ admin) - asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do Endpoints.blacklistCredentialTx userPaymentCred >>= void . sendTx . signTxOperator admin - asWallet Wallet.w2 $ Env.withDirectoryFor txIn $ Env.withTransferFor progLogicCred opPkh $ do + asWallet Wallet.w2 $ Env.withDirectoryFor scriptRoot $ Env.withTransfer transferLogic $ do Endpoints.transferSmartTokensTx aid 30 (C.PaymentCredentialByKey opPkh) >>= void . sendTx . signTxOperator (user Wallet.w2) -seizeUserOutput :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () -seizeUserOutput = failOnError $ Env.withEnv $ do +seizeUserOutput :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => DirectoryScriptRoot -> m () +seizeUserOutput scriptRoot = failOnError $ Env.withEnv $ do userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv) let userPaymentCred = C.PaymentCredentialByKey userPkh - txIn <- deployDirectorySet - aid <- issueTransferLogicProgrammableToken txIn + aid <- issueTransferLogicProgrammableToken scriptRoot - asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do Endpoints.deployBlacklistTx >>= void . sendTx . signTxOperator admin - asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do Endpoints.transferSmartTokensTx aid 50 (C.PaymentCredentialByKey userPkh) >>= void . sendTx . signTxOperator admin Query.programmableLogicOutputs @C.ConwayEra @@ -235,7 +217,7 @@ seizeUserOutput = failOnError $ Env.withEnv $ do Query.userProgrammableOutputs (C.PaymentCredentialByKey userPkh) >>= void . expectN 1 "user programmable outputs" - asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) Endpoints.seizeCredentialAssetsTx userPaymentCred >>= void . sendTx . signTxOperator admin @@ -260,11 +242,11 @@ dummyNodeArgs = registerAlwaysSucceedsStakingCert :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () registerAlwaysSucceedsStakingCert = failOnError $ do pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters - let script = C.PlutusScript C.plutusScriptVersion Scripts.alwaysSucceedsScript + let script = C.PlutusScript C.plutusScriptVersion $ Scripts.alwaysSucceedsScript Production hsh = C.hashScript script cred = C.StakeCredentialByScript hsh txBody <- BuildTx.execBuildTxT $ do - BuildTx.addStakeScriptWitness cred Scripts.alwaysSucceedsScript () + BuildTx.addStakeScriptWitness cred (Scripts.alwaysSucceedsScript Production) () BuildTx.addConwayStakeCredentialRegistrationCertificate cred (pp ^. Ledger.ppKeyDepositL) void (tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange []) @@ -325,3 +307,20 @@ assertBlacklistedAddressException :: SomeException -> Assertion assertBlacklistedAddressException ex | "user error (TransferBlacklistedCredential (PubKeyCredential" `isPrefixOf` show ex = pure () | otherwise = throw ex + +nodeParamsFor :: ScriptTarget -> NodeParams C.ConwayEra +nodeParamsFor = \case + -- Run the 'Mockchain' action with modified node parameters to allow larger-than-usual + -- transactions. This is useful for showing debug output from the scripts and fail if there is an error + Debug -> + let tenX ExUnits{exUnitsSteps=steps, exUnitsMem=mem} = + ExUnits{exUnitsSteps = 10 * steps, exUnitsMem = 10 * mem} + in Defaults.nodeParams + & ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxSizeL %~ (*10) + & ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxExUnitsL %~ tenX + Production -> Defaults.nodeParams + +mockchainSucceedsWithTarget :: ScriptTarget -> ReaderT ScriptTarget (MockchainT C.ConwayEra IO) a -> Assertion +mockchainSucceedsWithTarget target = + mockchainSucceedsWith (nodeParamsFor target) . flip runReaderT target + diff --git a/src/wst-poc.cabal b/src/wst-poc.cabal index f6a840b..e3eba06 100644 --- a/src/wst-poc.cabal +++ b/src/wst-poc.cabal @@ -84,7 +84,6 @@ library Wst.Offchain.Query Wst.Offchain.Scripts Wst.Server - Wst.Server.Endpoints Wst.Server.Types hs-source-dirs: lib