From 96043e04e923cc266118761e5721e509e44ddc16 Mon Sep 17 00:00:00 2001 From: Amir Rad Date: Fri, 20 Dec 2024 11:56:07 +0000 Subject: [PATCH] Add TransferLogicEnv --- src/lib/Wst/Offchain/BuildTx/TransferLogic.hs | 25 ++++----- src/lib/Wst/Offchain/Env.hs | 51 +++++++++++++++++-- src/lib/Wst/Offchain/Scripts.hs | 13 +++++ 3 files changed, 71 insertions(+), 18 deletions(-) diff --git a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs index a9238bf..7c237b3 100644 --- a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs +++ b/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 () diff --git a/src/lib/Wst/Offchain/Env.hs b/src/lib/Wst/Offchain/Env.hs index bb347a9..3826a12 100644 --- a/src/lib/Wst/Offchain/Env.hs +++ b/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 diff --git a/src/lib/Wst/Offchain/Scripts.hs b/src/lib/Wst/Offchain/Scripts.hs index 093d9bd..9a60437 100644 --- a/src/lib/Wst/Offchain/Scripts.hs +++ b/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