diff --git a/src/lib/SmartTokens/Types/PTokenDirectory.hs b/src/lib/SmartTokens/Types/PTokenDirectory.hs index 2aaee2d..a8870e0 100644 --- a/src/lib/SmartTokens/Types/PTokenDirectory.hs +++ b/src/lib/SmartTokens/Types/PTokenDirectory.hs @@ -23,6 +23,7 @@ module SmartTokens.Types.PTokenDirectory ( pletFieldsBlacklistNode, pisEmptyNode, BlacklistNode(..), + pdeserializeCredential, ) where import Generics.SOP qualified as SOP @@ -257,13 +258,28 @@ pisInsertedOnNode = phoistAcyclic $ pisInsertedNode :: ClosedTerm (PAsData PByteString :--> PAsData PByteString :--> PAsData PDirectorySetNode :--> PBool) pisInsertedNode = phoistAcyclic $ plam $ \insertedKey coveringNext outputNode -> - pletFields @'["transferLogicScript", "issuerLogicScript", "key", "next"] outputNode $ \outputNodeDatumF -> - let transferLogicCred_ = outputNodeDatumF.transferLogicScript - issuerLogicCred_ = outputNodeDatumF.issuerLogicScript + pletFields @'["transferLogicScript", "issuerLogicScript"] outputNode $ \outputNodeDatumF -> + let transferLogicCred_ = ptraceInfoShowId outputNodeDatumF.transferLogicScript + issuerLogicCred_ = ptraceInfoShowId outputNodeDatumF.issuerLogicScript expectedDirectoryNode = - pmkDirectorySetNode # insertedKey # coveringNext # pdeserializeCredential transferLogicCred_ # pdeserializeCredential issuerLogicCred_ + pmkDirectorySetNode # insertedKey # coveringNext # pdeserializeDirectoryCredential transferLogicCred_ # pdeserializeDirectoryCredential issuerLogicCred_ in outputNode #== expectedDirectoryNode +pdeserializeDirectoryCredential :: Term s (PAsData PCredential) -> Term s (PAsData PCredential) +pdeserializeDirectoryCredential term = + plet (pasConstr # pforgetData term) $ \constrPair -> + plet (pfstBuiltin # constrPair) $ \constrIdx -> + pif (plengthBS # (pasByteStr # (pheadSingleton # (psndBuiltin # constrPair))) #<= 28) + ( + pcond + [ ( constrIdx #== 0 , term) + , ( constrIdx #== 1 , term) + ] + (ptraceInfoError "Invalid credential") + ) + (ptraceInfoError $ pconstant "Invalid credential len" <> pshow (plengthBS # (pasByteStr # (pheadSingleton # (psndBuiltin # constrPair))))) + +-- TODO: move to catalyst library pdeserializeCredential :: Term s (PAsData PCredential) -> Term s (PAsData PCredential) pdeserializeCredential term = plet (pasConstr # pforgetData term) $ \constrPair -> @@ -274,6 +290,6 @@ pdeserializeCredential term = [ ( constrIdx #== 0 , term) , ( constrIdx #== 1 , term) ] - perror + (ptraceInfoError "Invalid credential") ) - perror + (ptraceInfoError $ pconstant "Invalid credential len" <> pshow (plengthBS # (pasByteStr # (pheadSingleton # (psndBuiltin # constrPair))))) diff --git a/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs b/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs index 036ca51..17c6923 100644 --- a/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs +++ b/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs @@ -125,12 +125,10 @@ insertDirectoryNode UTxODat{uIn=paramsRef} UTxODat{uIn, uOut=firstTxOut, uDatum= , issuerLogicScript = transStakeCredential inaIssuerLogic } newDat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData dsn - insertedNode = C.TxOut addr newVal newDat C.ReferenceScriptNone firstDat = firstTxData { next = inaNewKey } firstOutput = C.TxOut addr firstTxVal (C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData firstDat) C.ReferenceScriptNone - addReference paramsRef spendPlutusInlineDatum uIn directorySpendingScript () mintPlutus directoryMintingScript (InsertDirectoryNode inaNewKey) newTokenName 1 diff --git a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs index 12bac15..f440aab 100644 --- a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs @@ -119,8 +119,7 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i IMPORTANT: The caller should ensure that the destination address of the programmable token(s) in this transaction all correspond to the same - programmable logic payment credential (even in the case of non-programmable - tokens) otherwise the transaction will fail onchain validation. + programmable logic payment credential 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) => UTxODat era ProgrammableLogicGlobalParams -> [C.TxIn] -> CurrencySymbol -> [UTxODat era DirectorySetNode] -> m () transferProgrammableToken _ _ _ [] = error "directory list not initialised" diff --git a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs index 3e6d0ab..8e6a122 100644 --- a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs @@ -69,7 +69,7 @@ intaFromEnv = do blacklistInitialNode :: BlacklistNode blacklistInitialNode = BlacklistNode - { blnNext= "" + { blnNext= "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff" , 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 () diff --git a/src/lib/Wst/Offchain/Env.hs b/src/lib/Wst/Offchain/Env.hs index 4456887..204eea2 100644 --- a/src/lib/Wst/Offchain/Env.hs +++ b/src/lib/Wst/Offchain/Env.hs @@ -55,7 +55,8 @@ module Wst.Offchain.Env( addRuntimeEnv, withRuntime, addOperatorEnv, - withOperator + withOperator, + blacklistNodePolicyId ) where import Blammo.Logging (Logger) @@ -255,6 +256,9 @@ mkTransferLogicEnv progLogicBaseCred cred = , tleIssuerScript = permissionedTransferScript cred } +blacklistNodePolicyId :: TransferLogicEnv -> C.PolicyId +blacklistNodePolicyId = scriptPolicyIdV3 . tleBlacklistMintingScript + data RuntimeEnv = RuntimeEnv { envLogger :: Logger diff --git a/src/lib/Wst/Offchain/Query.hs b/src/lib/Wst/Offchain/Query.hs index 1ea3b87..788cab9 100644 --- a/src/lib/Wst/Offchain/Query.hs +++ b/src/lib/Wst/Offchain/Query.hs @@ -28,6 +28,7 @@ import Convex.Utxos (UtxoSet, toApiUtxo) import Data.Aeson (FromJSON, ToJSON) import Data.Map qualified as Map import Data.Maybe (listToMaybe, mapMaybe) +import GHC.Exts (IsList (..)) import GHC.Generics (Generic) import PlutusTx qualified import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) @@ -36,7 +37,8 @@ import Wst.AppError (AppError (GlobalParamsNodeNotFound)) import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript, dsProgrammableLogicBaseScript), HasDirectoryEnv (directoryEnv), HasTransferLogicEnv (transferLogicEnv), - TransferLogicEnv (tleBlacklistSpendingScript)) + TransferLogicEnv (tleBlacklistSpendingScript), + blacklistNodePolicyId, directoryNodePolicyId) import Wst.Offchain.Scripts (protocolParamsSpendingScript) -- TODO: We should probably filter the UTxOs to check that they have the correct NFTs @@ -55,16 +57,18 @@ data UTxODat era a = {-| Find all UTxOs that make up the registry -} registryNodes :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxODat era DirectorySetNode] -registryNodes = - asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsDirectorySpendingScript . directoryEnv) - >>= fmap (extractUTxO @era) . utxosByPaymentCredential +registryNodes = do + utxosAtDirectoryScript <- asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsDirectorySpendingScript . directoryEnv) >>= fmap (extractUTxO @era) . utxosByPaymentCredential + registryPolicy <- asks (directoryNodePolicyId . directoryEnv) + pure $ filter (utxoHasPolicyId registryPolicy) utxosAtDirectoryScript {-| Find all UTxOs that make up the blacklist -} blacklistNodes :: forall era env m. (MonadReader env m, HasTransferLogicEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxODat era BlacklistNode] -blacklistNodes = - asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . tleBlacklistSpendingScript . transferLogicEnv) - >>= fmap (extractUTxO @era) . utxosByPaymentCredential +blacklistNodes = do + utxosAtBlacklistScript <- asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . tleBlacklistSpendingScript . transferLogicEnv) >>= fmap (extractUTxO @era) . utxosByPaymentCredential + blacklistPolicy <- asks (blacklistNodePolicyId . transferLogicEnv) + pure $ filter (utxoHasPolicyId blacklistPolicy) utxosAtBlacklistScript 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 @@ -105,3 +109,17 @@ fromOutput _ _ = Nothing extractUTxO :: forall era a b. (PlutusTx.FromData a, C.IsBabbageBasedEra era) => UtxoSet C.CtxUTxO b -> [UTxODat era a] extractUTxO = mapMaybe (uncurry fromOutput) . Map.toList . C.unUTxO . toApiUtxo @era + +extractValue :: C.IsBabbageBasedEra era => C.TxOut C.CtxUTxO era -> C.Value +extractValue = L.view $ L._TxOut . L._2 . L._TxOutValue + +hasPolicyId :: C.PolicyId -> C.Value -> Bool +hasPolicyId policyId val = + let isPolicy :: (C.AssetId, C.Quantity) -> Bool + isPolicy (C.AssetId pid _, _) = pid == policyId + isPolicy _ = False + in any isPolicy (toList val) + +utxoHasPolicyId :: C.IsBabbageBasedEra era => C.PolicyId -> UTxODat era a -> Bool +utxoHasPolicyId policyId txoD = hasPolicyId policyId $ extractValue (uOut txoD) + diff --git a/src/lib/Wst/Offchain/Scripts.hs b/src/lib/Wst/Offchain/Scripts.hs index 4e87844..995911e 100644 --- a/src/lib/Wst/Offchain/Scripts.hs +++ b/src/lib/Wst/Offchain/Scripts.hs @@ -49,7 +49,10 @@ import SmartTokens.LinkedList.MintDirectory (mkDirectoryNodeMP) import SmartTokens.LinkedList.SpendDirectory (pmkDirectorySpending) tracingConfig :: Config -tracingConfig = Tracing LogInfo DoTracingAndBinds +tracingConfig = Tracing LogInfo DoTracing + +tracingAndBindsConfig :: Config +tracingAndBindsConfig = Tracing LogInfo DoTracingAndBinds prodConfig :: Config prodConfig = NoTracing @@ -60,34 +63,34 @@ prodConfig = NoTracing -- one shot mint protocolParamsMintingScript :: C.TxIn -> C.PlutusScript C.PlutusScriptV3 protocolParamsMintingScript txIn = - let script = tryCompile prodConfig $ mkProtocolParametersMinting # pdata (pconstant $ transTxOutRef txIn) + let script = tryCompile tracingConfig $ mkProtocolParametersMinting # pdata (pconstant $ transTxOutRef txIn) in C.PlutusScriptSerialised $ serialiseScript script -- | The spending script for the protocol parameters NFT parameterized by "" -- nonce protocolParamsSpendingScript :: C.PlutusScript C.PlutusScriptV3 protocolParamsSpendingScript = - let script = tryCompile prodConfig $ alwaysFailScript # pforgetData (pdata (pconstant "" :: ClosedTerm PByteString)) + let script = tryCompile tracingConfig $ alwaysFailScript # pforgetData (pdata (pconstant "" :: ClosedTerm PByteString)) in C.PlutusScriptSerialised $ serialiseScript script -- | The minting script for the directory node tokens, takes initial TxIn for -- symbol uniqueness across instances directoryNodeMintingScript :: C.TxIn -> C.PlutusScript C.PlutusScriptV3 directoryNodeMintingScript txIn = - let script = tryCompile prodConfig $ mkDirectoryNodeMP # pdata (pconstant $ transTxOutRef txIn) + let script = tryCompile tracingConfig $ mkDirectoryNodeMP # pdata (pconstant $ transTxOutRef txIn) in C.PlutusScriptSerialised $ serialiseScript script -- | The spending script for the directory node tokens, parameterized by the -- policy id of the protocol parameters NFT. directoryNodeSpendingScript :: C.PolicyId -> C.PlutusScript C.PlutusScriptV3 directoryNodeSpendingScript paramsPolId = - let script = tryCompile prodConfig $ pmkDirectorySpending # pdata (pconstant $ transPolicyId paramsPolId) + let script = tryCompile tracingConfig $ pmkDirectorySpending # pdata (pconstant $ transPolicyId paramsPolId) in C.PlutusScriptSerialised $ serialiseScript script -- TODO: can we change the signature to just take the param policy id? programmableLogicMintingScript :: C.PaymentCredential -> C.StakeCredential -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3 programmableLogicMintingScript progLogicBaseSpndingCred mintingCred nodePolId = - let script = tryCompile prodConfig + let script = tryCompile tracingConfig $ mkProgrammableLogicMinting # pdata (pconstant $ transCredential progLogicBaseSpndingCred) # pdata (pconstant $ transPolicyId nodePolId) @@ -96,39 +99,39 @@ programmableLogicMintingScript progLogicBaseSpndingCred mintingCred nodePolId = programmableLogicBaseScript :: C.StakeCredential -> C.PlutusScript C.PlutusScriptV3 -- Parameterized by the stake cred of the global script programmableLogicBaseScript globalCred = - let script = tryCompile prodConfig $ mkProgrammableLogicBase # pdata (pconstant $ transStakeCredential globalCred) + let script = tryCompile tracingConfig $ mkProgrammableLogicBase # pdata (pconstant $ transStakeCredential globalCred) in C.PlutusScriptSerialised $ serialiseScript script 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 permissionedTransferScript cred = - let script = tryCompile prodConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred) + let script = tryCompile tracingConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred) in C.PlutusScriptSerialised $ serialiseScript script freezeTransferScript :: C.PaymentCredential -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3 freezeTransferScript progLogicBaseSpndingCred blacklistPolicyId = - let script = tryCompile prodConfig $ mkFreezeAndSeizeTransfer # pdata (pconstant $ transCredential progLogicBaseSpndingCred) # pdata (pconstant $ transPolicyId blacklistPolicyId) + let script = tryCompile tracingConfig $ mkFreezeAndSeizeTransfer # pdata (pconstant $ transCredential progLogicBaseSpndingCred) # 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) + let script = tryCompile tracingConfig $ 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) + let script = tryCompile tracingConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred) in C.PlutusScriptSerialised $ serialiseScript script {-| 'C.PlutusScript C.PlutusScriptV3' that always succeeds. Can be used for minting, withdrawal, spending, etc. -} alwaysSucceedsScript :: C.PlutusScript C.PlutusScriptV3 alwaysSucceedsScript = - C.PlutusScriptSerialised $ serialiseScript $ tryCompile prodConfig palwaysSucceed + C.PlutusScriptSerialised $ serialiseScript $ tryCompile tracingConfig palwaysSucceed -- Utilities scriptPolicyIdV3 :: C.PlutusScript C.PlutusScriptV3 -> C.PolicyId diff --git a/src/test/Wst/Test/UnitTest.hs b/src/test/Wst/Test/UnitTest.hs index a398822..c06c72e 100644 --- a/src/test/Wst/Test/UnitTest.hs +++ b/src/test/Wst/Test/UnitTest.hs @@ -5,9 +5,12 @@ module Wst.Test.UnitTest( import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C +import Cardano.Ledger.Api qualified as Ledger import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Plutus.ExUnits qualified as Ledger import Cardano.Ledger.Shelley.TxCert qualified as TxCert -import Control.Lens ((^.)) +import Control.Exception (try) +import Control.Lens (set, (%~), (&), (^.)) import Control.Monad (void) import Control.Monad.Reader (asks) import Control.Monad.Reader.Class (MonadReader) @@ -16,12 +19,17 @@ import Convex.BuildTx qualified as BuildTx import Convex.Class (MonadBlockchain (queryProtocolParameters, sendTx), MonadMockchain, MonadUtxoQuery) import Convex.CoinSelection (ChangeOutputPosition (TrailingChange)) +import Convex.MockChain import Convex.MockChain.CoinSelection (tryBalanceAndSubmit) +import Convex.MockChain.Defaults qualified as Defaults import Convex.MockChain.Utils (mockchainFails, mockchainSucceeds) +import Convex.NodeParams (NodeParams, ledgerProtocolParameters, + protocolParameters) import Convex.Utils (failOnError) import Convex.Wallet.MockWallet qualified as Wallet import Convex.Wallet.Operator (signTxOperator) import Data.List (isPrefixOf) +import Data.Word (Word32) import GHC.Exception (SomeException, throw) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase) @@ -33,9 +41,28 @@ import Wst.Offchain.Query qualified as Query import Wst.Offchain.Scripts qualified as Scripts import Wst.Test.Env (admin, asAdmin, asWallet, user) +testTxSize :: Word32 +testTxSize = 16384 + +testNodeParams :: NodeParams C.ConwayEra +testNodeParams = + -- restrict script bugdet to current value on mainnet + let newExUnits = Ledger.ExUnits {Ledger.exUnitsSteps = 10_000_000_000, Ledger.exUnitsMem = 14_000_000} + npsTx = Defaults.nodeParams & set (ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxSizeL) testTxSize + in npsTx & set (ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxExUnitsL) newExUnits + +-- | Run the 'Mockchain' action with modified node parameters to allow larger-than-usual +-- transactions. This is useful for showing debug output from the scripts and fail if there is an error +mockchainSucceedsWithLargeTx :: MockchainIO C.ConwayEra a -> Assertion +mockchainSucceedsWithLargeTx action = + let params' = testNodeParams & ledgerProtocolParameters . protocolParameters . Ledger.ppMaxTxSizeL %~ (*10) + in try @SomeException (runMockchain0IOWith Wallet.initialUTxOs params' action) >>= \case + Right{} -> pure () + Left err -> fail (show err) + tests :: TestTree tests = testGroup "unit tests" - [ testCase "deploy directory and global params" (mockchainSucceeds deployDirectorySet) + [ testCase "deploy directory and global params" (mockchainSucceedsWithLargeTx deployDirectorySet) , testCase "insert directory node" (mockchainSucceeds insertDirectoryNode) , testGroup "issue programmable tokens" [ testCase "always succeeds validator" (mockchainSucceeds issueAlwaysSucceedsValidator) diff --git a/src/wst-poc.cabal b/src/wst-poc.cabal index ca4cca4..5396587 100644 --- a/src/wst-poc.cabal +++ b/src/wst-poc.cabal @@ -162,6 +162,7 @@ test-suite wst-poc-test build-depends: , base >=4.14.0 , cardano-api + , cardano-ledger-api , cardano-ledger-core , cardano-ledger-shelley , convex-base