Deploy all scripts and reg in single tx test case

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

@@ -0,0 +1 @@
+

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

@@ -9,6 +9,7 @@ module Wst.Offchain.BuildTx.ProgrammableLogic
   ( issueProgrammableToken,
     transferProgrammableToken,
     seizeProgrammableToken,
+    registerProgrammableGlobalScript,
   )
 where
 
@@ -38,6 +39,7 @@ import SmartTokens.Types.ProtocolParams
 import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
 import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..),
                                           insertDirectoryNode)
+import Wst.Offchain.BuildTx.Utils (addConwayStakeCredentialCertificate)
 import Wst.Offchain.Env (TransferLogicEnv (..))
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (..))
@@ -206,13 +208,20 @@ seizeProgrammableToken UTxODat{uIn = paramsTxIn} UTxODat{uIn = seizingTxIn, uOut
   addReference paramsTxIn -- Protocol Params TxIn
   addReference dirNodeRef -- Directory Node TxIn
   spendPlutusInlineDatum seizingTxIn baseSpendingScript () -- Redeemer is ignored in programmableLogicBase
-  -- QUESTION: why do we have to spend an issuer output?
-  -- spendPlutusInlineDatum issuerTxIn baseSpendingScript () -- Redeemer is ignored in programmableLogicBase
   addWithdrawalWithTxBody -- Add the global script witness to the transaction
     (C.makeStakeAddress nid globalStakeCred)
     (C.Quantity 0)
     $ C.ScriptWitness C.ScriptWitnessForStakeAddr . programmableGlobalWitness
 
+registerProgrammableGlobalScript :: forall env era m. (MonadReader env m, C.IsBabbageBasedEra era, MonadBuildTx era m, Env.HasDirectoryEnv env) => m ()
+registerProgrammableGlobalScript = case C.babbageBasedEra @era of
+  C.BabbageEraOnwardsBabbage -> error "babbage era registration not implemented"
+  C.BabbageEraOnwardsConway  -> Utils.inConway @era $ do
+    programmableGlobalScript <- asks (Env.dsProgrammableLogicGlobalScript . Env.directoryEnv)
+    let hshGlobal = C.hashScript $ C.PlutusScript C.plutusScriptVersion programmableGlobalScript
+        credGlobal = C.StakeCredentialByScript hshGlobal
+    addConwayStakeCredentialCertificate credGlobal
+
   -- TODO: check that the issuerTxOut is at a programmable logic payment credential
 _checkIssuerAddressIsProgLogicCred :: forall era ctx m. ( MonadBuildTx era m) => C.PaymentCredential -> C.TxOut ctx era -> m ()
 _checkIssuerAddressIsProgLogicCred _progLogicCred (C.TxOut (C.AddressInEra _ (C.ShelleyAddress _ _pcred _stakeRef)) _ _ C.ReferenceScriptNone) =

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

@@ -9,7 +9,8 @@ module Wst.Offchain.BuildTx.TransferLogic
     seizeSmartTokens,
     initBlacklist,
     insertBlacklistNode,
-    paySmartTokensToDestination
+    paySmartTokensToDestination,
+    registerTransferScripts,
   )
 where
 
@@ -47,6 +48,7 @@ import Wst.AppError (AppError (TransferBlacklistedCredential))
 import Wst.Offchain.BuildTx.ProgrammableLogic (issueProgrammableToken,
                                                seizeProgrammableToken,
                                                transferProgrammableToken)
+import Wst.Offchain.BuildTx.Utils (addConwayStakeCredentialCertificate)
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (..))
 import Wst.Offchain.Scripts (scriptPolicyIdV3)
@@ -327,3 +329,20 @@ unwrapCredential :: Credential -> PlutusTx.BuiltinByteString
 unwrapCredential = \case
   PubKeyCredential (PubKeyHash s) -> s
   ScriptCredential (ScriptHash s) -> s
