From fd89c6eab181dea93ba80150412997baa7a30432 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Mon, 30 Dec 2024 12:48:11 +0100 Subject: [PATCH] Fix alwaysSucceeds script --- src/lib/Wst/Offchain/BuildTx/TransferLogic.hs | 26 +++++++++++++------ src/lib/Wst/Offchain/Endpoints/Deployment.hs | 4 ++- src/lib/Wst/Offchain/Env.hs | 9 +++++++ src/test/Wst/Test/UnitTest.hs | 4 --- 4 files changed, 30 insertions(+), 13 deletions(-) diff --git a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs index 39bf954..853bc08 100644 --- a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs @@ -9,6 +9,7 @@ module Wst.Offchain.BuildTx.TransferLogic seizeSmartTokens, initBlacklist, insertBlacklistNode, + paySmartTokensToDestination ) where @@ -139,21 +140,30 @@ insertBlacklistNode cred blacklistNodes = Utils.inBabbage @era $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) addRequiredSignature opPkh -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 +{-| Add a smart token output that locks the given value, +addressed to the payment credential +-} +paySmartTokensToDestination :: forall era env m. (MonadBuildTx era m, MonadReader env m, Env.HasDirectoryEnv env, MonadBlockchain era m, C.IsBabbageBasedEra era) => (C.AssetName, C.Quantity) -> C.PolicyId -> C.PaymentCredential -> m () +paySmartTokensToDestination (an, q) issuedPolicyId destinationCred = Utils.inBabbage @era $ do nid <- queryNetworkId - - directoryEnv <- asks Env.directoryEnv - let progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv - inta <- intaFromEnv - issuedPolicyId <- issueProgrammableToken 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 + directoryEnv <- asks Env.directoryEnv + let progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv let value = fromList [(C.AssetId issuedPolicyId an, q)] addr = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue stakeCred) - addIssueWitness payToAddress addr value + +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 + inta <- intaFromEnv + issuedPolicyId <- issueProgrammableToken paramsTxOut (an, q) inta directoryList + + + addIssueWitness + -- payToAddress addr value + paySmartTokensToDestination (an, q) issuedPolicyId destinationCred 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, Env.HasOperatorEnv era env, MonadError (AppError era) m) => UTxODat era ProgrammableLogicGlobalParams -> C.PaymentCredential -> [UTxODat era BlacklistNode] -> [UTxODat era DirectorySetNode] -> [UTxODat era a] -> (C.AssetId, C.Quantity) -> C.PaymentCredential -> m () diff --git a/src/lib/Wst/Offchain/Endpoints/Deployment.hs b/src/lib/Wst/Offchain/Endpoints/Deployment.hs index 9166f08..55a587f 100644 --- a/src/lib/Wst/Offchain/Endpoints/Deployment.hs +++ b/src/lib/Wst/Offchain/Endpoints/Deployment.hs @@ -30,6 +30,7 @@ import Wst.Offchain.BuildTx.DirectorySet qualified as BuildTx import Wst.Offchain.BuildTx.ProgrammableLogic qualified as BuildTx import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx import Wst.Offchain.BuildTx.TransferLogic qualified as BuildTx +import Wst.Offchain.BuildTx.TransferLogic qualified as TL import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query (UTxODat (..)) import Wst.Offchain.Query qualified as Query @@ -84,7 +85,8 @@ issueProgrammableTokenTx issueTokenArgs assetName quantity = do paramsNode <- Query.globalParamsNode @era (tx, _) <- Env.balanceTxEnv_ $ do polId <- BuildTx.issueProgrammableToken paramsNode (assetName, quantity) issueTokenArgs directory - + Env.operatorPaymentCredential + >>= BuildTx.paySmartTokensToDestination (assetName, quantity) polId let hsh = C.hashScript (C.PlutusScript C.plutusScriptVersion $ BuildTx.intaMintingLogic issueTokenArgs) BuildTx.addScriptWithdrawal hsh 0 $ BuildTx.buildScriptWitness (BuildTx.intaMintingLogic issueTokenArgs) C.NoScriptDatumForStake () pure (Convex.CoinSelection.signBalancedTxBody [] tx) diff --git a/src/lib/Wst/Offchain/Env.hs b/src/lib/Wst/Offchain/Env.hs index 48ffcb6..7aee006 100644 --- a/src/lib/Wst/Offchain/Env.hs +++ b/src/lib/Wst/Offchain/Env.hs @@ -12,6 +12,7 @@ module Wst.Offchain.Env( OperatorEnv(..), loadOperatorEnv, loadOperatorEnvFromAddress, + operatorPaymentCredential, -- ** Using the operator environment selectOperatorOutput, @@ -111,6 +112,11 @@ data OperatorEnv era = , bteOperatorUtxos :: UTxO era -- ^ UTxOs owned by the operator, available for spending } +{-| Get the operator's payment credential from the 'env' +-} +operatorPaymentCredential :: (MonadReader env m, HasOperatorEnv era env) => m C.PaymentCredential +operatorPaymentCredential = asks (C.PaymentCredentialByKey . fst . bteOperator . operatorEnv) + {-| Populate the 'OperatorEnv' with UTxOs locked by the payment credential -} loadOperatorEnv :: (MonadUtxoQuery m, C.IsBabbageBasedEra era) => C.Hash C.PaymentKey -> C.StakeAddressReference -> m (OperatorEnv era) @@ -233,6 +239,9 @@ class HasTransferLogicEnv e where instance HasTransferLogicEnv TransferLogicEnv where transferLogicEnv = id +{-| The 'TransferLogicEnv' with scripts that allow the given payment credential +to manage the blacklist and issue / burn tokens +-} mkTransferLogicEnv :: C.Hash C.PaymentKey -> TransferLogicEnv mkTransferLogicEnv cred = let blacklistMinting = blacklistMintingScript cred diff --git a/src/test/Wst/Test/UnitTest.hs b/src/test/Wst/Test/UnitTest.hs index 2e29fb8..42c33d0 100644 --- a/src/test/Wst/Test/UnitTest.hs +++ b/src/test/Wst/Test/UnitTest.hs @@ -38,9 +38,6 @@ tests = testGroup "unit tests" [ testCase "deploy directory and global params" (mockchainSucceeds deployDirectorySet) , testCase "insert directory node" (mockchainSucceeds insertDirectoryNode) , testGroup "issue programmable tokens" - -- FIXME: Fails because the minted value is not sent to the operator - -- address. If we want to keep this test we need to modify the Endpoint.issueProgrammableTokenTx - -- tx builder to pay the minted value to progLogicBaseScript with operator stake credential [ testCase "always succeeds validator" (mockchainSucceeds issueAlwaysSucceedsValidator) , testCase "smart token issuance" (mockchainSucceeds issueSmartTokensScenario) , testCase "smart token transfer" (mockchainSucceeds transferSmartTokens) @@ -240,7 +237,6 @@ registerAlwaysSucceedsStakingCert = failOnError $ do txBody <- BuildTx.execBuildTxT $ do BuildTx.addStakeScriptWitness cred Scripts.alwaysSucceedsScript () BuildTx.addConwayStakeCredentialRegistrationCertificate cred (pp ^. Ledger.ppKeyDepositL) - addStakeCredentialCertificate cred void (tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange []) registerTransferScripts :: (MonadFail m, MonadReader env m, Env.HasDirectoryEnv env, Env.HasTransferLogicEnv env, MonadMockchain C.ConwayEra m) => C.Hash C.PaymentKey -> m C.TxId