Use classes for environment bits

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
 

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

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)

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)

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
+
+