+
+registerTransferScripts :: forall env era m. (MonadReader env m, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBuildTx era m) => m ()
+registerTransferScripts = case C.babbageBasedEra @era of
+  C.BabbageEraOnwardsBabbage -> error "babbage era registration not implemented"
+  C.BabbageEraOnwardsConway  -> Utils.inConway @era $ do
+    transferMintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv)
+    transferSpendingScript <- asks (Env.tleTransferScript . Env.transferLogicEnv)
+
+    let
+        hshMinting = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferMintingScript
+        credMinting = C.StakeCredentialByScript hshMinting
+
+        hshSpending = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferSpendingScript
+        credSpending = C.StakeCredentialByScript hshSpending
+
+    addConwayStakeCredentialCertificate credMinting
+    addConwayStakeCredentialCertificate credSpending

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

@@ -0,0 +1,17 @@
+
+module Wst.Offchain.BuildTx.Utils
+  ( addConwayStakeCredentialCertificate
+  ) where
+
+
+import Cardano.Api qualified as C
+import Cardano.Api.Shelley qualified as C
+import Cardano.Ledger.Shelley.TxCert qualified as TxCert
+import Convex.BuildTx (MonadBuildTx, addCertificate)
+
+{-| Add a 'C.StakeCredential' as a certificate to the transaction
+-}
+addConwayStakeCredentialCertificate :: forall era m. C.IsConwayBasedEra era => MonadBuildTx era m => C.StakeCredential -> m ()
+addConwayStakeCredentialCertificate stk =
+  C.conwayEraOnwardsConstraints @era C.conwayBasedEra $
+  addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.RegTxCert $ C.toShelleyStakeCredential stk

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

@@ -3,6 +3,7 @@
 -}
 module Wst.Offchain.Endpoints.Deployment(
   deployTx,
+  deployTxAll,
   deployBlacklistTx,
   insertNodeTx,
   issueProgrammableTokenTx,
@@ -28,14 +29,18 @@ import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
 import Wst.AppError (AppError)
 import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (inaNewKey))
 import Wst.Offchain.BuildTx.DirectorySet qualified as BuildTx
+import Wst.Offchain.BuildTx.ProgrammableLogic (registerProgrammableGlobalScript)
 import Wst.Offchain.BuildTx.ProgrammableLogic qualified as BuildTx
 import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx
+import Wst.Offchain.BuildTx.TransferLogic (registerTransferScripts)
 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
 
+
+
 {-| Build a transaction that deploys the directory and global params. Returns the
 transaction and the 'TxIn' that was selected for the one-shot NFTs.
 -}
@@ -49,6 +54,24 @@ deployTx target = do
               $ BuildTx.mintProtocolParams >> BuildTx.initDirectorySet
   pure (Convex.CoinSelection.signBalancedTxBody [] tx, root)
 
+{-| Build a transaction that deploys the directory and global params. Returns the
+transaction and the 'TxIn' that was selected for the one-shot NFTs.
+-}
+deployTxAll :: (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)
+deployTxAll target = do
+  (txi, _) <- Env.selectOperatorOutput
+  opEnv <- asks Env.operatorEnv
+  let root = DirectoryScriptRoot txi target
+  (tx, _) <- Env.withEnv $ Env.withOperator opEnv $ Env.withDirectoryFor root $ Env.withTransferFromOperator
+              $ Env.balanceTxEnv_
+              $ BuildTx.mintProtocolParams
+                >> BuildTx.initDirectorySet
+                >> BuildTx.initBlacklist
+                >> BuildTx.registerProgrammableGlobalScript
+                >> BuildTx.registerTransferScripts
+
+  pure (Convex.CoinSelection.signBalancedTxBody [] tx, root)
+
 {-| Build a transaction that inserts a node into the directory
 -}
 insertNodeTx :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasDirectoryEnv env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadUtxoQuery m) => InsertNodeArgs -> m (C.Tx era)

src/test/unit/Wst/Test/UnitTest.hs

@@ -28,11 +28,13 @@ import Convex.Wallet.Operator (signTxOperator)
 import Convex.Wallet.Operator qualified as Operator
 import Data.List (isPrefixOf)
 import Data.String (IsString (..))
+import Debug.Trace (traceM)
 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.Utils (addConwayStakeCredentialCertificate)
 import Wst.Offchain.Endpoints.Deployment qualified as Endpoints
 import Wst.Offchain.Env (DirectoryScriptRoot)
 import Wst.Offchain.Env qualified as Env
