Issue transfer logic builder

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

@@ -6,7 +6,9 @@
 
 {-# HLINT ignore "Use second" #-}
 module Wst.Offchain.BuildTx.ProgrammableLogic
-  ( issueProgrammableToken,
+  (
+    IssueNewTokenArgs (..),
+    issueProgrammableToken,
     transferProgrammableToken,
     seizeProgrammableToken,
   )
@@ -39,44 +41,49 @@ import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..),
                                           insertDirectoryNode)
 import Wst.Offchain.BuildTx.ProtocolParams (getProtocolParamsGlobalInline)
 import Wst.Offchain.Env qualified as Env
+import Wst.Offchain.Query (UTxODat (..))
 import Wst.Offchain.Query qualified as Query
 import Wst.Offchain.Scripts (programmableLogicBaseScript,
                              programmableLogicGlobalScript,
                              programmableLogicMintingScript)
 
 
+data IssueNewTokenArgs = IssueNewTokenArgs
+  { intaMintingLogic :: C.StakeCredential,
+    intaTransferLogic :: C.StakeCredential,
+    intaIssuerLogic :: C.StakeCredential
+  }
+
 {- Issue a programmable token and register it in the directory set if necessary. The caller should ensure that the specific
    minting logic stake script witness is included in the final transaction.
   - 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.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)
+issueProgrammableToken :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.TxIn -> UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> IssueNewTokenArgs -> [UTxODat era DirectorySetNode] -> m C.PolicyId
+issueProgrammableToken directoryInitialTxIn paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, intaTransferLogic, intaIssuerLogic} directoryList = Utils.inBabbage @era $ do
+  let ProgrammableLogicGlobalParams {directoryNodeCS, progLogicCred} = uDatum paramsTxOut
 
   progLogicScriptCredential <- either (const $ error "could not parse protocol params") pure $ unTransCredential progLogicCred
   directoryNodeSymbol <- either (const $ error "could not parse protocol params") pure $ unTransPolicyId directoryNodeCS
 
-  let mintingScript = programmableLogicMintingScript progLogicScriptCredential mintingCred directoryNodeSymbol
-      policyId = transPolicyId $ C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript
-
-      (dirNodeRef, dirNodeOut) =
-        maximumBy (compare `on` (fmap key . getDirectoryNodeInline . C.inAnyCardanoEra (C.cardanoEra @era) . snd)) $
-          filter (maybe False ((<= policyId) . key) . getDirectoryNodeInline . C.inAnyCardanoEra (C.cardanoEra @era) . snd) directoryList
+  let mintingScript = programmableLogicMintingScript progLogicScriptCredential intaMintingLogic directoryNodeSymbol
+      issuedPolicyId = C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript
+      issuedSymbol = transPolicyId issuedPolicyId
 
-  dirNodeData <- maybe (error "could not parse directory node data") pure $ getDirectoryNodeInline $ C.inAnyCardanoEra (C.cardanoEra @era) dirNodeOut
+      udat@UTxODat{uDatum = dirNodeData} =
+        maximumBy (compare `on` (key . uDatum)) $
+          filter ((<= issuedSymbol) . key . uDatum) directoryList
 
-  if key dirNodeData == policyId
+  if key dirNodeData == issuedSymbol
     then
       mintPlutus mintingScript MintPToken an q
     else do
-      let firstNode = fromJust (error "failed to extract DirectorySetNode from first node") $ Query.fromOutput @era @DirectorySetNode dirNodeRef (C.toCtxUTxOTxOut dirNodeOut)
-          nodeArgs  = InsertNodeArgs{inaNewKey = policyId, inaTransferLogic = transferLogic, inaIssuerLogic = issuerLogic}
+      let nodeArgs  = InsertNodeArgs{inaNewKey = issuedSymbol, inaTransferLogic = intaTransferLogic, inaIssuerLogic = intaIssuerLogic}
       mintPlutus mintingScript RegisterPToken an q
         -- TODO: propagate the HasEnv constraint upwards
-        >> runReaderT (insertDirectoryNode firstNode nodeArgs) (Env.mkDirectoryEnv directoryInitialTxIn)
+        >> runReaderT (insertDirectoryNode udat nodeArgs) (Env.mkDirectoryEnv directoryInitialTxIn)
 
-  pure policyId
+  pure issuedPolicyId
 
 {- User facing transfer of programmable tokens from one address to another.
    The caller should ensure that the specific transfer logic stake script

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

@@ -9,22 +9,27 @@ module Wst.Offchain.BuildTx.TransferLogic (
   ) where
 
 import Cardano.Api qualified as C
+import Cardano.Api.Ledger (hashKey)
 import Cardano.Api.Shelley qualified as C
+import Control.Monad.Reader (MonadReader, asks)
 import Convex.BuildTx (MonadBuildTx, addBtx, addReference, addScriptWithdrawal,
                        addStakeWitness, addWithdrawalWithTxBody,
                        buildScriptWitness, findIndexReference,
                        findIndexSpending, mintPlutus, payToAddress,
                        spendPlutusInlineDatum)
 import Convex.CardanoApi.Lenses as L
 import Convex.Class (MonadBlockchain (queryNetworkId))
-import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential,
-                               unTransPolicyId)
+import Convex.PlutusLedger.V1 (transCredential, transPolicyId,
+                               unTransCredential, unTransPolicyId,
+                               unTransStakeCredential)
 import Convex.Scripts (fromHashableScriptData)
 import Convex.Utils qualified as Utils
