Fix alwaysSucceeds script

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

@@ -9,6 +9,7 @@ module Wst.Offchain.BuildTx.TransferLogic
     seizeSmartTokens,
     initBlacklist,
     insertBlacklistNode,
+    paySmartTokensToDestination
   )
 where
 
@@ -139,21 +140,30 @@ insertBlacklistNode cred blacklistNodes = Utils.inBabbage @era $ do
   opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv)
   addRequiredSignature opPkh
 
-issueSmartTokens :: forall era env m. (MonadReader env m, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m, Env.HasOperatorEnv era env) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> [UTxODat era DirectorySetNode] -> C.PaymentCredential -> m C.AssetId
-issueSmartTokens paramsTxOut (an, q) directoryList destinationCred = Utils.inBabbage @era $ do
+{-| Add a smart token output that locks the given value,
+addressed to the payment credential
+-}
+paySmartTokensToDestination :: forall era env m. (MonadBuildTx era m, MonadReader env m, Env.HasDirectoryEnv env, MonadBlockchain era m, C.IsBabbageBasedEra era) => (C.AssetName, C.Quantity) -> C.PolicyId -> C.PaymentCredential -> m ()
+paySmartTokensToDestination (an, q) issuedPolicyId destinationCred = Utils.inBabbage @era $ do
   nid <- queryNetworkId
-
-  directoryEnv <- asks Env.directoryEnv
-  let progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv
-  inta <- intaFromEnv
-  issuedPolicyId <- issueProgrammableToken paramsTxOut (an, q) inta directoryList
   -- TODO: check if there is a better way to achieve: C.PaymentCredential -> C.StakeCredential
   stakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential destinationCred
+  directoryEnv <- asks Env.directoryEnv
+  let progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv
   let value = fromList [(C.AssetId issuedPolicyId an, q)]
       addr = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue stakeCred)
 
-  addIssueWitness
   payToAddress addr value
+
+issueSmartTokens :: forall era env m. (MonadReader env m, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m, Env.HasOperatorEnv era env) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> [UTxODat era DirectorySetNode] -> C.PaymentCredential -> m C.AssetId
+issueSmartTokens paramsTxOut (an, q) directoryList destinationCred = Utils.inBabbage @era $ do
+  inta <- intaFromEnv
+  issuedPolicyId <- issueProgrammableToken paramsTxOut (an, q) inta directoryList
+
+
+  addIssueWitness
+  --  payToAddress addr value
+  paySmartTokensToDestination (an, q) issuedPolicyId destinationCred
   pure $ C.AssetId issuedPolicyId an
 
 transferSmartTokens :: forall env era a m. (MonadReader env m, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m, Env.HasOperatorEnv era env, MonadError (AppError era) m) => UTxODat era ProgrammableLogicGlobalParams -> C.PaymentCredential -> [UTxODat era BlacklistNode] -> [UTxODat era DirectorySetNode] -> [UTxODat era a] -> (C.AssetId, C.Quantity) -> C.PaymentCredential -> m ()

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

@@ -30,6 +30,7 @@ import Wst.Offchain.BuildTx.DirectorySet qualified as BuildTx
 import Wst.Offchain.BuildTx.ProgrammableLogic qualified as BuildTx
 import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx
 import Wst.Offchain.BuildTx.TransferLogic qualified as BuildTx
+import Wst.Offchain.BuildTx.TransferLogic qualified as TL
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (..))
 import Wst.Offchain.Query qualified as Query
@@ -84,7 +85,8 @@ issueProgrammableTokenTx issueTokenArgs assetName quantity = do
   paramsNode <- Query.globalParamsNode @era
   (tx, _) <- Env.balanceTxEnv_ $ do
     polId <- BuildTx.issueProgrammableToken paramsNode (assetName, quantity) issueTokenArgs directory
-
+    Env.operatorPaymentCredential
+      >>= BuildTx.paySmartTokensToDestination (assetName, quantity) polId
     let hsh = C.hashScript (C.PlutusScript C.plutusScriptVersion $ BuildTx.intaMintingLogic issueTokenArgs)
     BuildTx.addScriptWithdrawal hsh 0 $ BuildTx.buildScriptWitness (BuildTx.intaMintingLogic issueTokenArgs) C.NoScriptDatumForStake ()
   pure (Convex.CoinSelection.signBalancedTxBody [] tx)

src/lib/Wst/Offchain/Env.hs

@@ -12,6 +12,7 @@ module Wst.Offchain.Env(
   OperatorEnv(..),
   loadOperatorEnv,
   loadOperatorEnvFromAddress,
+  operatorPaymentCredential,
 
   -- ** Using the operator environment
   selectOperatorOutput,
@@ -111,6 +112,11 @@ data OperatorEnv era =
     , bteOperatorUtxos :: UTxO era -- ^ UTxOs owned by the operator, available for spending
     }
 
+{-| Get the operator's payment credential from the 'env'
+-}
+operatorPaymentCredential :: (MonadReader env m, HasOperatorEnv era env) => m C.PaymentCredential
+operatorPaymentCredential = asks (C.PaymentCredentialByKey . fst . bteOperator . operatorEnv)
+
 {-| Populate the 'OperatorEnv' with UTxOs locked by the payment credential
 -}
 loadOperatorEnv :: (MonadUtxoQuery m, C.IsBabbageBasedEra era) => C.Hash C.PaymentKey -> C.StakeAddressReference -> m (OperatorEnv era)
@@ -233,6 +239,9 @@ class HasTransferLogicEnv e where
 instance HasTransferLogicEnv TransferLogicEnv where
   transferLogicEnv = id
 
+{-| The 'TransferLogicEnv' with scripts that allow the given payment credential
+to manage the blacklist and issue / burn tokens
+-}
 mkTransferLogicEnv :: C.Hash C.PaymentKey -> TransferLogicEnv
 mkTransferLogicEnv cred =
   let blacklistMinting = blacklistMintingScript cred

src/test/Wst/Test/UnitTest.hs

@@ -38,9 +38,6 @@ tests = testGroup "unit tests"
   [ testCase "deploy directory and global params" (mockchainSucceeds deployDirectorySet)
   , testCase "insert directory node" (mockchainSucceeds insertDirectoryNode)
   , testGroup "issue programmable tokens"
-      -- FIXME: Fails because the minted value is not sent to the operator
-      -- address. If we want to keep this test we need to modify the Endpoint.issueProgrammableTokenTx
-      -- tx builder to pay the minted value to progLogicBaseScript with operator stake credential
       [ testCase "always succeeds validator" (mockchainSucceeds issueAlwaysSucceedsValidator)
       , testCase "smart token issuance" (mockchainSucceeds issueSmartTokensScenario)
       , testCase "smart token transfer" (mockchainSucceeds transferSmartTokens)
@@ -240,7 +237,6 @@ registerAlwaysSucceedsStakingCert = failOnError $ do
   txBody <- BuildTx.execBuildTxT $ do
     BuildTx.addStakeScriptWitness cred Scripts.alwaysSucceedsScript ()
     BuildTx.addConwayStakeCredentialRegistrationCertificate cred (pp ^. Ledger.ppKeyDepositL)
-    addStakeCredentialCertificate cred
   void (tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange [])
 
 registerTransferScripts :: (MonadFail m, MonadReader env m, Env.HasDirectoryEnv env, Env.HasTransferLogicEnv env, MonadMockchain C.ConwayEra m) => C.Hash C.PaymentKey -> m C.TxId