Use Env in DirectorySet, move Query module around

cabal.project

@@ -42,7 +42,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/j-mueller/sc-tools
-  tag: a1bb7958b5a2d1cfde27daec360822e07513bd2b
+  tag: 956eb259e22d5a73fa5f67bc8aceec5df144d170
   subdir:
     src/devnet
     src/coin-selection

nix/project.nix

@@ -2,7 +2,7 @@
 
 let
   sha256map = {
-    "https://github.com/j-mueller/sc-tools"."a1bb7958b5a2d1cfde27daec360822e07513bd2b" = "sha256-nhlXl/WCQDq3o9gwFRFu0FsOtySDZBjXKmkUHGxXSyI=";
+    "https://github.com/j-mueller/sc-tools"."956eb259e22d5a73fa5f67bc8aceec5df144d170" = "sha256-nhlXl/WCQDq3o9gwFRFu0FsOtySDZBjXKmkUHGxXSyI=";
     "https://github.com/colll78/plutarch-plutus"."b2379767c7f1c70acf28206bf922f128adc02f28" = "sha256-mhuW2CHxnc6FDWuMcjW/51PKuPOdYc4yxz+W5RmlQew=";
     "https://github.com/input-output-hk/catalyst-onchain-libs"."650a3435f8efbd4bf36e58768fac266ba5beede4" = "sha256-NUh+l97+eO27Ppd8Bx0yMl0E5EV+p7+7GuFun1B8gRc=";
   };

src/lib/Wst/Offchain/BuildTx/DirectorySet.hs

@@ -78,9 +78,11 @@ initDirectorySet = Utils.inBabbage @era $ do
 
   addBtx (over L.txOuts (output :))
 
-insertDirectoryNode :: forall era m ctx. (C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => C.PolicyId -> C.TxIn -> (C.TxIn, C.TxOut ctx era) -> (CurrencySymbol, C.StakeCredential, C.StakeCredential) -> m ()
-insertDirectoryNode paramsPolicyId initialTxIn (_, firstTxOut) (newKey, transferLogic, issuerLogic) = Utils.inBabbage @era $ do
+insertDirectoryNode :: forall era env m ctx. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => (C.TxIn, C.TxOut ctx era) -> (CurrencySymbol, C.StakeCredential, C.StakeCredential) -> m ()
+insertDirectoryNode (_, firstTxOut) (newKey, transferLogic, issuerLogic) = Utils.inBabbage @era $ do
   netId <- queryNetworkId
+  initialTxIn <- asks (Env.dsTxIn . Env.directoryEnv)
+  paramsPolicyId <- asks (Env.protocolParamsPolicyId . Env.directoryEnv)
 
   let
       directoryMintingScript = directoryNodeMintingScript initialTxIn

src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs

@@ -15,6 +15,7 @@ where
 import Cardano.Api qualified as C
 import Cardano.Api.Shelley qualified as C
 import Control.Lens (over, (^.))
+import Control.Monad.Reader (runReaderT)
 import Convex.BuildTx (MonadBuildTx, addBtx, addReference,
                        addWithdrawalWithTxBody, buildScriptWitness,
                        findIndexReference, findIndexSpending, mintPlutus,
@@ -36,6 +37,7 @@ import SmartTokens.Types.ProtocolParams
 import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
 import Wst.Offchain.BuildTx.DirectorySet (insertDirectoryNode)
 import Wst.Offchain.BuildTx.ProtocolParams (getProtocolParamsGlobalInline)
+import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Scripts (programmableLogicBaseScript,
                              programmableLogicGlobalScript,
                              programmableLogicMintingScript)
@@ -46,8 +48,8 @@ import Wst.Offchain.Scripts (programmableLogicBaseScript,
   - 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 m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.TxIn -> (C.PolicyId, C.TxOut C.CtxTx era) -> (C.AssetName, C.Quantity) -> (C.StakeCredential, C.StakeCredential, C.StakeCredential) -> [(C.TxIn, C.TxOut C.CtxTx era)] -> m CurrencySymbol
-issueProgrammableToken directoryInitialTxIn (paramsPolicyId, paramsTxOut) (an, q) (mintingCred, transferLogic, issuerLogic) directoryList = Utils.inBabbage @era $ do
+issueProgrammableToken :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.TxIn -> C.TxOut C.CtxTx era -> (C.AssetName, C.Quantity) -> (C.StakeCredential, C.StakeCredential, C.StakeCredential) -> [(C.TxIn, C.TxOut C.CtxTx era)] -> m CurrencySymbol
+issueProgrammableToken directoryInitialTxIn paramsTxOut (an, q) (mintingCred, transferLogic, issuerLogic) directoryList = Utils.inBabbage @era $ do
   ProgrammableLogicGlobalParams {directoryNodeCS, progLogicCred} <- maybe (error "could not parse protocol params") pure $ getProtocolParamsGlobalInline (C.inAnyCardanoEra (C.cardanoEra @era) paramsTxOut)
 
   progLogicScriptCredential <- either (const $ error "could not parse protocol params") pure $ unTransCredential progLogicCred
@@ -67,7 +69,7 @@ issueProgrammableToken directoryInitialTxIn (paramsPolicyId, paramsTxOut) (an, q
       mintPlutus mintingScript MintPToken an q
     else
       mintPlutus mintingScript RegisterPToken an q
-        >> insertDirectoryNode paramsPolicyId directoryInitialTxIn (dirNodeRef, dirNodeOut) (policyId, transferLogic, issuerLogic)
+        >> runReaderT (insertDirectoryNode (dirNodeRef, dirNodeOut) (policyId, transferLogic, issuerLogic)) (Env.mkDirectoryEnv directoryInitialTxIn)
 
   pure policyId
 

src/lib/Wst/Offchain/Endpoints/Deployment.hs

@@ -24,3 +24,9 @@ deployTx = do
               $ Env.balanceTxEnv
               $ BuildTx.mintProtocolParams >> BuildTx.initDirectorySet
   pure (Convex.CoinSelection.signBalancedTxBody [] tx, txi)
+
+{-| Build a transaction that inserts a node into the directory
+-}
+insertNodeTx :: (MonadReader env m, Env.HasOperatorEnv era env, Env.HasDirectoryEnv env, MonadBlockchain era m, MonadError (BuildTxError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era) => m (C.Tx era)
+insertNodeTx = do
+  pure undefined

src/lib/Wst/Offchain/Endpoints/Query.hs → src/lib/Wst/Offchain/Query.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-| Look up outputs at script addresses
 -}
-module Wst.Offchain.Endpoints.Query(
+module Wst.Offchain.Query(
   UTxO(..),
   registryNodes,
   globalParamsNode

src/test/Wst/Test/UnitTest.hs

@@ -13,8 +13,8 @@ import Convex.Wallet.Operator (signTxOperator)
 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.Offchain.Query qualified as Query
 import Wst.Test.Env (admin, asAdmin)
 
 tests :: TestTree
@@ -26,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 (Env.directoryEnv txI) $ do
+  flip runReaderT (Env.mkDirectoryEnv txI) $ do
     Query.registryNodes @C.ConwayEra
       >>= void . expectSingleton "registry output"
     Query.globalParamsNode @C.ConwayEra

src/wst-poc.cabal

@@ -77,8 +77,8 @@ library
     Wst.Offchain.BuildTx.ProtocolParams
     Wst.Offchain.BuildTx.TransferLogic
     Wst.Offchain.Endpoints.Deployment
-    Wst.Offchain.Endpoints.Query
     Wst.Offchain.Env
+    Wst.Offchain.Query
     Wst.Offchain.Scripts
     Wst.Onchain
     Wst.Server