From 46d968a9e3009abd11440ccf2041d1a4a3ec9742 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Thu, 19 Dec 2024 19:12:47 +0100 Subject: [PATCH] Use classes for environment bits --- src/lib/Wst/Offchain/BuildTx/DirectorySet.hs | 8 ++- .../Wst/Offchain/BuildTx/ProtocolParams.hs | 10 ++- src/lib/Wst/Offchain/Endpoints/Deployment.hs | 23 +++---- src/lib/Wst/Offchain/Endpoints/Query.hs | 9 +-- src/lib/Wst/Offchain/Env.hs | 63 ++++++++++++++++--- 5 files changed, 78 insertions(+), 35 deletions(-) diff --git a/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs b/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs index f54f090..36459ec 100644 --- a/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs +++ b/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs @@ -13,6 +13,7 @@ module Wst.Offchain.BuildTx.DirectorySet ( import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C import Control.Lens (over) +import Control.Monad.Reader (MonadReader, asks) import Convex.BuildTx (MonadBuildTx, addBtx, mintPlutus) import Convex.CardanoApi.Lenses qualified as L import Convex.Class (MonadBlockchain, queryNetworkId) @@ -30,6 +31,7 @@ import SmartTokens.CodeLens (_printTerm) import SmartTokens.LinkedList.MintDirectory (DirectoryNodeAction (..)) import SmartTokens.Types.Constants (directoryNodeToken) import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) +import Wst.Offchain.Env qualified as Env import Wst.Offchain.Scripts (directoryNodeMintingScript, directoryNodeSpendingScript, scriptPolicyIdV3) @@ -49,8 +51,10 @@ initialNode = DirectorySetNode , issuerLogicScript = PubKeyCredential "" } -initDirectorySet :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.PolicyId -> C.TxIn -> m () -initDirectorySet paramsPolicyId txIn = Utils.inBabbage @era $ do +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 diff --git a/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs b/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs index 61740f4..79efd70 100644 --- a/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs +++ b/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs @@ -5,6 +5,7 @@ module Wst.Offchain.BuildTx.ProtocolParams ( import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C +import Control.Monad.Reader (MonadReader, asks) import Convex.BuildTx (MonadBuildTx, mintPlutus, prependTxOut, spendPublicKeyOutput) import Convex.Class (MonadBlockchain (..)) @@ -14,16 +15,19 @@ import Convex.Utils qualified as Utils import GHC.Exts (IsList (..)) import SmartTokens.Types.Constants (protocolParamsToken) import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) +import Wst.Offchain.Env qualified as Env import Wst.Offchain.Scripts (protocolParamsMintingScript, protocolParamsSpendingScript, scriptPolicyIdV3) protocolParamsTokenC :: C.AssetName protocolParamsTokenC = unTransAssetName protocolParamsToken -{-| Mint the protocol parameters NFT. Returns NFT's policy ID. +{-| Mint the protocol parameters NFT and place it in the output locked by 'protocolParamsSpendingScript' -} -mintProtocolParams :: forall era m. (C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => ProgrammableLogicGlobalParams -> C.TxIn -> m () -mintProtocolParams params txIn = Utils.inBabbage @era $ do +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) + params <- asks (Env.globalParams . Env.directoryEnv) netId <- queryNetworkId let mintingScript = protocolParamsMintingScript txIn diff --git a/src/lib/Wst/Offchain/Endpoints/Deployment.hs b/src/lib/Wst/Offchain/Endpoints/Deployment.hs index a0476ab..94cf6ec 100644 --- a/src/lib/Wst/Offchain/Endpoints/Deployment.hs +++ b/src/lib/Wst/Offchain/Endpoints/Deployment.hs @@ -4,32 +4,23 @@ module Wst.Offchain.Endpoints.Deployment( deployTx ) where -import Cardano.Api (PlutusScript, PlutusScriptV3) import Cardano.Api.Shelley qualified as C import Control.Monad.Except (MonadError) import Control.Monad.Reader (MonadReader) import Convex.Class (MonadBlockchain) import Convex.CoinSelection qualified -import Convex.PlutusLedger.V1 (transCredential, transPolicyId) -import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams (..)) -import Wst.Offchain.BuildTx.DirectorySet (initDirectorySet) -import Wst.Offchain.BuildTx.ProtocolParams (mintProtocolParams) -import Wst.Offchain.Env (BuildTxError, OperatorEnv) +import Wst.Offchain.BuildTx.DirectorySet qualified as BuildTx +import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx +import Wst.Offchain.Env (BuildTxError) import Wst.Offchain.Env qualified as Env -import Wst.Offchain.Scripts (directoryNodeMintingScript, - directoryNodeSpendingScript, - programmableLogicBaseScript, - programmableLogicGlobalScript, - protocolParamsMintingScript, scriptPolicyIdV3) {-| 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 :: (MonadReader env m, Env.HasOperatorEnv era env, 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 = Env.directoryEnv txi - (tx, _) <- Env.balanceTxEnv $ do - mintProtocolParams (Env.globalParams scripts) txi - initDirectorySet (Env.protocolParamsPolicyId scripts) txi + (tx, _) <- Env.withDirectoryFor txi + $ Env.balanceTxEnv + $ BuildTx.mintProtocolParams >> BuildTx.initDirectorySet 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 c252a14..addcab2 100644 --- a/src/lib/Wst/Offchain/Endpoints/Query.hs +++ b/src/lib/Wst/Offchain/Endpoints/Query.hs @@ -20,7 +20,8 @@ import Data.Maybe (mapMaybe) import PlutusTx qualified import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) -import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript)) +import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript), + HasDirectoryEnv (directoryEnv)) import Wst.Offchain.Scripts (protocolParamsSpendingScript) -- TODO: We should probably filter the UTxOs to check that they have the correct NFTs @@ -36,14 +37,14 @@ data UTxO era a = {-| Find all UTxOs that make up the registry -} -registryNodes :: forall era m. (MonadReader DirectoryEnv m, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxO era DirectorySetNode] +registryNodes :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxO era DirectorySetNode] registryNodes = - asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsDirectorySpendingScript) + asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsDirectorySpendingScript . directoryEnv) >>= fmap (extractUTxO @era) . utxosByPaymentCredential {-| Find the UTxO with the global params -} -globalParamsNode :: forall era m. (MonadReader DirectoryEnv m, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxO era ProgrammableLogicGlobalParams] +globalParamsNode :: forall era 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 e6bea98..bb347a9 100644 --- a/src/lib/Wst/Offchain/Env.hs +++ b/src/lib/Wst/Offchain/Env.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE NamedFieldPuns #-} {-| Transaction building environment -} module Wst.Offchain.Env( -- * Operator environment + HasOperatorEnv(..), OperatorEnv(..), loadEnv, BuildTxError(..), @@ -12,20 +15,25 @@ module Wst.Offchain.Env( balanceTxEnv, -- * Directory environment + HasDirectoryEnv(..), DirectoryEnv(..), - directoryEnv, + mkDirectoryEnv, programmableLogicStakeCredential, programmableLogicBaseCredential, directoryNodePolicyId, protocolParamsPolicyId, - globalParams + globalParams, + + -- * Combined environment + CombinedEnv(..), + withDirectoryFor ) where 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 Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) import Convex.BuildTx (BuildTxT) import Convex.BuildTx qualified as BuildTx import Convex.Class (MonadBlockchain, MonadUtxoQuery (..), @@ -47,6 +55,14 @@ import Wst.Offchain.Scripts (directoryNodeMintingScript, programmableLogicGlobalScript, protocolParamsMintingScript, scriptPolicyIdV3) +{-| Environments that have an 'OperatorEnv' +-} +class HasOperatorEnv era e | e -> era where + operatorEnv :: e -> OperatorEnv era + +instance HasOperatorEnv era (OperatorEnv era) where + operatorEnv = id + {-| Information needed to build transactions -} data OperatorEnv era = @@ -74,21 +90,27 @@ data BuildTxError era = {-| Select an output owned by the operator -} -selectOperatorOutput :: (MonadReader (OperatorEnv era) m, MonadError (BuildTxError era) m) => m (C.TxIn, C.TxOut C.CtxUTxO era) -selectOperatorOutput = asks (listToMaybe . Map.toList . C.unUTxO . bteOperatorUtxos) >>= \case +selectOperatorOutput :: (MonadReader env m, HasOperatorEnv era env, MonadError (BuildTxError era) m) => m (C.TxIn, C.TxOut C.CtxUTxO era) +selectOperatorOutput = asks (listToMaybe . Map.toList . C.unUTxO . bteOperatorUtxos . operatorEnv) >>= \case Nothing -> throwError OperatorNoUTxOs Just k -> pure k {-| Balance a transaction using the operator's funds and return output -} -balanceTxEnv :: forall era a m. (MonadBlockchain era m, MonadReader (OperatorEnv era) m, MonadError (BuildTxError era) m, C.IsBabbageBasedEra era) => BuildTxT era m a -> m (C.BalancedTxBody era, BalanceChanges) +balanceTxEnv :: forall era env a m. (MonadBlockchain era m, MonadReader env m, HasOperatorEnv era env, MonadError (BuildTxError era) m, C.IsBabbageBasedEra era) => BuildTxT era m a -> m (C.BalancedTxBody era, BalanceChanges) balanceTxEnv btx = do - OperatorEnv{bteOperatorUtxos, bteOperator} <- ask + OperatorEnv{bteOperatorUtxos, bteOperator} <- asks operatorEnv params <- queryProtocolParameters txBuilder <- BuildTx.execBuildTxT $ btx >> BuildTx.setMinAdaDepositAll params output <- operatorReturnOutput bteOperator mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange) +class HasDirectoryEnv e where + directoryEnv :: e -> DirectoryEnv + +instance HasDirectoryEnv DirectoryEnv where + directoryEnv = id + {-| Scripts relatd to managing the token policy directory. All of the scripts and their hashes are determined by the 'TxIn'. -} @@ -102,8 +124,8 @@ data DirectoryEnv = , dsProgrammableLogicGlobalScript :: PlutusScript PlutusScriptV3 } -directoryEnv :: C.TxIn -> DirectoryEnv -directoryEnv dsTxIn = +mkDirectoryEnv :: C.TxIn -> DirectoryEnv +mkDirectoryEnv dsTxIn = let dsDirectoryMintingScript = directoryNodeMintingScript dsTxIn dsProtocolParamsMintingScript = protocolParamsMintingScript dsTxIn dsDirectorySpendingScript = directoryNodeSpendingScript (protocolParamsPolicyId result) @@ -139,3 +161,24 @@ globalParams scripts = { directoryNodeCS = transPolicyId (directoryNodePolicyId scripts) , progLogicCred = transCredential (programmableLogicBaseCredential scripts) -- its the script hash of the programmable base spending script } + +data CombinedEnv era = + CombinedEnv + { ceOperator :: OperatorEnv era + , ceDirectory :: DirectoryEnv + } + +instance HasOperatorEnv era (CombinedEnv era) where + operatorEnv = ceOperator + +instance HasDirectoryEnv (CombinedEnv era) where + directoryEnv = ceDirectory + +{-| Add a 'DirectoryEnv' to the environment +-} +withDirectoryFor :: (MonadReader env m, HasOperatorEnv era env) => C.TxIn -> ReaderT (CombinedEnv era) m a -> m a +withDirectoryFor txi action = do + asks (CombinedEnv . operatorEnv) <*> pure (mkDirectoryEnv txi) + >>= runReaderT action + +