@@ -58,9 +60,23 @@ scriptTargetTests target =
         , testCase "blacklist credential" (mockchainSucceedsWithTarget target $ void $ deployDirectorySet >>= blacklistCredential)
         , testCase "blacklisted transfer" (mockchainFails blacklistTransfer assertBlacklistedAddressException)
         , testCase "seize user output" (mockchainSucceedsWithTarget target $ deployDirectorySet >>= seizeUserOutput)
+        , testCase "deploy all" (mockchainSucceedsWithTarget target deployAll)
         ]
     ]
 
+deployAll :: (MonadReader ScriptTarget m, MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => m ()
+deployAll = do
+  target <- ask
+  failOnError $ Env.withEnv $ asAdmin @C.ConwayEra $ do
+    (tx, scriptRoot) <- Endpoints.deployTxAll target
+    void $ sendTx $ signTxOperator admin tx
+    traceM $ show tx
+    Env.withDirectoryFor scriptRoot $ do
+      Query.registryNodes @C.ConwayEra
+        >>= void . expectSingleton "registry output"
+      void $ Query.globalParamsNode @C.ConwayEra
+
+
 deployDirectorySet :: (MonadReader ScriptTarget m, MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => m DirectoryScriptRoot
 deployDirectorySet = do
   target <- ask
@@ -250,9 +266,9 @@ registerAlwaysSucceedsStakingCert = failOnError $ do
     BuildTx.addConwayStakeCredentialRegistrationCertificate cred (pp ^. Ledger.ppKeyDepositL)
   void (tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange [])
 
+-- TODO: registration to be moved to the endpoints
 registerTransferScripts :: (MonadFail m, MonadReader env m, Env.HasDirectoryEnv env, Env.HasTransferLogicEnv env, MonadMockchain C.ConwayEra m) => C.Hash C.PaymentKey -> m C.TxId
 registerTransferScripts pkh = failOnError $ do
-  pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters
   transferMintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv)
   transferSpendingScript <- asks (Env.tleTransferScript . Env.transferLogicEnv)
   transferGlobalScript <- asks (Env.dsProgrammableLogicGlobalScript . Env.directoryEnv)
@@ -267,24 +283,19 @@ registerTransferScripts pkh = failOnError $ do
       credGlobal = C.StakeCredentialByScript hshGlobal
 
   txBody <- BuildTx.execBuildTxT $ do
-    BuildTx.addStakeScriptWitness credMinting transferMintingScript ()
-    BuildTx.addConwayStakeCredentialRegistrationCertificate credMinting (pp ^. Ledger.ppKeyDepositL)
+    -- pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters
+    -- BuildTx.addStakeScriptWitness credMinting transferMintingScript ()
+    -- BuildTx.addConwayStakeCredentialRegistrationCertificate credMinting (pp ^. Ledger.ppKeyDepositL)
 
-    addStakeCredentialCertificate credSpending
-    addStakeCredentialCertificate credGlobal
+    addConwayStakeCredentialCertificate credSpending
+    addConwayStakeCredentialCertificate credMinting
+    addConwayStakeCredentialCertificate credGlobal
 
     BuildTx.addRequiredSignature pkh
 
   x <- tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange []
   pure $ C.getTxId $ C.getTxBody x
 
-{-| Add a 'C.StakeCredential' as a certificate to the transaction
--}
-addStakeCredentialCertificate :: forall era m. C.IsConwayBasedEra era => MonadBuildTx era m => C.StakeCredential -> m ()
-addStakeCredentialCertificate stk =
-  C.conwayEraOnwardsConstraints @era C.conwayBasedEra $
-  addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.RegTxCert $ C.toShelleyStakeCredential stk
-
 expectSingleton :: MonadFail m => String -> [a] -> m a
 expectSingleton msg = \case
   [a] -> pure a

src/wst-poc.cabal

@@ -79,6 +79,7 @@ library
     Wst.Offchain.BuildTx.ProgrammableLogic
     Wst.Offchain.BuildTx.ProtocolParams
     Wst.Offchain.BuildTx.TransferLogic
+    Wst.Offchain.BuildTx.Utils
     Wst.Offchain.Endpoints.Deployment
     Wst.Offchain.Env
     Wst.Offchain.Query
@@ -95,6 +96,7 @@ library
     , blockfrost-api
     , blockfrost-client-core
     , cardano-api
+    , cardano-ledger-shelley
     , containers
     , convex-base
     , convex-blockfrost