diff --git a/src/lib/Wst/Offchain/Endpoints/Deployment.hs b/src/lib/Wst/Offchain/Endpoints/Deployment.hs index a81ca02..a0476ab 100644 --- a/src/lib/Wst/Offchain/Endpoints/Deployment.hs +++ b/src/lib/Wst/Offchain/Endpoints/Deployment.hs @@ -1,15 +1,6 @@ -{-# LANGUAGE NamedFieldPuns #-} - {-| Deploy the directory and global params -} module Wst.Offchain.Endpoints.Deployment( - DeploymentScripts(..), - deploymentScripts, - programmableLogicStakeCredential, - programmableLogicBaseCredential, - directoryNodePolicyId, - protocolParamsPolicyId, - globalParams, deployTx ) where @@ -31,62 +22,14 @@ import Wst.Offchain.Scripts (directoryNodeMintingScript, programmableLogicGlobalScript, protocolParamsMintingScript, scriptPolicyIdV3) -data DeploymentScripts = - DeploymentScripts - { dsTxIn :: C.TxIn -- ^ The 'txIn' that we spend when deploying the protocol params and directory set - , dsDirectoryMintingScript :: PlutusScript PlutusScriptV3 - , dsDirectorySpendingScript :: PlutusScript PlutusScriptV3 - , dsProtocolParamsMintingScript :: PlutusScript PlutusScriptV3 - , dsProgrammableLogicBaseScript :: PlutusScript PlutusScriptV3 - , dsProgrammableLogicGlobalScript :: PlutusScript PlutusScriptV3 - } - -deploymentScripts :: C.TxIn -> DeploymentScripts -deploymentScripts 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 (directoryNodePolicyId result) -- Parameterized by the CS holding protocol params datum - result = DeploymentScripts - { dsTxIn - , dsDirectoryMintingScript - , dsProtocolParamsMintingScript - , dsProgrammableLogicBaseScript - , dsProgrammableLogicGlobalScript - , dsDirectorySpendingScript - } - in result - -programmableLogicStakeCredential :: DeploymentScripts -> C.StakeCredential -programmableLogicStakeCredential = - C.StakeCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicGlobalScript - -programmableLogicBaseCredential :: DeploymentScripts -> C.PaymentCredential -programmableLogicBaseCredential = - C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicBaseScript - -directoryNodePolicyId :: DeploymentScripts -> C.PolicyId -directoryNodePolicyId = scriptPolicyIdV3 . dsDirectoryMintingScript - -protocolParamsPolicyId :: DeploymentScripts -> C.PolicyId -protocolParamsPolicyId = scriptPolicyIdV3 . dsProtocolParamsMintingScript - -globalParams :: DeploymentScripts -> ProgrammableLogicGlobalParams -globalParams scripts = - ProgrammableLogicGlobalParams - { directoryNodeCS = transPolicyId (directoryNodePolicyId scripts) - , progLogicCred = transCredential (programmableLogicBaseCredential scripts) -- its the script hash of the programmable base spending script - } - {-| 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 (OperatorEnv era) m, MonadBlockchain era m, MonadError (BuildTxError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era) => m (C.Tx era, C.TxIn) deployTx = do (txi, _) <- Env.selectOperatorOutput - let scripts = deploymentScripts txi + let scripts = Env.directoryEnv txi (tx, _) <- Env.balanceTxEnv $ do - mintProtocolParams (globalParams scripts) txi - initDirectorySet (protocolParamsPolicyId scripts) txi + mintProtocolParams (Env.globalParams scripts) txi + initDirectorySet (Env.protocolParamsPolicyId scripts) txi pure (Convex.CoinSelection.signBalancedTxBody [] tx, txi) diff --git a/src/lib/Wst/Offchain/Endpoints/Query.hs b/src/lib/Wst/Offchain/Endpoints/Query.hs index f1fd3fd..c252a14 100644 --- a/src/lib/Wst/Offchain/Endpoints/Query.hs +++ b/src/lib/Wst/Offchain/Endpoints/Query.hs @@ -20,7 +20,7 @@ import Data.Maybe (mapMaybe) import PlutusTx qualified import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) -import Wst.Offchain.Endpoints.Deployment (DeploymentScripts (dsDirectorySpendingScript)) +import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript)) import Wst.Offchain.Scripts (protocolParamsSpendingScript) -- TODO: We should probably filter the UTxOs to check that they have the correct NFTs @@ -36,14 +36,14 @@ data UTxO era a = {-| Find all UTxOs that make up the registry -} -registryNodes :: forall era m. (MonadReader DeploymentScripts m, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxO era DirectorySetNode] +registryNodes :: forall era m. (MonadReader DirectoryEnv m, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxO era DirectorySetNode] registryNodes = asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsDirectorySpendingScript) >>= fmap (extractUTxO @era) . utxosByPaymentCredential {-| Find the UTxO with the global params -} -globalParamsNode :: forall era m. (MonadReader DeploymentScripts m, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxO era ProgrammableLogicGlobalParams] +globalParamsNode :: forall era m. (MonadReader DirectoryEnv m, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxO era ProgrammableLogicGlobalParams] globalParamsNode = do let cred = C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 $ protocolParamsSpendingScript fmap (extractUTxO @era) (utxosByPaymentCredential cred) diff --git a/src/lib/Wst/Offchain/Env.hs b/src/lib/Wst/Offchain/Env.hs index b3dde92..e6bea98 100644 --- a/src/lib/Wst/Offchain/Env.hs +++ b/src/lib/Wst/Offchain/Env.hs @@ -7,13 +7,23 @@ module Wst.Offchain.Env( loadEnv, BuildTxError(..), - -- ** Using the environment + -- ** Using the operator environment selectOperatorOutput, - balanceTxEnv + balanceTxEnv, + + -- * Directory environment + DirectoryEnv(..), + directoryEnv, + programmableLogicStakeCredential, + programmableLogicBaseCredential, + directoryNodePolicyId, + protocolParamsPolicyId, + globalParams ) where -import Cardano.Api (UTxO) +import Cardano.Api (PlutusScript, PlutusScriptV3, UTxO) import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, ask, asks) import Convex.BuildTx (BuildTxT) @@ -21,6 +31,7 @@ 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.Utils (mapError) import Convex.Utxos (BalanceChanges) import Convex.Utxos qualified as Utxos @@ -29,6 +40,12 @@ import Convex.Wallet.Operator (Operator (..), PaymentExtendedKey (..), operatorReturnOutput) import Data.Map qualified as Map import Data.Maybe (listToMaybe) +import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams (..)) +import Wst.Offchain.Scripts (directoryNodeMintingScript, + directoryNodeSpendingScript, + programmableLogicBaseScript, + programmableLogicGlobalScript, + protocolParamsMintingScript, scriptPolicyIdV3) {-| Information needed to build transactions -} @@ -71,3 +88,54 @@ balanceTxEnv btx = do txBuilder <- BuildTx.execBuildTxT $ btx >> BuildTx.setMinAdaDepositAll params output <- operatorReturnOutput bteOperator mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange) + +{-| Scripts relatd to managing the token policy directory. +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 + , dsDirectoryMintingScript :: PlutusScript PlutusScriptV3 + , dsDirectorySpendingScript :: PlutusScript PlutusScriptV3 + , dsProtocolParamsMintingScript :: PlutusScript PlutusScriptV3 + , dsProgrammableLogicBaseScript :: PlutusScript PlutusScriptV3 + , dsProgrammableLogicGlobalScript :: PlutusScript PlutusScriptV3 + } + +directoryEnv :: C.TxIn -> DirectoryEnv +directoryEnv 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 (directoryNodePolicyId result) -- Parameterized by the CS holding protocol params datum + result = DirectoryEnv + { dsTxIn + , dsDirectoryMintingScript + , dsProtocolParamsMintingScript + , dsProgrammableLogicBaseScript + , dsProgrammableLogicGlobalScript + , dsDirectorySpendingScript + } + in result + +programmableLogicStakeCredential :: DirectoryEnv -> C.StakeCredential +programmableLogicStakeCredential = + C.StakeCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicGlobalScript + +programmableLogicBaseCredential :: DirectoryEnv -> C.PaymentCredential +programmableLogicBaseCredential = + C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicBaseScript + +directoryNodePolicyId :: DirectoryEnv -> C.PolicyId +directoryNodePolicyId = scriptPolicyIdV3 . dsDirectoryMintingScript + +protocolParamsPolicyId :: DirectoryEnv -> C.PolicyId +protocolParamsPolicyId = scriptPolicyIdV3 . dsProtocolParamsMintingScript + +globalParams :: DirectoryEnv -> ProgrammableLogicGlobalParams +globalParams scripts = + ProgrammableLogicGlobalParams + { directoryNodeCS = transPolicyId (directoryNodePolicyId scripts) + , progLogicCred = transCredential (programmableLogicBaseCredential scripts) -- its the script hash of the programmable base spending script + } diff --git a/src/test/Wst/Test/UnitTest.hs b/src/test/Wst/Test/UnitTest.hs index f21f7cd..a97b918 100644 --- a/src/test/Wst/Test/UnitTest.hs +++ b/src/test/Wst/Test/UnitTest.hs @@ -14,6 +14,7 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Wst.Offchain.Endpoints.Deployment qualified as Endpoints import Wst.Offchain.Endpoints.Query qualified as Query +import Wst.Offchain.Env qualified as Env import Wst.Test.Env (admin, asAdmin) tests :: TestTree @@ -25,7 +26,7 @@ deployDirectorySet :: (MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFai deployDirectorySet = failOnError $ asAdmin @C.ConwayEra $ do (tx, txI) <- Endpoints.deployTx void $ sendTx $ signTxOperator admin tx - flip runReaderT (Endpoints.deploymentScripts txI) $ do + flip runReaderT (Env.directoryEnv txI) $ do Query.registryNodes @C.ConwayEra >>= void . expectSingleton "registry output" Query.globalParamsNode @C.ConwayEra