Add TransferLogicEnv

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

@@ -45,13 +45,8 @@ import Wst.Offchain.BuildTx.ProgrammableLogic (IssueNewTokenArgs,
 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 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 :: 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
 
@@ -76,17 +71,17 @@ transferStablecoins transferLogicCred blacklistPolicyId blacklistOutputs userOut
 
 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 :: 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
-  let mintingScript = permissionedTransferScript issuerPubKeyHash
-      sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 mintingScript
+  mintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv)
+  let 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 :: 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)) $
@@ -116,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