|
| 1 | +{-# LANGUAGE FlexibleContexts #-} |
| 2 | +{-# LANGUAGE GADTs #-} |
| 3 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 4 | + |
| 5 | +module Cardano.Rpc.Server.Internal.UtxoRpc.Predicate |
| 6 | + ( matchesUtxoPredicate |
| 7 | + , extractAddressesFromPredicate |
| 8 | + , matchesAddressPattern |
| 9 | + , matchesAssetPattern |
| 10 | + , matchesTxOutputPattern |
| 11 | + , matchesAnyUtxoPattern |
| 12 | + , serialisePaymentCredential |
| 13 | + , serialiseStakeCredential |
| 14 | + ) |
| 15 | +where |
| 16 | + |
| 17 | +import Cardano.Api.Address |
| 18 | +import Cardano.Api.Serialise.Raw |
| 19 | +import Cardano.Api.Tx |
| 20 | +import Cardano.Api.Value |
| 21 | +import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as U5c |
| 22 | +import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc |
| 23 | + |
| 24 | +import RIO hiding (toList) |
| 25 | + |
| 26 | +import Control.Monad (guard) |
| 27 | +import Data.ByteString qualified as BS |
| 28 | +import Data.Set (Set) |
| 29 | +import Data.Set qualified as Set |
| 30 | +import GHC.IsList |
| 31 | + |
| 32 | +-- | Check if a UTxO entry matches a 'UtxoPredicate'. |
| 33 | +-- All present fields are combined with AND logic. |
| 34 | +matchesUtxoPredicate |
| 35 | + :: UtxoRpc.UtxoPredicate |
| 36 | + -> TxOut CtxUTxO era |
| 37 | + -> Bool |
| 38 | +matchesUtxoPredicate p txOut = |
| 39 | + all (`matchesAnyUtxoPattern` txOut) (p ^. U5c.maybe'match) |
| 40 | + && not (any (`matchesUtxoPredicate` txOut) (p ^. U5c.not)) |
| 41 | + && all (`matchesUtxoPredicate` txOut) (p ^. U5c.allOf) |
| 42 | + && (null (p ^. U5c.anyOf) || any (`matchesUtxoPredicate` txOut) (p ^. U5c.anyOf)) |
| 43 | + |
| 44 | +-- | Check if a UTxO entry matches an 'AnyUtxoPattern'. |
| 45 | +-- Delegates to the Cardano-specific 'TxOutputPattern' if present. |
| 46 | +matchesAnyUtxoPattern |
| 47 | + :: UtxoRpc.AnyUtxoPattern |
| 48 | + -> TxOut CtxUTxO era |
| 49 | + -> Bool |
| 50 | +matchesAnyUtxoPattern pat txOut = |
| 51 | + all (`matchesTxOutputPattern` txOut) (pat ^. U5c.maybe'cardano) |
| 52 | + |
| 53 | +-- | Check if a tx output matches a 'TxOutputPattern'. |
| 54 | +-- Address and asset filters are combined with AND; absent fields are vacuously true. |
| 55 | +matchesTxOutputPattern |
| 56 | + :: UtxoRpc.TxOutputPattern |
| 57 | + -> TxOut CtxUTxO era |
| 58 | + -> Bool |
| 59 | +matchesTxOutputPattern pat (TxOut addrInEra txOutValue _datum _script) = |
| 60 | + all (`matchesAddressPattern` addrInEra) (pat ^. U5c.maybe'address) |
| 61 | + && all (`matchesAssetPattern` txOutValueToValue txOutValue) (pat ^. U5c.maybe'asset) |
| 62 | + |
| 63 | +-- | Check if an address matches an 'AddressPattern'. |
| 64 | +-- All present fields (exact, payment, delegation) must match (AND logic). |
| 65 | +-- Byron addresses only support exact matching; payment\/delegation filters reject them. |
| 66 | +matchesAddressPattern |
| 67 | + :: UtxoRpc.AddressPattern |
| 68 | + -> AddressInEra era |
| 69 | + -> Bool |
| 70 | +matchesAddressPattern pat addr = |
| 71 | + exactMatch && paymentMatch && delegationMatch |
| 72 | + where |
| 73 | + matchesRawField field actual = BS.null field || field == actual |
| 74 | + |
| 75 | + exactMatch = case addr of |
| 76 | + AddressInEra ByronAddressInAnyEra a -> matchesRawField (pat ^. U5c.exactAddress) $ serialiseToRawBytes a |
| 77 | + AddressInEra ShelleyAddressInEra{} a -> matchesRawField (pat ^. U5c.exactAddress) $ serialiseToRawBytes a |
| 78 | + paymentMatch = case addr of |
| 79 | + AddressInEra ShelleyAddressInEra{} (ShelleyAddress _ payCred _) -> |
| 80 | + matchesRawField (pat ^. U5c.paymentPart) . serialisePaymentCredential $ fromShelleyPaymentCredential payCred |
| 81 | + _ -> BS.null $ pat ^. U5c.paymentPart |
| 82 | + delegationMatch = case addr of |
| 83 | + AddressInEra ShelleyAddressInEra{} (ShelleyAddress _ _ stakeRef) -> |
| 84 | + case fromShelleyStakeReference stakeRef of |
| 85 | + StakeAddressByValue cred -> |
| 86 | + matchesRawField (pat ^. U5c.delegationPart) $ serialiseStakeCredential cred |
| 87 | + _ -> BS.null $ pat ^. U5c.delegationPart |
| 88 | + _ -> BS.null $ pat ^. U5c.delegationPart |
| 89 | + |
| 90 | +-- | Serialise a 'PaymentCredential' to raw bytes (the key or script hash). |
| 91 | +serialisePaymentCredential :: PaymentCredential -> ByteString |
| 92 | +serialisePaymentCredential (PaymentCredentialByKey h) = serialiseToRawBytes h |
| 93 | +serialisePaymentCredential (PaymentCredentialByScript h) = serialiseToRawBytes h |
| 94 | + |
| 95 | +-- | Serialise a 'StakeCredential' to raw bytes (the key or script hash). |
| 96 | +serialiseStakeCredential :: StakeCredential -> ByteString |
| 97 | +serialiseStakeCredential (StakeCredentialByKey h) = serialiseToRawBytes h |
| 98 | +serialiseStakeCredential (StakeCredentialByScript h) = serialiseToRawBytes h |
| 99 | + |
| 100 | +-- | Check if a 'Value' contains a native asset matching an 'AssetPattern'. |
| 101 | +-- Ada entries are always skipped; zero-quantity entries do not match. |
| 102 | +matchesAssetPattern |
| 103 | + :: UtxoRpc.AssetPattern |
| 104 | + -> Value |
| 105 | + -> Bool |
| 106 | +matchesAssetPattern pat value = |
| 107 | + any matchesEntry (toList value) |
| 108 | + where |
| 109 | + pid = pat ^. U5c.policyId |
| 110 | + aname = pat ^. U5c.assetName |
| 111 | + matchesEntry (AssetId pId aName, Quantity qty) = |
| 112 | + (BS.null pid || serialiseToRawBytes pId == pid) |
| 113 | + && (BS.null aname || serialiseToRawBytes aName == aname) |
| 114 | + && qty > 0 |
| 115 | + matchesEntry (AdaAssetId, _) = False |
| 116 | + |
| 117 | +-- | Try to extract a set of exact addresses from the predicate for use with 'QueryUTxOByAddress'. |
| 118 | +-- Returns 'Just' if the optimization is applicable, 'Nothing' otherwise. |
| 119 | +extractAddressesFromPredicate :: UtxoRpc.UtxoPredicate -> Maybe (Set AddressAny) |
| 120 | +extractAddressesFromPredicate p = |
| 121 | + case (p ^. U5c.maybe'match, p ^. U5c.not, p ^. U5c.allOf, p ^. U5c.anyOf) of |
| 122 | + (Just pat, [], [], []) -> extractAddressFromPattern pat |
| 123 | + (Nothing, [], [], anyPreds@(_ : _)) -> |
| 124 | + Set.unions <$> traverse extractAddressesFromPredicate anyPreds |
| 125 | + _ -> Nothing |
| 126 | + where |
| 127 | + extractAddressFromPattern :: UtxoRpc.AnyUtxoPattern -> Maybe (Set AddressAny) |
| 128 | + extractAddressFromPattern pat = do |
| 129 | + txoPat <- pat ^. U5c.maybe'cardano |
| 130 | + addrPat <- txoPat ^. U5c.maybe'address |
| 131 | + let exact = addrPat ^. U5c.exactAddress |
| 132 | + guard $ not (BS.null exact) |
| 133 | + addrAny <- either (const Nothing) Just $ deserialiseFromRawBytes AsAddressAny exact |
| 134 | + pure $ Set.singleton addrAny |
0 commit comments