From 857ec745d50f7f0ebd5cd934110403fae301ef6f Mon Sep 17 00:00:00 2001 From: Misha Date: Tue, 20 Sep 2022 16:19:13 +0300 Subject: [PATCH] Fix chain index query filtering (#153) * Adds handling of missing cases when collateral should not be returned by chain-index responses * Adds node query effect like UtxosAt but with filtering - UtxosAtExcluding * Enables other collateral tests (they were not included to suite for some reason) * Fixes some collateral-affected tests --- src/BotPlutusInterface/Balance.hs | 16 +- src/BotPlutusInterface/CardanoNode/Effects.hs | 9 +- src/BotPlutusInterface/ChainIndex.hs | 32 ++-- src/BotPlutusInterface/Collateral.hs | 96 +++++++++-- src/BotPlutusInterface/Effects.hs | 9 +- test/Spec.hs | 2 + test/Spec/BotPlutusInterface/Collateral.hs | 157 +++++++++++++++--- test/Spec/BotPlutusInterface/Contract.hs | 6 +- test/Spec/MockContract.hs | 59 ++++--- 9 files changed, 293 insertions(+), 93 deletions(-) diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index d2af7882..0366afc4 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -13,9 +13,9 @@ module BotPlutusInterface.Balance ( import BotPlutusInterface.BodyBuilder qualified as BodyBuilder import BotPlutusInterface.CardanoCLI qualified as CardanoCLI -import BotPlutusInterface.CardanoNode.Effects (NodeQuery (UtxosAt)) +import BotPlutusInterface.CardanoNode.Effects (NodeQuery (UtxosAt, UtxosAtExcluding)) import BotPlutusInterface.CoinSelection (selectTxIns) -import BotPlutusInterface.Collateral (removeCollateralFromMap) + import BotPlutusInterface.Effects ( PABEffect, createDirectoryIfMissingCLI, @@ -247,8 +247,14 @@ utxosAndCollateralAtAddress :: Eff effs (Either Text (Map TxOutRef Tx.ChainIndexTxOut, Maybe CollateralUtxo)) utxosAndCollateralAtAddress balanceCfg _pabConf changeAddr = runEitherT $ do - utxos <- firstEitherT (Text.pack . show) $ newEitherT $ queryNode @w (UtxosAt changeAddr) inMemCollateral <- lift $ getInMemCollateral @w + let nodeQuery = + maybe + (UtxosAt changeAddr) + (UtxosAtExcluding changeAddr . Set.singleton . collateralTxOutRef) + inMemCollateral + + utxos <- firstEitherT (Text.pack . show) $ newEitherT $ queryNode @w nodeQuery -- check if `bcHasScripts` is true, if this is the case then we search of -- collateral UTxO in the environment, if such collateral is not present we throw Error. @@ -259,9 +265,9 @@ utxosAndCollateralAtAddress balanceCfg _pabConf changeAddr = "The given transaction uses script, but there's no collateral provided." <> "This usually means that, we failed to create Tx and update our ContractEnvironment." ) - (const $ pure (removeCollateralFromMap inMemCollateral utxos, inMemCollateral)) + (const $ pure (utxos, inMemCollateral)) inMemCollateral - else pure (removeCollateralFromMap inMemCollateral utxos, Nothing) + else pure (utxos, Nothing) hasChangeUTxO :: Address -> Tx -> Bool hasChangeUTxO changeAddr tx = diff --git a/src/BotPlutusInterface/CardanoNode/Effects.hs b/src/BotPlutusInterface/CardanoNode/Effects.hs index 4856d4a9..7e250d40 100644 --- a/src/BotPlutusInterface/CardanoNode/Effects.hs +++ b/src/BotPlutusInterface/CardanoNode/Effects.hs @@ -41,9 +41,10 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Either (firstEitherT, hoistEither, newEitherT, runEitherT) import Data.Map (Map) import Data.Map qualified as Map +import Data.Set (Set) import Data.Set qualified as Set import Ledger.Address (Address) -import Ledger.Tx (ChainIndexTxOut (..)) +import Ledger.Tx (ChainIndexTxOut (..), TxOutRef) import Ledger.Tx.CardanoAPI qualified as TxApi import Plutus.V2.Ledger.Tx qualified as V2 import Prelude @@ -54,6 +55,9 @@ import Prelude data NodeQuery a where -- | 'UtxosAt' queries local node to get all the utxos at particular address. UtxosAt :: Address -> NodeQuery (Either NodeQueryError (Map V2.TxOutRef ChainIndexTxOut)) + -- | 'UtxosAtExcluding' queries local node to get all the utxos at particular address + -- excluding `TxOutRefs`'s specified in `Set`. + UtxosAtExcluding :: Address -> Set TxOutRef -> NodeQuery (Either NodeQueryError (Map V2.TxOutRef ChainIndexTxOut)) -- | 'PParams' queries local node to get it's 'ProtocolParameters'. PParams :: NodeQuery (Either NodeQueryError CApi.S.ProtocolParameters) @@ -78,6 +82,9 @@ handleNodeQuery = interpret $ \case UtxosAt addr -> handleUtxosAt addr PParams -> queryBabbageEra CApi.QueryProtocolParameters + UtxosAtExcluding addr excluded -> + let filterOuts = Map.filterWithKey (\oref _ -> not $ oref `Set.member` excluded) + in fmap filterOuts <$> handleUtxosAt addr handleUtxosAt :: forall effs. diff --git a/src/BotPlutusInterface/ChainIndex.hs b/src/BotPlutusInterface/ChainIndex.hs index 05ac6c46..9adabf28 100644 --- a/src/BotPlutusInterface/ChainIndex.hs +++ b/src/BotPlutusInterface/ChainIndex.hs @@ -4,11 +4,9 @@ module BotPlutusInterface.ChainIndex ( handleChainIndexReq, ) where -import BotPlutusInterface.Collateral (removeCollateralFromPage) import BotPlutusInterface.Types ( ContractEnvironment (ContractEnvironment, cePABConfig), PABConfig, - readCollateralUtxo, ) import Data.Kind (Type) import Network.HTTP.Client ( @@ -21,10 +19,10 @@ import Network.HTTP.Types (Status (statusCode)) import Plutus.ChainIndex.Api ( QueryAtAddressRequest (QueryAtAddressRequest), TxoAtAddressRequest (TxoAtAddressRequest), - TxosResponse (TxosResponse), + TxosResponse, UtxoAtAddressRequest (UtxoAtAddressRequest), UtxoWithCurrencyRequest (UtxoWithCurrencyRequest), - UtxosResponse (UtxosResponse), + UtxosResponse, ) import Plutus.ChainIndex.Client qualified as ChainIndexClient import Plutus.Contract.Effects (ChainIndexQuery (..), ChainIndexResponse (..)) @@ -73,7 +71,7 @@ handleChainIndexReq contractEnv@ContractEnvironment {cePABConfig} = contractEnv (ChainIndexClient.getUtxoSetAtAddress (UtxoAtAddressRequest (Just page) credential)) UtxoSetWithCurrency page assetClass -> - UtxoSetAtResponse + UtxoSetWithCurrencyResponse <$> chainIndexUtxoQuery contractEnv (ChainIndexClient.getUtxoSetWithCurrency (UtxoWithCurrencyRequest (Just page) assetClass)) @@ -105,24 +103,16 @@ chainIndexQueryOne pabConf endpoint = do | otherwise -> error (show failureResp) Left failureResp -> error (show failureResp) --- | Query for utxo's and filter collateral utxo from result. +-- | Query for utxo's. chainIndexUtxoQuery :: forall (w :: Type). ContractEnvironment w -> ClientM UtxosResponse -> IO UtxosResponse chainIndexUtxoQuery contractEnv query = do - collateralUtxo <- readCollateralUtxo contractEnv - let removeCollateral :: UtxosResponse -> UtxosResponse - removeCollateral (UtxosResponse tip page) = UtxosResponse tip (removeCollateralFromPage collateralUtxo page) - removeCollateral - <$> chainIndexQueryMany - contractEnv.cePABConfig - query + chainIndexQueryMany + contractEnv.cePABConfig + query --- | Query for txo's and filter collateral txo from result. +-- | Query for txo's. chainIndexTxoQuery :: forall (w :: Type). ContractEnvironment w -> ClientM TxosResponse -> IO TxosResponse chainIndexTxoQuery contractEnv query = do - collateralUtxo <- readCollateralUtxo contractEnv - let removeCollateral :: TxosResponse -> TxosResponse - removeCollateral (TxosResponse page) = TxosResponse (removeCollateralFromPage collateralUtxo page) - removeCollateral - <$> chainIndexQueryMany - contractEnv.cePABConfig - query + chainIndexQueryMany + contractEnv.cePABConfig + query diff --git a/src/BotPlutusInterface/Collateral.hs b/src/BotPlutusInterface/Collateral.hs index 2d5e2d7c..28ffed8b 100644 --- a/src/BotPlutusInterface/Collateral.hs +++ b/src/BotPlutusInterface/Collateral.hs @@ -1,10 +1,8 @@ module BotPlutusInterface.Collateral ( getInMemCollateral, setInMemCollateral, - filterCollateral, mkCollateralTx, - removeCollateralFromPage, - removeCollateralFromMap, + withCollateralHandling, ) where import BotPlutusInterface.Types ( @@ -16,12 +14,32 @@ import BotPlutusInterface.Types ( ) import Cardano.Prelude (Void) import Control.Concurrent.STM (atomically, readTVarIO, writeTVar) +import Control.Monad (unless) import Data.Kind (Type) -import Data.Map (Map) -import Data.Map qualified as Map -import Ledger (ChainIndexTxOut, PaymentPubKeyHash (PaymentPubKeyHash), TxOutRef) +import Ledger (PaymentPubKeyHash (PaymentPubKeyHash), TxOutRef) import Ledger.Constraints qualified as Constraints import Plutus.ChainIndex (Page (pageItems)) +import Plutus.ChainIndex.Api ( + IsUtxoResponse (IsUtxoResponse), + QueryResponse (QueryResponse), + TxosResponse (paget), + UtxosResponse (page), + ) +import Plutus.Contract.Effects ( + ChainIndexQuery (..), + ChainIndexResponse ( + TxOutRefResponse, + TxoSetAtResponse, + UnspentTxOutResponse, + UnspentTxOutsAtResponse, + UtxoSetAtResponse, + UtxoSetMembershipResponse, + UtxoSetWithCurrencyResponse + ), + PABReq (ChainIndexQueryReq), + PABResp (ChainIndexQueryResp), + matches, + ) import Prelude getInMemCollateral :: forall (w :: Type). ContractEnvironment w -> IO (Maybe CollateralUtxo) @@ -38,16 +56,68 @@ mkCollateralTx pabConf = Constraints.mkTx @Void mempty txc txc :: Constraints.TxConstraints Void Void txc = Constraints.mustPayToPubKey (PaymentPubKeyHash $ pcOwnPubKeyHash pabConf) (collateralValue pabConf) -filterCollateral :: CollateralUtxo -> [TxOutRef] -> [TxOutRef] -filterCollateral (CollateralUtxo collateralTxOutRef) = filter (/= collateralTxOutRef) +-- | Middleware to run `chain-index` queries and filter out collateral output from response. +withCollateralHandling :: + Monad m => + Maybe CollateralUtxo -> + (ChainIndexQuery -> m ChainIndexResponse) -> + ChainIndexQuery -> + m ChainIndexResponse +withCollateralHandling mCollateral runChainIndexQuery = \query -> do + response <- + adjustChainIndexResponse mCollateral query + <$> runChainIndexQuery query + ensureMatches query response + pure response + where + ensureMatches query result = + unless (matches (ChainIndexQueryReq query) (ChainIndexQueryResp result)) $ + error $ + mconcat + [ "Chain-index request doesn't match response." + , "\nRequest: " ++ show query + , "\nResponse:" ++ show result + ] + +adjustChainIndexResponse :: Maybe CollateralUtxo -> ChainIndexQuery -> ChainIndexResponse -> ChainIndexResponse +adjustChainIndexResponse mc ciQuery ciResponse = + case mc of + Nothing -> ciResponse + Just (CollateralUtxo collateralOref) -> case (ciQuery, ciResponse) of + -- adjustment based on response + (_, UtxoSetAtResponse utxosResp) -> + let newPage = removeCollateralFromPage mc (page utxosResp) + in UtxoSetAtResponse $ utxosResp {page = newPage} + (_, TxoSetAtResponse txosResp) -> + let newPaget = removeCollateralFromPage mc (paget txosResp) + in TxoSetAtResponse $ txosResp {paget = newPaget} + (_, UnspentTxOutsAtResponse (QueryResponse refsAndOuts nq)) -> + let filtered = filter (\v -> fst v /= collateralOref) refsAndOuts + in UnspentTxOutsAtResponse $ QueryResponse filtered nq + (_, UtxoSetWithCurrencyResponse utxosResp) -> + let newPage = removeCollateralFromPage mc (page utxosResp) + in UtxoSetWithCurrencyResponse $ utxosResp {page = newPage} + -- adjustment based on request + (UtxoSetMembership oref, UtxoSetMembershipResponse (IsUtxoResponse ct isU)) -> + UtxoSetMembershipResponse $ + IsUtxoResponse ct $ + oref /= collateralOref && isU + (TxOutFromRef oref, TxOutRefResponse _) -> + if collateralOref == oref + then TxOutRefResponse Nothing + else ciResponse + (UnspentTxOutFromRef oref, UnspentTxOutResponse _) -> + if collateralOref == oref + then UnspentTxOutResponse Nothing + else ciResponse + -- all other cases + (_, rest) -> rest -- | Removes collateral utxo from the UtxoResponse page. Receives `Nothing` if Collateral uninitialized. removeCollateralFromPage :: Maybe CollateralUtxo -> Page TxOutRef -> Page TxOutRef removeCollateralFromPage = \case Nothing -> id - Just txOutRef -> \page -> page {pageItems = filterCollateral txOutRef (pageItems page)} + Just txOutRef -> \page' -> page' {pageItems = filterCollateral txOutRef (pageItems page')} -removeCollateralFromMap :: Maybe CollateralUtxo -> Map TxOutRef ChainIndexTxOut -> Map TxOutRef ChainIndexTxOut -removeCollateralFromMap = \case - Nothing -> id - Just (CollateralUtxo collateral) -> Map.filterWithKey (\oref _ -> collateral /= oref) +filterCollateral :: CollateralUtxo -> [TxOutRef] -> [TxOutRef] +filterCollateral (CollateralUtxo collateralTxOutRef) = filter (/= collateralTxOutRef) diff --git a/src/BotPlutusInterface/Effects.hs b/src/BotPlutusInterface/Effects.hs index 21591129..049465d4 100644 --- a/src/BotPlutusInterface/Effects.hs +++ b/src/BotPlutusInterface/Effects.hs @@ -37,6 +37,7 @@ module BotPlutusInterface.Effects ( import BotPlutusInterface.CardanoNode.Effects (NodeQuery, runNodeQuery) import BotPlutusInterface.ChainIndex (handleChainIndexReq) +import BotPlutusInterface.Collateral (withCollateralHandling) import BotPlutusInterface.Collateral qualified as Collateral import BotPlutusInterface.ExBudget qualified as ExBudget import BotPlutusInterface.TimeSlot qualified as TimeSlot @@ -193,8 +194,12 @@ handlePABEffect contractEnv = Local -> pure () Remote ipAddr -> void $ readProcess "scp" ["-r", Text.unpack dir, Text.unpack $ ipAddr <> ":$HOME"] "" - QueryChainIndex query -> - handleChainIndexReq contractEnv query + QueryChainIndex query -> do + collateralUtxo <- Collateral.getInMemCollateral contractEnv + withCollateralHandling + collateralUtxo + (handleChainIndexReq contractEnv) + query QueryNode query -> runNodeQuery contractEnv.cePABConfig (send query) EstimateBudget txPath -> ExBudget.estimateBudget contractEnv.cePABConfig txPath diff --git a/test/Spec.hs b/test/Spec.hs index 57499773..206abea5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,6 +3,7 @@ module Main (main) where import Spec.BotPlutusInterface.AdjustUnbalanced qualified import Spec.BotPlutusInterface.Balance qualified import Spec.BotPlutusInterface.CoinSelection qualified +import Spec.BotPlutusInterface.Collateral qualified import Spec.BotPlutusInterface.Contract qualified import Spec.BotPlutusInterface.ContractStats qualified import Spec.BotPlutusInterface.Server qualified @@ -30,4 +31,5 @@ tests = , Spec.BotPlutusInterface.ContractStats.tests , Spec.BotPlutusInterface.TxStatusChange.tests , Spec.BotPlutusInterface.AdjustUnbalanced.tests + , Spec.BotPlutusInterface.Collateral.tests ] diff --git a/test/Spec/BotPlutusInterface/Collateral.hs b/test/Spec/BotPlutusInterface/Collateral.hs index ecc3b40c..21d2cb93 100644 --- a/test/Spec/BotPlutusInterface/Collateral.hs +++ b/test/Spec/BotPlutusInterface/Collateral.hs @@ -3,7 +3,7 @@ module Spec.BotPlutusInterface.Collateral where -import Control.Lens ((&), (.~), (^.)) +import Control.Lens ((&), (.~), (<>~), (^.)) import Data.Aeson.Extras (encodeByteString) import Data.Default (def) import Data.Text (Text, pack) @@ -19,8 +19,16 @@ import Ledger.Value qualified as Value import NeatInterpolation (text) import Plutus.Contract ( Contract, + EmptySchema, Endpoint, + ownAddresses, submitTxConstraintsWith, + txOutFromRef, + unspentTxOutFromRef, + utxoRefMembership, + utxoRefsAt, + utxoRefsWithCurrency, + utxosAt, ) import Spec.MockContract ( addr1, @@ -31,11 +39,12 @@ import Spec.MockContract ( pkh1', pkhAddr1, runContractPure, + theCollateralUtxo, utxos, ) import BotPlutusInterface.Types ( - CollateralUtxo (CollateralUtxo), + CollateralUtxo (CollateralUtxo, collateralTxOutRef), CollateralVar (CollateralVar), ContractEnvironment (ceCollateral, cePABConfig), PABConfig (pcCollateralSize), @@ -44,32 +53,49 @@ import Control.Concurrent.STM (newTVarIO) import Spec.BotPlutusInterface.Contract (assertCommandHistory, assertContract) +import Data.Foldable (find) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (isJust, isNothing) +import Ledger.Value (CurrencySymbol (CurrencySymbol), TokenName (TokenName), assetClass) +import Plutus.ChainIndex (Page (pageItems), PageQuery (PageQuery), PageSize (PageSize)) +import Plutus.ChainIndex.Api (IsUtxoResponse, UtxosResponse, isUtxo, page) import PlutusTx qualified import PlutusTx.Builtins (fromBuiltin) import System.IO.Unsafe (unsafePerformIO) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertEqual, testCase) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) import Prelude tests :: TestTree tests = testGroup - "Doesn't spend collateral." + "Collateral handling" [ testCase - "Use collateral utxo present in the user's wallet, instead of creating new one." + "Should use collateral utxo present in the user's wallet, instead of creating new one." testTxUsesCollateralCorrectly - , testCase "create collateral utxo" testTxCreatesCollateralCorrectly + , testCase + "Should create collateral utxo if not present in user's wallets" + testTxCreatesCollateralCorrectly + , testCase + "Should not return collateral utxo in chain-index responses" + testCollateralFiltering ] -- Test to check that correct UTxo is selected from user's wallet as collateral. testTxUsesCollateralCorrectly :: Assertion testTxUsesCollateralCorrectly = do - let txOutRef1 = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 + let -- txOutRef1 should be picked up and used as collateral UTxO + txOutRef1 = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 txOut1 = PublicKeyChainIndexTxOut pkhAddr1 (Ada.lovelaceValueOf 10_000_000) Nothing Nothing txOutRef2 = TxOutRef "d406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e4" 0 txOut2 = PublicKeyChainIndexTxOut pkhAddr1 (Ada.lovelaceValueOf 90_000_000) Nothing Nothing cenv' = def {ceCollateral = CollateralVar $ unsafePerformIO $ newTVarIO Nothing} - initState = def & utxos .~ [(txOutRef1, txOut1), (txOutRef2, txOut2)] & contractEnv .~ cenv' & collateralUtxo .~ Nothing + initState = + def & utxos .~ [(txOutRef1, txOut1), (txOutRef2, txOut2)] + & contractEnv .~ cenv' + & collateralUtxo .~ Nothing collatUtxo = Just $ CollateralUtxo txOutRef1 @@ -87,17 +113,17 @@ testTxUsesCollateralCorrectly = do [ ( 3 , [text| - cardano-cli transaction build-raw --alonzo-era + cardano-cli transaction build-raw --babbage-era --tx-in ${inTxId}#0 --tx-in-collateral ${collateralTxId}#0 - --tx-out ${addr2}+1000 + 5 648823ffdad1610b4162f4dbc87bd47f6f9cf45d772ddef661eff198.74657374546F6B656E - --mint-script-file ./result-scripts/policy-648823ffdad1610b4162f4dbc87bd47f6f9cf45d772ddef661eff198.plutus + --tx-out ${addr2}+3000000 + 5 363d3944282b3d16b239235a112c0f6e2f1195de5067f61c0dfc0f5f.74657374546F6B656E + --mint-script-file ./result-scripts/policy-363d3944282b3d16b239235a112c0f6e2f1195de5067f61c0dfc0f5f.plutus --mint-redeemer-file ./result-scripts/redeemer-923918e403bf43c34b4ef6b48eb2ee04babed17320d8d1b9ff9ad086e86f44ec.json --mint-execution-units (0,0) - --mint 5 648823ffdad1610b4162f4dbc87bd47f6f9cf45d772ddef661eff198.74657374546F6B656E + --mint 5 363d3944282b3d16b239235a112c0f6e2f1195de5067f61c0dfc0f5f.74657374546F6B656E --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 --protocol-params-file ./protocol.json - --out-file ./txs/tx-9e13584e45ce4c310f2b0f14341b9ab51bd3ec7978caeaf8e395f7a54315f94e.raw + --out-file ./txs/tx-?.raw |] ) ] @@ -118,25 +144,16 @@ testTxCreatesCollateralCorrectly = do assertCommandHistory state [ - ( 2 - , [text| - cardano-cli transaction calculate-min-required-utxo - --alonzo-era - --tx-out ${addr1}+${collatVal} - --protocol-params-file ./protocol.json - |] - ) - , ( 3 , [text| cardano-cli transaction build-raw - --alonzo-era + --babbage-era --tx-in ${inTxId}#0 --tx-out ${addr1}+${collatVal} --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 --protocol-params-file ./protocol.json - --out-file ./txs/tx-fa4c303a2d6feb62b43440d6e0b9a90f5b20b00ecfe5364b6927806b0e8e0198.raw + --out-file ./txs/tx-?.raw |] ) ] @@ -155,10 +172,100 @@ mintContract = do Constraints.mustMintValue (Value.singleton curSymbol "testToken" 5) <> Constraints.mustPayToPubKey paymentPkh2 - (Ada.lovelaceValueOf 1000 <> Value.singleton curSymbol "testToken" 5) + ( Ada.adaValueOf 3 -- use big enough Value to not to deal with min Ada adjustment + <> Value.singleton curSymbol "testToken" 5 + ) submitTxConstraintsWith @Void lookups constraints mintingPolicy :: Scripts.MintingPolicy mintingPolicy = Scripts.mkMintingPolicyScript $$(PlutusTx.compile [||(\_ _ -> ())||]) + +type ContractResult = + ( Maybe TxId.ChainIndexTxOut + , Maybe TxId.ChainIndexTxOut + , IsUtxoResponse + , UtxosResponse + , UtxosResponse + , Map TxOutRef TxId.ChainIndexTxOut + ) +testCollateralFiltering :: Assertion +testCollateralFiltering = do + let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 + txOut = PublicKeyChainIndexTxOut pkhAddr1 (Ada.adaValueOf 50) Nothing Nothing + initState = def & utxos <>~ [(txOutRef, txOut)] + + collateralOref = collateralTxOutRef theCollateralUtxo + + contract :: Plutus.Contract.Contract () EmptySchema Text ContractResult + contract = do + (ownAddress :| _) <- ownAddresses + txOutFromRef' <- txOutFromRef collateralOref + unspentTxOutFromRef' <- unspentTxOutFromRef collateralOref + utxoRefMembership' <- utxoRefMembership collateralOref + utxoRefsAt' <- utxoRefsAt (PageQuery (PageSize 10) Nothing) ownAddress + + let adaAsset = assetClass (CurrencySymbol "") (TokenName "") + utxoRefsWithCurrency' <- utxoRefsWithCurrency (PageQuery (PageSize 10) Nothing) adaAsset + utxosAt' <- utxosAt ownAddress + pure + ( txOutFromRef' + , unspentTxOutFromRef' + , utxoRefMembership' + , utxoRefsAt' + , utxoRefsWithCurrency' + , utxosAt' + ) + + case runContractPure contract initState of + ( Right + ( txOutFromRef' + , unspentTxOutFromRef' + , utxoRefMembership' + , utxoRefsAt' + , utxoRefsWithCurrency' + , utxosAt' + ) + , st + ) -> do + assertCollateralInDistribution collateralOref (st ^. utxos) + assertCollateralNotReturnedBy + "txOutFromRef" + txOutFromRef' + assertCollateralNotReturnedBy + "unspentTxOutFromRef" + unspentTxOutFromRef' + assertBool + "collateral should not be member of UTxO set" + (not $ isUtxo utxoRefMembership') + assertNotFoundIn + "utxoRefsAt response" + collateralOref + (pageItems $ page utxoRefsAt') + assertNotFoundIn + "utxoRefsWithCurrency response" + collateralOref + (pageItems $ page utxoRefsWithCurrency') + assertNotFoundIn + "utxosAt response" + collateralOref + (Map.keys utxosAt') + (Left e, _) -> assertFailure $ "Contract execution failed: " <> show e + where + assertCollateralNotReturnedBy request txOutFromRef' = + assertBool (request <> " should return Nothing for collateral UTxO") (isNothing txOutFromRef') + + assertNotFoundIn :: (Foldable t, Eq a) => String -> a -> t a -> Assertion + assertNotFoundIn what collateralOref outs = + assertBool (what <> " should not contain collateral") (isNothing $ find (== collateralOref) outs) + + assertCollateralInDistribution :: TxOutRef -> [(TxOutRef, Ledger.Tx.ChainIndexTxOut)] -> Assertion + assertCollateralInDistribution collateralOref utxs = + let collateral = lookup collateralOref utxs + in if isJust collateral + then pure () + else + assertFailure + "Collateral UTxO not found in mock utxos distribution \ + \ - should not happen. Interrupting test with failure." diff --git a/test/Spec/BotPlutusInterface/Contract.hs b/test/Spec/BotPlutusInterface/Contract.hs index 8a432025..c805231c 100644 --- a/test/Spec/BotPlutusInterface/Contract.hs +++ b/test/Spec/BotPlutusInterface/Contract.hs @@ -664,7 +664,7 @@ redeemFromValidator = do ( 1 , [text| cardano-cli transaction build-raw --babbage-era - --tx-in ${collateralTxId}#0 + --tx-in ${inTxId}#0 --tx-in ${inTxId}#1 --tx-in-script-file ./result-scripts/validator-${valHash'}.plutus --tx-in-datum-file ./result-scripts/datum-${datumHash'}.json @@ -680,7 +680,7 @@ redeemFromValidator = do ( 13 , [text| cardano-cli transaction build-raw --babbage-era - --tx-in ${collateralTxId}#0 + --tx-in ${inTxId}#0 --tx-in ${inTxId}#1 --tx-in-script-file ./result-scripts/validator-${valHash'}.plutus --tx-in-datum-file ./result-scripts/datum-${datumHash'}.json @@ -688,7 +688,7 @@ redeemFromValidator = do --tx-in-execution-units (500000,2000) --tx-in-collateral ${collateralTxId}#0 --tx-out ${addr2}+857690 - --tx-out ${addr1}+9143160 + --tx-out ${addr1}+49143160 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 400 --protocol-params-file ./protocol.json --out-file ./txs/tx-?.raw diff --git a/test/Spec/MockContract.hs b/test/Spec/MockContract.hs index 2fc62672..444435dc 100644 --- a/test/Spec/MockContract.hs +++ b/test/Spec/MockContract.hs @@ -54,9 +54,10 @@ module Spec.MockContract ( ) where import BotPlutusInterface.CardanoCLI (unsafeSerialiseAddress) -import BotPlutusInterface.CardanoNode.Effects (NodeQuery (PParams, UtxosAt)) +import BotPlutusInterface.CardanoNode.Effects (NodeQuery (PParams, UtxosAt, UtxosAtExcluding)) import BotPlutusInterface.CardanoNode.Query (toQueryError) -import BotPlutusInterface.Collateral (removeCollateralFromPage) + +import BotPlutusInterface.Collateral (withCollateralHandling) import BotPlutusInterface.Contract (handleContract) import BotPlutusInterface.Effects (PABEffect (..), ShellArgs (..), calcMinUtxo) import BotPlutusInterface.Files qualified as Files @@ -119,7 +120,7 @@ import Data.Kind (Type) import Data.List (isPrefixOf, sortOn) import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.Row (Row) import Data.Set qualified as Set import Data.Text (Text) @@ -153,7 +154,7 @@ import Ledger.Tx ( import Ledger.Tx qualified as Tx import Ledger.Value qualified as Value import NeatInterpolation (text) -import Plutus.ChainIndex.Api (QueryResponse (QueryResponse), UtxosResponse (..)) +import Plutus.ChainIndex.Api (IsUtxoResponse (IsUtxoResponse), QueryResponse (QueryResponse), UtxosResponse (..)) import Plutus.ChainIndex.Tx ( ChainIndexTx (..), ChainIndexTxOutputs (ValidTx), @@ -370,7 +371,12 @@ runPABEffectPure initState req = mockWriteFileTextEnvelope filepath envelopeDescr contents go (ListDirectory dir) = mockListDirectory dir go (UploadDir dir) = mockUploadDir dir - go (QueryChainIndex query) = mockQueryChainIndex query + go (QueryChainIndex query) = do + mCollateral <- _collateralUtxo <$> get @(MockContractState w) + withCollateralHandling + mCollateral + mockQueryChainIndex + query go (EstimateBudget file) = mockExBudget file go (SaveBudget txId budget) = mockSaveBudget txId budget go (SlotToPOSIXTime _) = pure $ Right 1506203091 @@ -657,22 +663,25 @@ mockQueryChainIndex = \case , _citxScripts = mempty , _citxCardanoTx = Nothing } - UtxoSetMembership _ -> - throwError @Text "UtxoSetMembership is unimplemented" + UtxoSetMembership oref -> do + state <- get @(MockContractState w) + pure $ + UtxoSetMembershipResponse $ + IsUtxoResponse (state ^. tip) (isJust $ lookup oref (state ^. utxos)) UtxoSetAtAddress pageQuery _ -> do state <- get @(MockContractState w) pure $ UtxoSetAtResponse $ UtxosResponse (state ^. tip) - (removeCollateralFromPage (_collateralUtxo state) $ pageOf pageQuery (Set.fromList (state ^. utxos ^.. traverse . _1))) + (pageOf pageQuery (Set.fromList (state ^. utxos ^.. traverse . _1))) UtxoSetWithCurrency pageQuery _ -> do state <- get @(MockContractState w) pure $ - UtxoSetAtResponse $ + UtxoSetWithCurrencyResponse $ UtxosResponse (state ^. tip) - (removeCollateralFromPage (_collateralUtxo state) (pageOf pageQuery (Set.fromList (state ^. utxos ^.. traverse . _1)))) + (pageOf pageQuery (Set.fromList (state ^. utxos ^.. traverse . _1))) TxsFromTxIds ids -> do -- TODO: Track some kind of state here, add tests to ensure this works correctly -- For now, empty txs @@ -697,7 +706,7 @@ mockQueryChainIndex = \case -- | Fills in gaps of inputs with garbage TxOuts, so that the indexes we know about are in the correct positions buildOutputsFromKnownUTxOs :: [(TxOutRef, ChainIndexTxOut)] -> TxId -> ChainIndexTxOutputs -buildOutputsFromKnownUTxOs knownUtxos txId = ValidTx $ map converCiTxOut $ fillGaps sortedRelatedRefs 0 +buildOutputsFromKnownUTxOs knownUtxos txId = ValidTx $ map convertCiTxOut $ fillGaps sortedRelatedRefs 0 where sortedRelatedRefs = sortOn (Tx.txOutRefIdx . fst) $ filter ((== txId) . Tx.txOutRefId . fst) knownUtxos fillGaps :: [(TxOutRef, ChainIndexTxOut)] -> Integer -> [ChainIndexTxOut] @@ -712,10 +721,10 @@ buildOutputsFromKnownUTxOs knownUtxos txId = ValidTx $ map converCiTxOut $ fillG Nothing Nothing -converCiTxOut :: ChainIndexTxOut -> CIT.ChainIndexTxOut -converCiTxOut (PublicKeyChainIndexTxOut addr val dat maybeRefSc) = +convertCiTxOut :: ChainIndexTxOut -> CIT.ChainIndexTxOut +convertCiTxOut (PublicKeyChainIndexTxOut addr val dat maybeRefSc) = CIT.ChainIndexTxOut addr val (convertMaybeDatum dat) (convertRefScript maybeRefSc) -converCiTxOut (ScriptChainIndexTxOut addr val eitherDatum maybeRefSc _) = +convertCiTxOut (ScriptChainIndexTxOut addr val eitherDatum maybeRefSc _) = let datum = case eitherDatum of (dh, Nothing) -> OutputDatumHash dh (_, Just d) -> OutputDatum d @@ -801,12 +810,16 @@ mockQueryNode :: forall (w :: Type) (a :: Type). NodeQuery a -> MockContract w a -mockQueryNode (UtxosAt _addr) = do - state <- get @(MockContractState w) - return $ Right $ Map.fromList (state ^. utxos) -mockQueryNode PParams = do - state <- get @(MockContractState w) - - case pcProtocolParams $ cePABConfig $ _contractEnv state of - Nothing -> return $ Left $ toQueryError @String "Not able to get protocol parameters." - (Just pparams) -> return $ Right pparams +mockQueryNode = \case + UtxosAt _addr -> do + state <- get @(MockContractState w) + return $ Right $ Map.fromList (state ^. utxos) + UtxosAtExcluding _addr excluded -> do + state <- get @(MockContractState w) + let filterNotExcluded = filter (not . (`Set.member` excluded) . fst) + return . Right . Map.fromList . filterNotExcluded $ (state ^. utxos) + PParams -> do + state <- get @(MockContractState w) + case pcProtocolParams $ cePABConfig $ _contractEnv state of + Nothing -> return $ Left $ toQueryError @String "Not able to get protocol parameters." + (Just pparams) -> return $ Right pparams