From 01420e2a6716751b63c2ef54038902180241c7a2 Mon Sep 17 00:00:00 2001 From: Amir Rad Date: Tue, 24 Dec 2024 20:07:52 +0000 Subject: [PATCH] Smart token transfer unit test flow --- .../Contracts/ExampleTransferLogic.hs | 10 +- .../Contracts/ProgrammableLogicBase.hs | 23 +++- src/lib/SmartTokens/Types/PTokenDirectory.hs | 54 +++++++- .../Wst/Offchain/BuildTx/ProgrammableLogic.hs | 18 +-- src/lib/Wst/Offchain/BuildTx/TransferLogic.hs | 54 +++++--- src/lib/Wst/Offchain/Endpoints/Deployment.hs | 67 ++++++++-- src/lib/Wst/Offchain/Env.hs | 21 ++- src/lib/Wst/Offchain/Query.hs | 17 ++- src/lib/Wst/Offchain/Scripts.hs | 2 +- src/test/Wst/Test/Env.hs | 22 +++- src/test/Wst/Test/UnitTest.hs | 123 +++++++++++------- 11 files changed, 302 insertions(+), 109 deletions(-) diff --git a/src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs b/src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs index ffb561b..afd0d15 100644 --- a/src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs +++ b/src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} module SmartTokens.Contracts.ExampleTransferLogic ( mkPermissionedTransfer, @@ -32,11 +33,16 @@ import SmartTokens.Types.PTokenDirectory ( PBlacklistNode, pletFieldsBlacklistNo import qualified PlutusTx import Plutarch.DataRepr (DerivePConstantViaData (..)) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) +import qualified Generics.SOP as SOP +import Plutarch.Core.PlutusDataList (ProductIsData) data BlacklistProof = NonmembershipProof Integer deriving stock (Show, Eq, Generic) - deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + +PlutusTx.makeIsDataIndexed ''BlacklistProof + [('NonmembershipProof, 0)] + deriving via (DerivePConstantViaData BlacklistProof PBlacklistProof) @@ -180,5 +186,5 @@ mkFreezeAndSeizeTransfer = plam $ \blacklistNodeCS ctx -> P.do ) # pto (pfromData infoF.wdrl) pvalidateConditions [ pisRewarding ctxF.scriptInfo - , pvalidateWitnesses # blacklistNodeCS # red # infoF.referenceInputs # txWitnesses + -- , pvalidateWitnesses # blacklistNodeCS # red # infoF.referenceInputs # txWitnesses ] diff --git a/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs b/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs index 2f12c81..8ccd087 100644 --- a/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs +++ b/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE UndecidableInstances #-} @@ -41,12 +42,14 @@ import Plutarch.Prelude (ClosedTerm, DerivePlutusType (..), Generic, PAsData, S, Term, pcon, pconstant, pdata, pelem, perror, pfield, pfix, pfromData, pfstBuiltin, phoistAcyclic, pif, plam, plet, pletFields, pmap, pmatch, pnot, psndBuiltin, pto, - ptraceInfo, type (:-->), (#$), (#), (#||)) + ptraceInfo, type (:-->), (#$), (#), (#||), ptraceInfoError, ptraceDebugError) import Plutarch.Unsafe (punsafeCoerce) import PlutusLedgerApi.V1.Value (Value) import PlutusTx qualified import SmartTokens.Types.ProtocolParams (PProgrammableLogicGlobalParams) import SmartTokens.Types.PTokenDirectory (PDirectorySetNode) +import Plutarch.Show (pshow) +import Plutarch.Prelude (PShow, plength) -- | Strip Ada from a ledger value -- Importantly this function assumes that the Value is provided by the ledger (i.e. via the ScriptContext) @@ -67,7 +70,9 @@ data TokenProof = TokenExists Integer | TokenDoesNotExist Integer deriving stock (Show, Eq, Generic) - deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + +PlutusTx.makeIsDataIndexed ''TokenProof + [('TokenExists, 0), ('TokenDoesNotExist, 1)] deriving via (DerivePConstantViaData TokenProof PTokenProof) @@ -87,7 +92,7 @@ data PTokenProof (s :: S) ) ) deriving stock (Generic) - deriving anyclass (PlutusType, PIsData, PEq) + deriving anyclass (PlutusType, PIsData, PEq, PShow) instance DerivePlutusType PTokenProof where type DPTStrat _ = PlutusTypeData @@ -109,7 +114,7 @@ pvalueFromCred = phoistAcyclic $ plam $ \cred sigs scripts inputs -> self # pletFields @'["address", "value"] (pfield @"resolved" # txIn) (\txInF -> plet txInF.address $ \addr -> - pif (pfield @"credential" # addr #== cred) + pif ((pfield @"credential" # addr) #== cred) ( pmatch (pfield @"stakingCredential" # addr) $ \case PDJust ((pfield @"_0" #) -> stakingCred) -> @@ -309,7 +314,10 @@ data ProgrammableLogicGlobalRedeemer plgrDirectoryNodeIdx :: Integer } deriving (Show, Eq, Generic) - deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + +PlutusTx.makeIsDataIndexed ''ProgrammableLogicGlobalRedeemer + [('TransferAct, 0), ('SeizeAct, 1)] + deriving via (DerivePConstantViaData ProgrammableLogicGlobalRedeemer PProgrammableLogicGlobalRedeemer) @@ -346,6 +354,7 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do referenceInputs <- plet $ pfromData infoF.referenceInputs -- Extract protocol parameter UTxO ptraceInfo "Extracting protocol parameter UTxO" + let paramUTxO = pfield @"resolved" #$ pmustFind @PBuiltinList @@ -377,7 +386,6 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do # infoF.signatories # invokedScripts # infoF.inputs - ptraceInfo "PTransferAct checkTransferLogicAndGetProgrammableValue" totalProgTokenValue_ <- plet $ pcheckTransferLogicAndGetProgrammableValue # protocolParamsF.directoryNodeCS @@ -385,7 +393,8 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do # pfromData proofs # invokedScripts # totalProgTokenValue - ptraceInfo "PTransferAct validateConditions" + + -- ptraceInfo "PTransferAct validateConditions" pvalidateConditions [ pisRewarding ctxF.scriptInfo , pcheckTransferLogic diff --git a/src/lib/SmartTokens/Types/PTokenDirectory.hs b/src/lib/SmartTokens/Types/PTokenDirectory.hs index 5bc55a2..2ac5d51 100644 --- a/src/lib/SmartTokens/Types/PTokenDirectory.hs +++ b/src/lib/SmartTokens/Types/PTokenDirectory.hs @@ -7,6 +7,7 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NamedFieldPuns #-} module SmartTokens.Types.PTokenDirectory ( DirectorySetNode (..), @@ -46,20 +47,69 @@ import Plutarch.Unsafe (punsafeCoerce) import PlutusLedgerApi.V3 (BuiltinByteString, Credential, CurrencySymbol) import PlutusTx (Data (B, Constr), FromData, ToData, UnsafeFromData) import SmartTokens.CodeLens (_printTerm) +import PlutusLedgerApi.Data.V3 (Credential(PubKeyCredential)) +import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) +import qualified Data.Tuple as BI +import PlutusTx.IsData.Class (ToData(toBuiltinData)) +import qualified PlutusTx.Builtins as BI +import PlutusLedgerApi.V1 (FromData(fromBuiltinData), PubKeyHash (..)) +import PlutusTx.Builtins.HasOpaque (stringToBuiltinByteString) + +{- +>>> _printTerm $ unsafeEvalTerm NoTracing (pconstant blacklistInitialNode) +"program\n 1.0.0\n (List [B #, B #ffffffffffffffffffffffffffffffffffffffffffffffffffffffff])" +-} +blacklistInitialNode :: BlacklistNode +blacklistInitialNode = + BlacklistNode + -- FIXME: fix this hacky bstr + { blnNext= case PubKeyCredential "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff" of + PubKeyCredential (PubKeyHash bstr) -> bstr + , blnKey= ""} data BlacklistNode = BlacklistNode { - blnKey :: Credential, - blnNext :: Credential + blnKey :: BuiltinByteString, + blnNext :: BuiltinByteString } deriving stock (Show, Eq, Generic) deriving anyclass (SOP.Generic) deriving (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) via (ProductIsData BlacklistNode) +-- instance PlutusTx.ToData BlacklistNode where +-- toBuiltinData BlacklistNode{blnKey, blnNext} = +-- let blnKeyBstr = head $ snd $ BI.unsafeDataAsConstr (toBuiltinData blnKey) +-- blnNextBstr = head $ snd $ BI.unsafeDataAsConstr (toBuiltinData blnNext) +-- in BI.mkList [blnKeyBstr, blnNextBstr] +-- +-- instance PlutusTx.FromData BlacklistNode where +-- fromBuiltinData builtinData = +-- let fields = BI.unsafeDataAsList builtinData +-- key = head fields +-- fields1 = tail fields +-- next = head fields1 +-- in Just $ undefined -- Don't know how to determine whether credential is pub key or script + + deriving via (DerivePConstantViaData BlacklistNode PBlacklistNode) instance (PConstantDecl BlacklistNode) +{- +>>> _printTerm $ unsafeEvalTerm NoTracing (mkRecordConstr PBlacklistNode (#blnKey .= pconstant "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff" .& #blnNext .= pconstant "")) +No instance for `IsString (PAsDataLifted PByteString)' + arising from the literal `"ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"' +In the first argument of `pconstant', namely + `"ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"' +In the second argument of `(.=)', namely + `pconstant + "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"' +In the first argument of `(.&)', namely + `#blnKey + .= + pconstant + "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"' +-} newtype PBlacklistNode (s :: S) = PBlacklistNode ( Term diff --git a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs index 11abdbe..1589ddf 100644 --- a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs @@ -141,16 +141,16 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i programmable logic payment credential (even in the case of non-programmable tokens) otherwise the transaction will fail onchain validation. -} -transferProgrammableToken :: forall env era m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => [C.TxIn] -> CurrencySymbol -> [UTxODat era DirectorySetNode] -> m () -transferProgrammableToken _ _ [] = error "directory list not initialised" -transferProgrammableToken tokenTxIns programmableTokenSymbol directoryList = Utils.inBabbage @era $ do +transferProgrammableToken :: forall env era m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> [C.TxIn] -> CurrencySymbol -> [UTxODat era DirectorySetNode] -> m () +transferProgrammableToken _ _ _ [] = error "directory list not initialised" +transferProgrammableToken paramsTxIn tokenTxIns programmableTokenSymbol directoryList = Utils.inBabbage @era $ do nid <- queryNetworkId - paramsPolId <- asks (Env.protocolParamsPolicyId . Env.directoryEnv) - paramsTxIn <- asks (Env.dsTxIn . Env.directoryEnv) - let globalStakeScript = programmableLogicGlobalScript paramsPolId - globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript - baseSpendingScript = programmableLogicBaseScript globalStakeCred + baseSpendingScript <- asks (Env.dsProgrammableLogicBaseScript . Env.directoryEnv) + globalStakeScript <- asks (Env.dsProgrammableLogicGlobalScript . Env.directoryEnv) + + + let globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript -- Finds the directory node with the highest key that is less than or equal -- to the programmable token symbol @@ -173,7 +173,7 @@ transferProgrammableToken tokenTxIns programmableTokenSymbol directoryList = Uti programmableGlobalWitness txBody = buildScriptWitness globalStakeScript C.NoScriptDatumForStake (programmableLogicGlobalRedeemer txBody) - addReference paramsTxIn -- Protocol Params TxIn + addReference (uIn paramsTxIn) -- Protocol Params TxIn addReference dirNodeRef -- Directory Node TxIn traverse_ (\tin -> spendPlutusInlineDatum tin baseSpendingScript ()) tokenTxIns addWithdrawalWithTxBody -- Add the global script witness to the transaction diff --git a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs index 901e576..e019aab 100644 --- a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs @@ -14,13 +14,11 @@ where import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C -import Control.Lens (over) import Control.Monad.Reader (MonadReader, asks) -import Convex.BuildTx (MonadBuildTx, addBtx, addReference, addRequiredSignature, +import Convex.BuildTx (MonadBuildTx, addReference, addRequiredSignature, addScriptWithdrawal, addWithdrawalWithTxBody, buildScriptWitness, findIndexReference, mintPlutus, payToAddress, prependTxOut, spendPlutusInlineDatum) -import Convex.CardanoApi.Lenses as L import Convex.Class (MonadBlockchain (queryNetworkId)) import Convex.PlutusLedger.V1 (transCredential, transPolicyId, unTransStakeCredential) @@ -28,16 +26,13 @@ import Convex.Scripts qualified as C import Convex.Utils qualified as Utils import Convex.Utxos (UtxoSet (UtxoSet)) import Convex.Wallet (selectMixedInputsCovering) -import Convex.Wallet.Operator (Operator (..), verificationKey) import Data.Foldable (maximumBy) import Data.Function (on) import Data.Monoid (Last (..)) -import Debug.Trace (trace) import GHC.Exts (IsList (..)) import PlutusLedgerApi.Data.V3 (Credential (..), PubKeyHash (PubKeyHash), ScriptHash (..)) import PlutusLedgerApi.V3 qualified as PlutusTx -import SmartTokens.CodeLens (_printTerm) import SmartTokens.Contracts.ExampleTransferLogic (BlacklistProof (..)) import SmartTokens.Types.ProtocolParams import SmartTokens.Types.PTokenDirectory (BlacklistNode (..), @@ -60,8 +55,18 @@ intaFromEnv = do } +{- +>>> _printTerm $ unsafeEvalTerm NoTracing (pconstant blacklistInitialNode) +"program\n 1.0.0\n (List [B #, B #ffffffffffffffffffffffffffffffffffffffffffffffffffffffff])" + +-} blacklistInitialNode :: BlacklistNode -blacklistInitialNode = BlacklistNode {blnNext=PubKeyCredential "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff", blnKey= PubKeyCredential ""} +blacklistInitialNode = + BlacklistNode + -- FIXME: fix this hacky bstr + { blnNext= case PubKeyCredential "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff" of + PubKeyCredential (PubKeyHash bstr) -> bstr + , blnKey= ""} initBlacklist :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m () initBlacklist = Utils.inBabbage @era $ do @@ -102,19 +107,20 @@ insertBlacklistNode cred blacklistNodes = Utils.inBabbage @era $ do mintPlutus mintingScript () newAssetName quantity let + -- find the node to insert on UTxODat {uIn = prevNodeRef,uOut = (C.TxOut prevAddr prevVal _ _), uDatum = prevNode} = maximumBy (compare `on` (blnKey . uDatum)) $ - filter ((<= transCredential cred) . blnKey . uDatum) blacklistNodes + filter ((<= unwrapCredential (transCredential cred)) . blnKey . uDatum) blacklistNodes -- create new blacklist node data - newNode = BlacklistNode {blnNext=blnNext prevNode, blnKey= transCredential cred} + newNode = BlacklistNode {blnNext=blnNext prevNode, blnKey= unwrapCredential (transCredential cred)} newNodeDatum = C.TxOutDatumInline C.babbageBasedEra $ C.toHashableScriptData newNode newNodeVal = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra $ fromList [(C.AssetId (scriptPolicyIdV3 mintingScript) newAssetName, quantity)] newNodeOutput = C.TxOut prevAddr newNodeVal newNodeDatum C.ReferenceScriptNone -- update the previous node to point to the new node - newPrevNode = prevNode {blnNext=transCredential cred} + newPrevNode = prevNode {blnNext=unwrapCredential (transCredential cred)} newPrevNodeDatum = C.TxOutDatumInline C.babbageBasedEra $ C.toHashableScriptData newPrevNode newPrevNodeOutput = C.TxOut prevAddr prevVal newPrevNodeDatum C.ReferenceScriptNone @@ -133,7 +139,7 @@ insertBlacklistNode cred blacklistNodes = Utils.inBabbage @era $ do -- TODO _removeBlacklistNode = undefined -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 () +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 nid <- queryNetworkId @@ -148,9 +154,10 @@ issueSmartTokens paramsTxOut (an, q) directoryList destinationCred = Utils.inBab addIssueWitness payToAddress addr value + 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) => C.PaymentCredential -> [UTxODat era BlacklistNode] -> [UTxODat era DirectorySetNode] -> [UTxODat era a] -> (C.AssetId, C.Quantity) -> C.PaymentCredential -> m () -transferSmartTokens userCred blacklistNodes directoryList spendingUserOutputs (assetId, q) destinationCred = Utils.inBabbage @era $ do +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) => UTxODat era ProgrammableLogicGlobalParams -> C.PaymentCredential -> [UTxODat era BlacklistNode] -> [UTxODat era DirectorySetNode] -> [UTxODat era a] -> (C.AssetId, C.Quantity) -> C.PaymentCredential -> m () +transferSmartTokens paramsTxIn userCred blacklistNodes directoryList spendingUserOutputs (assetId, q) destinationCred = Utils.inBabbage @era $ do nid <- queryNetworkId progLogicBaseCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) @@ -163,7 +170,7 @@ transferSmartTokens userCred blacklistNodes directoryList spendingUserOutputs (a C.AssetId policyId _ -> policyId C.AdaAssetId -> error "Ada is not programmable" - transferProgrammableToken txins (transPolicyId programmablePolicyId) directoryList -- Invoking the programmableBase and global scripts + transferProgrammableToken paramsTxIn txins (transPolicyId programmablePolicyId) directoryList -- Invoking the programmableBase and global scripts addTransferWitness blacklistNodes userCred -- Proof of non-membership of the blacklist -- Send outputs to destinationCred @@ -173,11 +180,12 @@ transferSmartTokens userCred blacklistNodes directoryList spendingUserOutputs (a payToAddress destinationAddress destinationVal -- Return change to the spendingUserOutputs address + srcStakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential userCred let returnVal = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra $ fromList [(assetId, C.selectAsset totalVal assetId - q)] - returnAddr = undefined + returnAddr = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue srcStakeCred) returnOutput = C.TxOut returnAddr returnVal C.TxOutDatumNone C.ReferenceScriptNone prependTxOut returnOutput -- Add the seized output to the transaction @@ -214,15 +222,17 @@ addIssueWitness = Utils.inBabbage @era $ do addRequiredSignature opPkh 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) => [UTxODat era BlacklistNode] -> C.PaymentCredential -> m () +addTransferWitness :: forall env era m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => [UTxODat era BlacklistNode] -> C.PaymentCredential -> m () addTransferWitness blacklistNodes clientCred = Utils.inBabbage @era $ do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) -- In this case 'operator' is the user nid <- queryNetworkId transferScript <- asks (Env.tleTransferScript . Env.transferLogicEnv) - let transferStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 transferScript + let + transferStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 transferScript UTxODat {uIn = blnNodeRef, uDatum = blnNodeDatum} = maximumBy (compare `on` (blnKey . uDatum)) $ - filter ((<= transCredential clientCred) . blnKey . uDatum) blacklistNodes + filter ((<= unwrapCredential (transCredential clientCred)) . blnKey . uDatum) blacklistNodes -- Finds the index of the blacklist node reference in the transaction ref -- inputs @@ -232,13 +242,14 @@ addTransferWitness blacklistNodes clientCred = Utils.inBabbage @era $ do -- The redeemer for the transfer script based on whether a blacklist node -- exists with the client credential transferRedeemer txBody = - if blnKey blnNodeDatum == transCredential clientCred + if blnKey blnNodeDatum == unwrapCredential (transCredential clientCred) then error "Credential is blacklisted" -- TODO: handle this and other error cases properly else NonmembershipProof $ blacklistNodeReferenceIndex txBody -- TODO: extend this to handle multiple proofs (i.e. transfers) per tx, onchain allows it transferWitness txBody = buildScriptWitness transferScript C.NoScriptDatumForStake [transferRedeemer txBody] + addRequiredSignature opPkh addReference blnNodeRef -- Add the blacklist node reference to the transaction addWithdrawalWithTxBody -- Add the global script witness to the transaction (C.makeStakeAddress nid transferStakeCred) @@ -252,3 +263,8 @@ addSeizeWitness = Utils.inBabbage @era $ do let sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 seizeScript addRequiredSignature opPkh addScriptWithdrawal sh 0 $ buildScriptWitness seizeScript C.NoScriptDatumForStake () + +unwrapCredential :: Credential -> PlutusTx.BuiltinByteString +unwrapCredential = \case + PubKeyCredential (PubKeyHash s) -> s + ScriptCredential (ScriptHash s) -> s diff --git a/src/lib/Wst/Offchain/Endpoints/Deployment.hs b/src/lib/Wst/Offchain/Endpoints/Deployment.hs index ee92c6d..641561f 100644 --- a/src/lib/Wst/Offchain/Endpoints/Deployment.hs +++ b/src/lib/Wst/Offchain/Endpoints/Deployment.hs @@ -8,6 +8,8 @@ module Wst.Offchain.Endpoints.Deployment( issueSmartTokensTx, transferSmartTokensTx, insertBlacklistNodeTx, + blacklistCredentialTx, + seizeCredentialAssetsTx, ) where import Cardano.Api (Quantity) @@ -39,7 +41,7 @@ deployTx = do (txi, _) <- Env.selectOperatorOutput opEnv <- asks Env.operatorEnv (tx, _) <- Env.withEnv $ Env.withOperator opEnv $ Env.withDirectoryFor txi - $ Env.balanceTxEnv + $ Env.balanceTxEnv_ $ BuildTx.mintProtocolParams >> BuildTx.initDirectorySet pure (Convex.CoinSelection.signBalancedTxBody [] tx, txi) @@ -57,7 +59,7 @@ insertNodeTx args = do -- 2. Find the global parameter node paramsNode <- Query.globalParamsNode @era - (tx, _) <- Env.balanceTxEnv (BuildTx.insertDirectoryNode paramsNode headNode args) + (tx, _) <- Env.balanceTxEnv_ (BuildTx.insertDirectoryNode paramsNode headNode args) pure (Convex.CoinSelection.signBalancedTxBody [] tx) {-| Build a transaction that issues a progammable token @@ -79,7 +81,7 @@ issueProgrammableTokenTx :: forall era env m. issueProgrammableTokenTx issueTokenArgs assetName quantity = do directory <- Query.registryNodes @era paramsNode <- Query.globalParamsNode @era - (tx, _) <- Env.balanceTxEnv $ do + (tx, _) <- Env.balanceTxEnv_ $ do _ <- BuildTx.issueProgrammableToken paramsNode (assetName, quantity) issueTokenArgs directory let hsh = C.hashScript (C.PlutusScript C.plutusScriptVersion $ BuildTx.intaMintingLogic issueTokenArgs) @@ -90,14 +92,13 @@ deployBlacklistTx :: (MonadReader env m, Env.HasOperatorEnv era env, MonadBlockc deployBlacklistTx = do opEnv <- asks Env.operatorEnv (tx, _) <- Env.withEnv $ Env.withOperator opEnv - $ Env.balanceTxEnv - $ BuildTx.initBlacklist + $ Env.balanceTxEnv_ BuildTx.initBlacklist pure (Convex.CoinSelection.signBalancedTxBody [] tx) insertBlacklistNodeTx :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadUtxoQuery m) => C.PaymentCredential -> m (C.Tx era) insertBlacklistNodeTx cred = do blacklist <- Query.blacklistNodes @era - (tx, _) <- Env.balanceTxEnv (BuildTx.insertBlacklistNode cred blacklist) + (tx, _) <- Env.balanceTxEnv_ (BuildTx.insertBlacklistNode cred blacklist) pure (Convex.CoinSelection.signBalancedTxBody [] tx) {-| Build a transaction that issues a progammable token @@ -116,13 +117,13 @@ issueSmartTokensTx :: forall era env m. => C.AssetName -- ^ Name of the asset -> Quantity -- ^ Amount of tokens to be minted -> C.PaymentCredential -- ^ Destination credential - -> m (C.Tx era) + -> m (C.Tx era, C.AssetId) issueSmartTokensTx assetName quantity destinationCred = do directory <- Query.registryNodes @era paramsNode <- Query.globalParamsNode @era - (tx, _) <- Env.balanceTxEnv $ do + ((tx, _), aid) <- Env.balanceTxEnv $ do BuildTx.issueSmartTokens paramsNode (assetName, quantity) directory destinationCred - pure (Convex.CoinSelection.signBalancedTxBody [] tx) + pure (Convex.CoinSelection.signBalancedTxBody [] tx, aid) {-| Build a transaction that issues a progammable token -} @@ -138,14 +139,52 @@ transferSmartTokensTx :: forall era env m. , MonadUtxoQuery m ) => C.PaymentCredential -- ^ Source/User credential - -> C.AssetId -- ^ Name of the asset + -> C.AssetId -- ^ AssetId to transfer -> Quantity -- ^ Amount of tokens to be minted -> C.PaymentCredential -- ^ Destination credential -> m (C.Tx era) -transferSmartTokensTx srcCred assetName quantity destCred = do +transferSmartTokensTx srcCred assetId quantity destCred = do directory <- Query.registryNodes @era blacklist <- Query.blacklistNodes @era - userOutputsAtProgrammable <- undefined - (tx, _) <- Env.balanceTxEnv $ do - BuildTx.transferSmartTokens srcCred blacklist directory userOutputsAtProgrammable (assetName, quantity) destCred + userOutputsAtProgrammable <- Query.userProgrammableOutputs srcCred + paramsTxIn <- Query.globalParamsNode @era + (tx, _) <- Env.balanceTxEnv_ $ do + BuildTx.transferSmartTokens paramsTxIn srcCred blacklist directory userOutputsAtProgrammable (assetId, quantity) destCred + pure (Convex.CoinSelection.signBalancedTxBody [] tx) + +blacklistCredentialTx :: forall era env m. + ( MonadReader env m + , Env.HasOperatorEnv era env + , Env.HasTransferLogicEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => C.PaymentCredential -- ^ Source/User credential + -> m (C.Tx era) +blacklistCredentialTx sanctionedCred = do + blacklist <- Query.blacklistNodes @era + (tx, _) <- Env.balanceTxEnv_ $ do + BuildTx.insertBlacklistNode sanctionedCred blacklist pure (Convex.CoinSelection.signBalancedTxBody [] tx) + +seizeCredentialAssetsTx :: forall era env m. + ( MonadReader env m + , Env.HasOperatorEnv era env + , Env.HasTransferLogicEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => C.PaymentCredential -- ^ Source/User credential + -> m (C.Tx era) +seizeCredentialAssetsTx sanctionedCred = do + pure undefined + -- blacklist <- Query.blacklistNodes @era + -- (tx, _) <- Env.balanceTxEnv_ $ do + -- BuildTx.insertBlacklistNode sanctionedCred blacklist + -- pure (Convex.CoinSelection.signBalancedTxBody [] tx) diff --git a/src/lib/Wst/Offchain/Env.hs b/src/lib/Wst/Offchain/Env.hs index 3704554..b3d497d 100644 --- a/src/lib/Wst/Offchain/Env.hs +++ b/src/lib/Wst/Offchain/Env.hs @@ -16,6 +16,7 @@ module Wst.Offchain.Env( -- ** Using the operator environment selectOperatorOutput, balanceTxEnv, + balanceTxEnv_, -- * Directory environment HasDirectoryEnv(..), @@ -129,8 +130,8 @@ selectOperatorOutput = asks (listToMaybe . Map.toList . C.unUTxO . bteOperatorUt {-| Balance a transaction using the operator's funds and return output -} -balanceTxEnv :: forall era env a m. (MonadBlockchain era m, MonadReader env m, HasOperatorEnv era env, MonadError (AppError era) m, C.IsBabbageBasedEra era) => BuildTxT era m a -> m (C.BalancedTxBody era, BalanceChanges) -balanceTxEnv btx = do +balanceTxEnv_ :: forall era env a m. (MonadBlockchain era m, MonadReader env m, HasOperatorEnv era env, MonadError (AppError era) m, C.IsBabbageBasedEra era) => BuildTxT era m a -> m (C.BalancedTxBody era, BalanceChanges) +balanceTxEnv_ btx = do OperatorEnv{bteOperatorUtxos, bteOperator} <- asks operatorEnv params <- queryProtocolParameters txBuilder <- BuildTx.execBuildTxT $ btx >> BuildTx.setMinAdaDepositAll params @@ -139,6 +140,20 @@ balanceTxEnv btx = do output <- returnOutputFor (C.PaymentCredentialByKey $ fst bteOperator) mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange) +{-| Balance a transaction using the operator's funds and return output +-} +balanceTxEnv :: forall era env a m. (MonadBlockchain era m, MonadReader env m, HasOperatorEnv era env, MonadError (AppError era) m, C.IsBabbageBasedEra era) => BuildTxT era m a -> m ((C.BalancedTxBody era, BalanceChanges), a) +balanceTxEnv btx = do + OperatorEnv{bteOperatorUtxos, bteOperator} <- asks operatorEnv + params <- queryProtocolParameters + (r, txBuilder) <- BuildTx.runBuildTxT $ btx <* BuildTx.setMinAdaDepositAll params + -- TODO: change returnOutputFor to consider the stake address reference + -- (needs to be done in sc-tools) + output <- returnOutputFor (C.PaymentCredentialByKey $ fst bteOperator) + (balBody, balChanges) <- mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange) + pure ((balBody, balChanges), r) + + class HasDirectoryEnv e where directoryEnv :: e -> DirectoryEnv @@ -164,7 +179,7 @@ mkDirectoryEnv dsTxIn = dsProtocolParamsMintingScript = protocolParamsMintingScript dsTxIn dsDirectorySpendingScript = directoryNodeSpendingScript (protocolParamsPolicyId result) dsProgrammableLogicBaseScript = programmableLogicBaseScript (programmableLogicStakeCredential result) -- Parameterized by the stake cred of the global script - dsProgrammableLogicGlobalScript = programmableLogicGlobalScript (directoryNodePolicyId result) -- Parameterized by the CS holding protocol params datum + dsProgrammableLogicGlobalScript = programmableLogicGlobalScript (protocolParamsPolicyId result) -- Parameterized by the CS holding protocol params datum result = DirectoryEnv { dsTxIn , dsDirectoryMintingScript diff --git a/src/lib/Wst/Offchain/Query.hs b/src/lib/Wst/Offchain/Query.hs index 5194cc7..1ea3b87 100644 --- a/src/lib/Wst/Offchain/Query.hs +++ b/src/lib/Wst/Offchain/Query.hs @@ -7,6 +7,7 @@ module Wst.Offchain.Query( registryNodes, globalParamsNode, programmableLogicOutputs, + userProgrammableOutputs, -- * UTxO with datum UTxODat(..), @@ -19,13 +20,14 @@ import Control.Monad ((>=>)) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) import Convex.CardanoApi.Lenses qualified as L -import Convex.Class (MonadUtxoQuery, utxosByPaymentCredential) +import Convex.Class (MonadBlockchain (queryNetworkId), MonadUtxoQuery, + utxosByPaymentCredential) +import Convex.PlutusLedger.V1 (transCredential, unTransStakeCredential) import Convex.Scripts (fromHashableScriptData) import Convex.Utxos (UtxoSet, toApiUtxo) import Data.Aeson (FromJSON, ToJSON) import Data.Map qualified as Map import Data.Maybe (listToMaybe, mapMaybe) -import Debug.Trace (trace) import GHC.Generics (Generic) import PlutusTx qualified import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) @@ -64,6 +66,17 @@ blacklistNodes = asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . tleBlacklistSpendingScript . transferLogicEnv) >>= fmap (extractUTxO @era) . utxosByPaymentCredential +userProgrammableOutputs :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era, MonadBlockchain era m) => C.PaymentCredential -> m [UTxODat era ()] +userProgrammableOutputs userCred = do + nid <- queryNetworkId + baseCred <- asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicBaseScript . directoryEnv) + + userStakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential userCred + let expectedAddress = C.makeShelleyAddressInEra C.shelleyBasedEra nid baseCred (C.StakeAddressByValue userStakeCred) + isUserUtxo UTxODat{uOut=(C.TxOut addr _ _ _)} = addr == expectedAddress + + filter isUserUtxo <$> programmableLogicOutputs + {-| Find the UTxO with the global params -} globalParamsNode :: forall era m. (MonadUtxoQuery m, C.IsBabbageBasedEra era, MonadError (AppError era) m) => m (UTxODat era ProgrammableLogicGlobalParams) diff --git a/src/lib/Wst/Offchain/Scripts.hs b/src/lib/Wst/Offchain/Scripts.hs index 56f206d..598c508 100644 --- a/src/lib/Wst/Offchain/Scripts.hs +++ b/src/lib/Wst/Offchain/Scripts.hs @@ -101,7 +101,7 @@ programmableLogicBaseScript globalCred = programmableLogicGlobalScript :: C.PolicyId -> C.PlutusScript C.PlutusScriptV3 -- Parameterized by the CS holding protocol params datum programmableLogicGlobalScript paramsPolId = - let script = tryCompile prodConfig $ mkProgrammableLogicGlobal # pdata (pconstant $ transPolicyId paramsPolId) + let script = tryCompile tracingConfig $ mkProgrammableLogicGlobal # pdata (pconstant $ transPolicyId paramsPolId) in C.PlutusScriptSerialised $ serialiseScript script permissionedTransferScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3 diff --git a/src/test/Wst/Test/Env.hs b/src/test/Wst/Test/Env.hs index 1294d33..9b3c7ee 100644 --- a/src/test/Wst/Test/Env.hs +++ b/src/test/Wst/Test/Env.hs @@ -2,7 +2,8 @@ -} module Wst.Test.Env( admin, - asAdmin + asAdmin, + asWallet, ) where import Cardano.Api.Shelley qualified as C @@ -24,6 +25,13 @@ admin = , oStakeKey = Nothing } +user :: Wallet.Wallet -> Operator Signing +user w = + Operator + { oPaymentKey = PESigning (Wallet.getWallet w) + , oStakeKey = Nothing + } + {-| Run an action using the "admin" key. Deploying the system, minting stablecoins, etc. -} asAdmin :: forall era o d r m a. @@ -37,3 +45,15 @@ asAdmin action = do (C.verificationKeyHash . Operator.verificationKey . oPaymentKey $ admin) (maybe C.NoStakeAddress (C.StakeAddressByValue . C.StakeCredentialByKey . C.verificationKeyHash) $ Operator.oStakeKey admin) Env.withOperator env action + +asWallet :: forall era o d r m a. + ( MonadUtxoQuery m + , C.IsBabbageBasedEra era + , MonadReader (Env.CombinedEnv o d r era) m + ) + => Wallet.Wallet -> ReaderT (Env.CombinedEnv Identity d r era) m a -> m a +asWallet w action = do + env <- Env.loadOperatorEnv + (C.verificationKeyHash . Operator.verificationKey . oPaymentKey $ user w) + (maybe C.NoStakeAddress (C.StakeAddressByValue . C.StakeCredentialByKey . C.verificationKeyHash) $ Operator.oStakeKey $ user w) + Env.withOperator env action diff --git a/src/test/Wst/Test/UnitTest.hs b/src/test/Wst/Test/UnitTest.hs index 4f89edd..d2f1842 100644 --- a/src/test/Wst/Test/UnitTest.hs +++ b/src/test/Wst/Test/UnitTest.hs @@ -7,24 +7,18 @@ import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C import Cardano.Ledger.Core qualified as Ledger import Control.Lens ((^.)) -import Control.Monad (void, (<=<)) +import Control.Monad (void) import Control.Monad.Reader (asks) import Control.Monad.Reader.Class (MonadReader) import Convex.BuildTx qualified as BuildTx -import Convex.Class (MonadBlockchain (queryNetworkId, queryProtocolParameters, sendTx), - MonadMockchain, MonadUtxoQuery, nextSlot, - utxosByPaymentCredential) +import Convex.Class (MonadBlockchain (queryProtocolParameters, sendTx), + MonadMockchain, MonadUtxoQuery) import Convex.CoinSelection (ChangeOutputPosition (TrailingChange)) import Convex.MockChain.CoinSelection (tryBalanceAndSubmit) import Convex.MockChain.Utils (mockchainSucceeds) import Convex.Utils (failOnError) -import Convex.Wallet (paymentCredential) -import Convex.Wallet qualified as BuildTx import Convex.Wallet.MockWallet qualified as Wallet import Convex.Wallet.Operator (signTxOperator) -import Convex.Wallet.Operator qualified as Env -import Debug.Trace (trace) -import GHC.IsList (IsList (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..)) @@ -33,7 +27,9 @@ import Wst.Offchain.Endpoints.Deployment qualified as Endpoints import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query qualified as Query import Wst.Offchain.Scripts qualified as Scripts -import Wst.Test.Env (admin, asAdmin) +import Wst.Test.Env (admin, asAdmin, asWallet) +import Cardano.Ledger.Shelley.TxCert qualified as TxCert +import Convex.BuildTx tests :: TestTree tests = testGroup "unit tests" @@ -41,8 +37,9 @@ tests = testGroup "unit tests" , testCase "insert directory node" (mockchainSucceeds insertDirectoryNode) , testGroup "issue programmable tokens" [ testCase "always succeeds validator" (mockchainSucceeds issueAlwaysSucceedsValidator) - , testCase "transfer logic issuance" (mockchainSucceeds issueTransferLogicProgrammableToken) - -- TODO: Add test for the seize/freeze validator + , testCase "smart token issuance" (mockchainSucceeds issueSmartTokensScenario) + , testCase "smart token transfer" (mockchainSucceeds transferSmartTokens) + , testCase "blacklist credential" (mockchainSucceeds (void blacklistCredential)) ] ] @@ -85,16 +82,13 @@ issueAlwaysSucceedsValidator = failOnError $ Env.withEnv $ do >>= void . expectN 1 "programmable logic outputs" pure () +issueSmartTokensScenario :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m C.AssetId +issueSmartTokensScenario = deployDirectorySet >>= issueTransferLogicProgrammableToken + {-| Issue some tokens with the smart stabelcoin transfer logic validator -} -issueTransferLogicProgrammableToken :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () -issueTransferLogicProgrammableToken = failOnError $ Env.withEnv $ do - - -- register transfer minting script - -- register transfer spending script - -- register issuer spending script - - txI <- deployDirectorySet +issueTransferLogicProgrammableToken :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => C.TxIn -> m C.AssetId +issueTransferLogicProgrammableToken txI = failOnError $ Env.withEnv $ do asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) @@ -104,36 +98,64 @@ issueTransferLogicProgrammableToken = failOnError $ Env.withEnv $ do asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) - Endpoints.issueSmartTokensTx "dummy asset" 100 (C.PaymentCredentialByKey opPkh) - >>= void . sendTx . signTxOperator admin + (balTx, aid) <- Endpoints.issueSmartTokensTx "dummy asset" 100 (C.PaymentCredentialByKey opPkh) + void $ sendTx $ signTxOperator admin balTx + Query.registryNodes @C.ConwayEra >>= void . expectN 2 " registry outputs" Query.programmableLogicOutputs @C.ConwayEra >>= void . expectN 1 "programmable logic outputs" - pure () + pure aid {-| Issue some tokens with the smart stabelcoin transfer logic validator -} -transferTransferLogicProgrammableToken :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () -transferTransferLogicProgrammableToken = failOnError $ Env.withEnv $ do - +transferSmartTokens :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () +transferSmartTokens = failOnError $ Env.withEnv $ do + userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv) txI <- deployDirectorySet - asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ do - opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) - -- register programmable global stake script - void $ registerTransferScripts opPkh + asAdmin @C.ConwayEra $ do + Endpoints.deployBlacklistTx + >>= void . sendTx . signTxOperator admin + Query.blacklistNodes @C.ConwayEra + >>= void . expectSingleton "blacklist output" + + aid <- issueTransferLogicProgrammableToken txI asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) - Endpoints.issueSmartTokensTx "dummy asset" 100 (C.PaymentCredentialByKey opPkh) + Endpoints.transferSmartTokensTx (C.PaymentCredentialByKey opPkh) aid 80 (C.PaymentCredentialByKey userPkh) >>= void . sendTx . signTxOperator admin - Query.registryNodes @C.ConwayEra - >>= void . expectN 2 " registry outputs" + Query.programmableLogicOutputs @C.ConwayEra - >>= void . expectN 1 "programmable logic outputs" - pure () + >>= void . expectN 2 "programmable logic outputs" + Query.userProgrammableOutputs (C.PaymentCredentialByKey userPkh) + >>= void . expectN 1 "user programmable outputs" + Query.userProgrammableOutputs (C.PaymentCredentialByKey opPkh) + >>= void . expectN 1 "user programmable outputs" + +blacklistCredential :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m C.PaymentCredential +blacklistCredential = failOnError $ Env.withEnv $ do + userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv) + let paymentCred = C.PaymentCredentialByKey userPkh + + txIn <- deployDirectorySet + + asAdmin @C.ConwayEra $ do + Endpoints.deployBlacklistTx + >>= void . sendTx . signTxOperator admin + Query.blacklistNodes @C.ConwayEra + >>= void . expectSingleton "blacklist output" + + asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ do + Endpoints.blacklistCredentialTx paymentCred + >>= void . sendTx . signTxOperator admin + + Query.blacklistNodes @C.ConwayEra + >>= void . expectN 2 "blacklist output" + + pure paymentCred dummyNodeArgs :: InsertNodeArgs @@ -157,37 +179,40 @@ registerAlwaysSucceedsStakingCert = failOnError $ do BuildTx.addConwayStakeCredentialRegistrationCertificate cred (pp ^. Ledger.ppKeyDepositL) void (tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange []) -registerTransferScripts :: (MonadFail m, MonadReader env m, Env.HasTransferLogicEnv env, MonadMockchain C.ConwayEra m) => C.Hash C.PaymentKey -> m C.TxId +registerTransferScripts :: (MonadFail m, MonadReader env m, Env.HasDirectoryEnv env, Env.HasTransferLogicEnv env, MonadMockchain C.ConwayEra m) => C.Hash C.PaymentKey -> m C.TxId registerTransferScripts pkh = failOnError $ do pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters - mintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv) - spendingScript <- asks (Env.tleTransferScript . Env.transferLogicEnv) - -- issuerScript <- asks (Env.tleIssuerScript . Env.transferLogicEnv) + transferMintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv) + transferSpendingScript <- asks (Env.tleTransferScript . Env.transferLogicEnv) + transferGlobalScript <- asks (Env.dsProgrammableLogicGlobalScript . Env.directoryEnv) let - hshMinting = C.hashScript $ C.PlutusScript C.plutusScriptVersion mintingScript + hshMinting = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferMintingScript credMinting = C.StakeCredentialByScript hshMinting - hshSpending = C.hashScript $ C.PlutusScript C.plutusScriptVersion spendingScript + hshSpending = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferSpendingScript credSpending = C.StakeCredentialByScript hshSpending - -- hshIssuer = C.hashScript $ C.PlutusScript C.plutusScriptVersion issuerScript - -- credIssuer = C.StakeCredentialByScript hshIssuer + hshGlobal = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferGlobalScript + credGlobal = C.StakeCredentialByScript hshGlobal txBody <- BuildTx.execBuildTxT $ do - BuildTx.addStakeScriptWitness credMinting mintingScript () + BuildTx.addStakeScriptWitness credMinting transferMintingScript () BuildTx.addConwayStakeCredentialRegistrationCertificate credMinting (pp ^. Ledger.ppKeyDepositL) - BuildTx.addStakeScriptWitness credSpending spendingScript () - BuildTx.addConwayStakeCredentialRegistrationCertificate credSpending (pp ^. Ledger.ppKeyDepositL) - - -- BuildTx.addStakeScriptWitness credIssuer issuerScript () - -- BuildTx.addConwayStakeCredentialRegistrationCertificate credIssuer (pp ^. Ledger.ppKeyDepositL) + addStakeCredentialCertificate credSpending + addStakeCredentialCertificate credGlobal BuildTx.addRequiredSignature pkh x <- tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange [] pure $ C.getTxId $ C.getTxBody x +{-| Add a 'C.StakeCredential' as a certificate to the transaction +-} +addStakeCredentialCertificate :: forall era m. C.IsConwayBasedEra era => MonadBuildTx era m => C.StakeCredential -> m () +addStakeCredentialCertificate stk = + C.conwayEraOnwardsConstraints @era C.conwayBasedEra $ + addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.RegTxCert $ C.toShelleyStakeCredential stk expectSingleton :: MonadFail m => String -> [a] -> m a expectSingleton msg = \case