Merge branch 'amir/api-endpoints' of github.com:input-output-hk/wsc-p…

…oc into amir/api-endpoints

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,45 +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.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 (paramsTxIn, 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)
-          paramsNode = fromJust (error "failed to extract ProgrammableLogicGlobalParams from params node") $ Query.fromOutput @era @ProgrammableLogicGlobalParams paramsTxIn (C.toCtxUTxOTxOut paramsTxOut)
-          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 paramsNode firstNode nodeArgs) (Env.mkDirectoryEnv directoryInitialTxIn)
+        >> runReaderT (insertDirectoryNode paramsTxOut 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,39 +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.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
-
-  -- TODO: create the value to be minted and the special address to send it to
-  let value = undefined
-      addr = undefined --
-  payToAddress value addr
-
-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 ()
+import Wst.Offchain.Env qualified as Env
+import Wst.Offchain.Query (UTxODat)
+
+issueStablecoins :: forall era env m. (MonadReader env m, Env.HasTransferLogicEnv env, 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
+
+  directoryEnv <- asks Env.directoryEnv
+  let txIn = Env.dsTxIn directoryEnv
+      progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv
+
+  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 ()
 
-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 ()
+seizeStablecoins = undefined
+
+addIssueWitness :: forall era env m. (MonadReader env m, Env.HasTransferLogicEnv env, 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
+  mintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv)
+  let sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 mintingScript
+  addScriptWithdrawal sh 0 $ buildScriptWitness mintingScript C.NoScriptDatumForStake ()
+
+addTransferWitness :: forall env era m. (MonadReader env m, Env.HasTransferLogicEnv env, 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
-  let transferScript = freezeAndSezieTransferScript blacklistPolicyId
-      transferStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 transferScript
+  transferScript <- asks (Env.tleTransferScript . Env.transferLogicEnv)
+  let transferStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 transferScript
 
       (blnNodeRef, blnNodeOut) =
         maximumBy (compare `on` (fmap blnKey . getDatumInline @BlacklistNode . C.inAnyCardanoEra (C.cardanoEra @era) . snd)) $
@@ -97,10 +111,10 @@ addTransferWitness blacklistPolicyId blacklistNodes clientCred = Utils.inBabbage
     (C.Quantity 0)
     $ C.ScriptWitness C.ScriptWitnessForStakeAddr . transferWitness
 
-addSeizeWitness :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.Hash C.PaymentKey -> m ()
+addSeizeWitness :: forall env era m. (MonadReader env m, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.Hash C.PaymentKey -> m ()
 addSeizeWitness issuerPubKeyHash = Utils.inBabbage @era $ do
-  let seizeScript = permissionedTransferScript issuerPubKeyHash
-      sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 seizeScript
+  seizeScript <- asks (Env.tleIssuerScript . Env.transferLogicEnv)
+  let sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 seizeScript
   addScriptWithdrawal sh 0 $ buildScriptWitness seizeScript C.NoScriptDatumForStake ()
 
 

src/lib/Wst/Offchain/Env.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE NamedFieldPuns         #-}
+{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
 {-| Transaction building environment
 -}
 module Wst.Offchain.Env(
@@ -24,6 +25,11 @@ module Wst.Offchain.Env(
   protocolParamsPolicyId,
   globalParams,
 
+
+  -- * Transfer logic environment
+  TransferLogicEnv(..),
+  HasTransferLogicEnv(..),
+
   -- * Combined environment
   CombinedEnv(..),
   withDirectoryFor
@@ -45,12 +51,15 @@ import Convex.Utxos (BalanceChanges)
 import Convex.Utxos qualified as Utxos
 import Convex.Wallet.Operator (Operator (..), PaymentExtendedKey (..),
                                Verification, operatorPaymentCredential,
-                               operatorReturnOutput)
+                               operatorReturnOutput, verificationKey)
 import Data.Map qualified as Map
 import Data.Maybe (listToMaybe)
 import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams (..))
-import Wst.Offchain.Scripts (directoryNodeMintingScript,
+import Wst.Offchain.Scripts (blacklistMintingScript, blacklistSpendingScript,
+                             directoryNodeMintingScript,
                              directoryNodeSpendingScript,
+                             freezeAndSezieTransferScript,
+                             permissionedTransferScript,
                              programmableLogicBaseScript,
                              programmableLogicGlobalScript,
                              protocolParamsMintingScript, scriptPolicyIdV3)
@@ -111,7 +120,7 @@ class HasDirectoryEnv e where
 instance HasDirectoryEnv DirectoryEnv where
   directoryEnv = id
 
-{-| Scripts relatd to managing the token policy directory.
+{-| Scripts related to managing the token policy directory.
 All of the scripts and their hashes are determined by the 'TxIn'.
 -}
 data DirectoryEnv =
@@ -162,6 +171,39 @@ globalParams scripts =
     , progLogicCred   = transCredential (programmableLogicBaseCredential scripts) -- its the script hash of the programmable base spending script
     }
 
+{-| Scripts related to managing the specific transfer logic
+-}
+
+data TransferLogicEnv =
+  TransferLogicEnv
+    { tleBlacklistPolicy :: C.PolicyId
+    , tleBlacklistMintingScript :: PlutusScript PlutusScriptV3
+    , tleBlacklistSpendingScript :: PlutusScript PlutusScriptV3
+    , tleMintingScript :: PlutusScript PlutusScriptV3
+    , tleTransferScript :: PlutusScript PlutusScriptV3
+    , tleIssuerScript :: PlutusScript PlutusScriptV3
+    }
+
+class HasTransferLogicEnv e where
+  transferLogicEnv :: e -> TransferLogicEnv
+
+instance HasTransferLogicEnv TransferLogicEnv where
+  transferLogicEnv = id
+
+mkTransferLogicEnv :: C.Hash C.PaymentKey -> TransferLogicEnv
+mkTransferLogicEnv cred =
+  let blacklistMinting = blacklistMintingScript cred
+      blacklistPolicy = scriptPolicyIdV3 blacklistMinting
+  in
+  TransferLogicEnv
+    { tleBlacklistPolicy = blacklistPolicy
+    , tleBlacklistMintingScript = blacklistMinting
+    , tleBlacklistSpendingScript = blacklistSpendingScript cred
+    , tleMintingScript =  permissionedTransferScript cred
+    , tleTransferScript = freezeAndSezieTransferScript blacklistPolicy
+    , tleIssuerScript = permissionedTransferScript cred
+    }
+
 data CombinedEnv era =
   CombinedEnv
     { ceOperator :: OperatorEnv era
@@ -174,6 +216,9 @@ instance HasOperatorEnv era (CombinedEnv era) where
 instance HasDirectoryEnv (CombinedEnv era) where
   directoryEnv = ceDirectory
 
+instance HasTransferLogicEnv (CombinedEnv era) where
+  transferLogicEnv = mkTransferLogicEnv . C.verificationKeyHash . verificationKey . oPaymentKey . bteOperator . ceOperator
+
 {-| Add a 'DirectoryEnv' to the environment
 -}
 withDirectoryFor :: (MonadReader env m, HasOperatorEnv era env) => C.TxIn -> ReaderT (CombinedEnv era) m a -> m a

src/lib/Wst/Offchain/Scripts.hs

@@ -14,6 +14,8 @@ module Wst.Offchain.Scripts (
   -- Transfer logic
   permissionedTransferScript,
   freezeAndSezieTransferScript,
+  blacklistMintingScript,
+  blacklistSpendingScript,
 
   -- Utils
   scriptPolicyIdV3
@@ -36,6 +38,7 @@ import SmartTokens.Contracts.Issuance (mkProgrammableLogicMinting)
 import SmartTokens.Contracts.ProgrammableLogicBase (mkProgrammableLogicBase,
                                                     mkProgrammableLogicGlobal)
 import SmartTokens.Contracts.ProtocolParams (alwaysFailScript,
+                                             mkPermissionedMinting,
                                              mkProtocolParametersMinting)
 import SmartTokens.Core.Scripts (tryCompile)
 import SmartTokens.LinkedList.MintDirectory (mkDirectoryNodeMP)
@@ -109,6 +112,16 @@ freezeAndSezieTransferScript blacklistPolicyId =
   let script = tryCompile prodConfig $ mkFreezeAndSeizeTransfer # pdata (pconstant $ transPolicyId blacklistPolicyId)
   in C.PlutusScriptSerialised $ serialiseScript script
 
+blacklistMintingScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3
+blacklistMintingScript cred =
+  let script = tryCompile prodConfig $ mkPermissionedMinting # pdata (pconstant $ transPubKeyHash cred)
+  in C.PlutusScriptSerialised $ serialiseScript script
+
+blacklistSpendingScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3
+blacklistSpendingScript cred =
+  let script = tryCompile prodConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred)
+  in C.PlutusScriptSerialised $ serialiseScript script
+
 -- Utilities
 scriptPolicyIdV3 :: C.PlutusScript C.PlutusScriptV3 -> C.PolicyId
 scriptPolicyIdV3 = C.scriptPolicyId . C.PlutusScript C.PlutusScriptV3