+import Convex.Wallet.Operator (Operator (..), verificationKey)
 import Data.Either (fromRight)
 import Data.Foldable (find, maximumBy)
 import Data.Function (on)
 import Data.Maybe (fromJust)
+import GHC.Exts (IsList (..))
 import PlutusLedgerApi.V3 (CurrencySymbol (..))
 import PlutusTx qualified
 import SmartTokens.Contracts.ExampleTransferLogic (BlacklistProof (..))
@@ -35,34 +40,48 @@ import SmartTokens.Types.ProtocolParams
 import SmartTokens.Types.PTokenDirectory (BlacklistNode (..),
                                           DirectorySetNode (..))
 import Wst.Offchain.BuildTx.DirectorySet (insertDirectoryNode)
-import Wst.Offchain.BuildTx.ProgrammableLogic (issueProgrammableToken)
+import Wst.Offchain.BuildTx.ProgrammableLogic (IssueNewTokenArgs,
+                                               issueProgrammableToken)
 import Wst.Offchain.BuildTx.ProtocolParams (getProtocolParamsGlobalInline)
+import Wst.Offchain.Env qualified as Env
+import Wst.Offchain.Query (UTxODat)
 import Wst.Offchain.Scripts (freezeAndSezieTransferScript,
                              permissionedTransferScript,
                              programmableLogicBaseScript,
                              programmableLogicGlobalScript,
                              programmableLogicMintingScript)
 
-issueStablecoins :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.PaymentCredential -> C.Value -> m ()
-issueStablecoins issuerLogicCred amount = Utils.inBabbage @era $ do
-  symbol <- issueProgrammableToken undefined undefined undefined undefined undefined
-  addIssueStablecoinsWitness undefined
+issueStablecoins :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, Env.HasOperatorEnv era env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> IssueNewTokenArgs -> [UTxODat era DirectorySetNode] -> C.PaymentCredential ->  m ()
+issueStablecoins paramsTxOut (an, q) inta directoryList destinationCred = Utils.inBabbage @era $ do
+  nid <- queryNetworkId
 
-  -- TODO: create the value to be minted and the special address to send it to
-  let value = undefined
-      addr = undefined --
-  payToAddress value addr
+  directoryEnv <- asks Env.directoryEnv
+  let txIn = Env.dsTxIn directoryEnv
+      progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv
 
-addIssueStablecoinsWitness :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.Hash C.PaymentKey -> m ()
-addIssueStablecoinsWitness issuerPubKeyHash = Utils.inBabbage @era $ do
-  let mintingScript = permissionedTransferScript issuerPubKeyHash
-      sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 mintingScript
-  addScriptWithdrawal sh 0 $ buildScriptWitness mintingScript C.NoScriptDatumForStake ()
+  opVerKey <- asks (verificationKey . oPaymentKey . Env.bteOperator . Env.operatorEnv)
+  let opPkh = C.verificationKeyHash opVerKey
+  addIssueWitness opPkh
+
+  issuedPolicyId <- issueProgrammableToken txIn 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
+  let value = fromList [(C.AssetId issuedPolicyId an, q)]
+      addr = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue $ stakeCred)
 
+  payToAddress addr value
 
 transferStablecoins :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.PaymentCredential -> C.PolicyId -> [(C.TxIn, C.TxOut C.CtxTx era)] -> [(C.TxIn, C.TxOut C.CtxTx era)] -> C.Value -> C.PaymentCredential -> m ()
 transferStablecoins transferLogicCred blacklistPolicyId blacklistOutputs userOutputs amount destinationCred = pure ()
 
+seizeStablecoins = undefined
+
+addIssueWitness :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.Hash C.PaymentKey -> m ()
+addIssueWitness issuerPubKeyHash = Utils.inBabbage @era $ do
+  let mintingScript = permissionedTransferScript issuerPubKeyHash
+      sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 mintingScript
+  addScriptWithdrawal sh 0 $ buildScriptWitness mintingScript C.NoScriptDatumForStake ()
+
 addTransferWitness :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.PolicyId -> [(C.TxIn, C.TxOut C.CtxTx era)] -> C.PaymentCredential -> m ()
 addTransferWitness blacklistPolicyId blacklistNodes clientCred = Utils.inBabbage @era $ do
   nid <- queryNetworkId