From da928b4ffe06b5b0fbbc5114f744d99fbc4331aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Fri, 20 Dec 2024 18:50:07 +0100 Subject: [PATCH] Add query for programmable logic UTxOs --- .../Wst/Offchain/BuildTx/ProgrammableLogic.hs | 55 +++++++++---------- src/lib/Wst/Offchain/Endpoints/Deployment.hs | 10 +--- src/lib/Wst/Offchain/Query.hs | 10 +++- src/test/Wst/Test/UnitTest.hs | 12 ++++ 4 files changed, 50 insertions(+), 37 deletions(-) diff --git a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs index 388bc95..7243998 100644 --- a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs @@ -19,7 +19,7 @@ where import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C import Control.Lens (over, (^.)) -import Control.Monad.Reader (MonadReader, asks, runReaderT) +import Control.Monad.Reader (MonadReader, asks) import Convex.BuildTx (MonadBuildTx, addBtx, addReference, addWithdrawalWithTxBody, buildScriptWitness, findIndexReference, findIndexSpending, mintPlutus, @@ -28,7 +28,7 @@ import Convex.CardanoApi.Lenses as L import Convex.Class (MonadBlockchain (queryNetworkId)) import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential, unTransPolicyId) -import Convex.Scripts (fromHashableScriptData) +import Convex.Scripts (toHashableScriptData) import Convex.Utils qualified as Utils import Data.Foldable (find, maximumBy, traverse_) import Data.Function (on) @@ -42,42 +42,38 @@ import SmartTokens.Types.ProtocolParams import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..), insertDirectoryNode) -import Wst.Offchain.BuildTx.ProtocolParams (getProtocolParamsGlobalInline) import Wst.Offchain.Env (DirectoryEnv (..), TransferLogicEnv (..)) import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query (UTxODat (..)) -import Wst.Offchain.Query qualified as Query import Wst.Offchain.Scripts (alwaysSucceedsScript, programmableLogicBaseScript, programmableLogicGlobalScript, programmableLogicMintingScript) data IssueNewTokenArgs = IssueNewTokenArgs - { intaMintingLogic :: C.StakeCredential, - intaTransferLogic :: C.StakeCredential, - intaIssuerLogic :: C.StakeCredential + { intaMintingLogic :: C.PlutusScript C.PlutusScriptV3, -- TODO: We could add a parameter for the script 'lang' instead of fixing it to PlutusV3 + intaTransferLogic :: C.PlutusScript C.PlutusScriptV3, + intaIssuerLogic :: C.PlutusScript C.PlutusScriptV3 } {-| 'IssueNewTokenArgs' for the policy that always succeeds (no checks) -} alwaysSucceedsArgs :: IssueNewTokenArgs alwaysSucceedsArgs = - let credential = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion alwaysSucceedsScript - in IssueNewTokenArgs - { intaMintingLogic = credential - , intaTransferLogic = credential - , intaIssuerLogic = credential - } + IssueNewTokenArgs + { intaMintingLogic = alwaysSucceedsScript + , intaTransferLogic = alwaysSucceedsScript + , intaIssuerLogic = alwaysSucceedsScript + } {-| 'IssueNewTokenArgs' for the transfer logic -} fromTransferEnv :: TransferLogicEnv -> IssueNewTokenArgs fromTransferEnv TransferLogicEnv{tleMintingScript, tleTransferScript, tleIssuerScript} = - let hsh = C.StakeCredentialByScript . C.hashScript . C.PlutusScript C.plutusScriptVersion - in IssueNewTokenArgs - { intaMintingLogic = hsh tleMintingScript - , intaTransferLogic = hsh tleTransferScript - , intaIssuerLogic = hsh tleIssuerScript - } + IssueNewTokenArgs + { intaMintingLogic = tleMintingScript + , intaTransferLogic = tleTransferScript + , intaIssuerLogic = tleIssuerScript + } {- 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. @@ -94,7 +90,7 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i DirectoryEnv{dsProgrammableLogicBaseScript} <- asks Env.directoryEnv -- TODO: maybe move programmableLogicMintingScript to DirectoryEnv - let mintingScript = programmableLogicMintingScript progLogicScriptCredential intaMintingLogic directoryNodeSymbol + let mintingScript = programmableLogicMintingScript progLogicScriptCredential (C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaMintingLogic) directoryNodeSymbol issuedPolicyId = C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript issuedSymbol = transPolicyId issuedPolicyId @@ -112,16 +108,24 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i receivingVal = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra $ fromList [(C.AssetId issuedPolicyId an, q)] + dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData () -- TODO: What should the datum be? + if key dirNodeData == issuedSymbol then mintPlutus mintingScript MintPToken an q else do - let nodeArgs = InsertNodeArgs{inaNewKey = issuedSymbol, inaTransferLogic = intaTransferLogic, inaIssuerLogic = intaIssuerLogic} + let nodeArgs = + InsertNodeArgs + { inaNewKey = issuedSymbol + , inaTransferLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaTransferLogic + , inaIssuerLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaIssuerLogic + } + mintPlutus mintingScript RegisterPToken an q insertDirectoryNode paramsTxOut udat nodeArgs -- add programmable logic output - prependTxOut $ C.TxOut receivingAddress receivingVal C.TxOutDatumNone C.ReferenceScriptNone + prependTxOut $ C.TxOut receivingAddress receivingVal dat C.ReferenceScriptNone pure issuedPolicyId @@ -261,10 +265,3 @@ checkIssuerAddressIsProgLogicCred _ _ = error "Issuer address is not a programma isNodeWithProgrammableSymbol :: forall era. CurrencySymbol -> UTxODat era DirectorySetNode -> Bool isNodeWithProgrammableSymbol programmableTokenSymbol (uDatum -> dat) = key dat == programmableTokenSymbol - -getDirectoryNodeInline :: C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe DirectorySetNode -getDirectoryNodeInline (C.InAnyCardanoEra C.ConwayEra (C.TxOut _ _ dat _)) = - case dat of - C.TxOutDatumInline C.BabbageEraOnwardsConway (fromHashableScriptData -> Just d) -> Just d - _ -> Nothing -getDirectoryNodeInline _ = Nothing diff --git a/src/lib/Wst/Offchain/Endpoints/Deployment.hs b/src/lib/Wst/Offchain/Endpoints/Deployment.hs index 17a4399..1a4c483 100644 --- a/src/lib/Wst/Offchain/Endpoints/Deployment.hs +++ b/src/lib/Wst/Offchain/Endpoints/Deployment.hs @@ -20,7 +20,6 @@ import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx import Wst.Offchain.Env (BuildTxError) import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query qualified as Query -import Wst.Offchain.Scripts qualified as Scripts {-| Build a transaction that deploys the directory and global params. Returns the transaction and the 'TxIn' that was selected for the one-shot NFTs. @@ -66,11 +65,8 @@ issueProgrammableTokenTx issueTokenArgs assetName quantity = do directory <- Query.registryNodes @era paramsNode <- head <$> Query.globalParamsNode @era (tx, _) <- Env.balanceTxEnv $ do - BuildTx.issueProgrammableToken paramsNode (assetName, quantity) issueTokenArgs directory + _ <- BuildTx.issueProgrammableToken paramsNode (assetName, quantity) issueTokenArgs directory - -- FIXME: We need the actual script here, not just the hash - let script = C.PlutusScript C.plutusScriptVersion Scripts.alwaysSucceedsScript - hsh = C.hashScript script - cred = C.StakeCredentialByScript hsh - BuildTx.addScriptWithdrawal hsh 0 $ BuildTx.buildScriptWitness Scripts.alwaysSucceedsScript C.NoScriptDatumForStake () + 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/Query.hs b/src/lib/Wst/Offchain/Query.hs index df4c6bf..ad9c840 100644 --- a/src/lib/Wst/Offchain/Query.hs +++ b/src/lib/Wst/Offchain/Query.hs @@ -5,6 +5,7 @@ module Wst.Offchain.Query( -- * Queries registryNodes, globalParamsNode, + programmableLogicOutputs, -- * UTxO with datum UTxODat(..), @@ -24,7 +25,7 @@ import Data.Maybe (mapMaybe) import PlutusTx qualified import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) -import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript), +import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript, dsProgrammableLogicBaseScript), HasDirectoryEnv (directoryEnv)) import Wst.Offchain.Scripts (protocolParamsSpendingScript) @@ -53,6 +54,13 @@ globalParamsNode = do let cred = C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 $ protocolParamsSpendingScript fmap (extractUTxO @era) (utxosByPaymentCredential cred) +{-| Outputs that are locked by the programmable logic base script. +-} +programmableLogicOutputs :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxODat era ()] +programmableLogicOutputs = do + asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicBaseScript . directoryEnv) + >>= fmap (extractUTxO @era) . utxosByPaymentCredential + fromOutput :: forall era a. (PlutusTx.FromData a, C.IsBabbageBasedEra era) => C.TxIn -> C.TxOut C.CtxUTxO era -> Maybe (UTxODat era a) fromOutput uIn uOut@(L.preview (L._TxOut . L._3 . L._TxOutDatumInline) >=> fromHashableScriptData -> Just uDatum) = Just UTxODat{uIn, uOut, uDatum} fromOutput _ _ = Nothing diff --git a/src/test/Wst/Test/UnitTest.hs b/src/test/Wst/Test/UnitTest.hs index f9292eb..965f07f 100644 --- a/src/test/Wst/Test/UnitTest.hs +++ b/src/test/Wst/Test/UnitTest.hs @@ -33,6 +33,7 @@ tests = testGroup "unit tests" , testCase "insert directory node" (mockchainSucceeds insertDirectoryNode) , testGroup "issue programmable tokens" [ testCase "always succeeds validator" (mockchainSucceeds issueAlwaysSucceedsValidator) + -- TODO: Add test for the seize/freeze validator ] ] @@ -59,11 +60,20 @@ insertDirectoryNode = failOnError $ do -} issueAlwaysSucceedsValidator :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () issueAlwaysSucceedsValidator = failOnError $ do + + -- Register the stake validator + -- Oddly, the tests passes even if we don't do this. + -- But I'll leave it in because it seems right. registerAlwaysSucceedsStakingCert + txI <- deployDirectorySet asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ do Endpoints.issueProgrammableTokenTx alwaysSucceedsArgs "dummy asset" 100 >>= void . sendTx . signTxOperator admin + Query.registryNodes @C.ConwayEra + >>= void . expectN 2 "registry outputs" + Query.programmableLogicOutputs @C.ConwayEra + >>= void . expectN 1 "programmable logic outputs" pure () @@ -75,6 +85,8 @@ dummyNodeArgs = , inaIssuerLogic = C.StakeCredentialByScript "e165610232235bbbbeff5b998b23e165610232235bbbbeff5b998b23" } +{-| Register the 'alwaysSucceedsScript' stake validator +-} registerAlwaysSucceedsStakingCert :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () registerAlwaysSucceedsStakingCert = failOnError $ do pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters