{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Rpc.Server.Internal.UtxoRpc.Predicate
  ( matchesUtxoPredicate
  , extractAddressesFromPredicate
  , matchesAddressPattern
  , matchesAssetPattern
  , matchesTxOutputPattern
  , matchesAnyUtxoPattern
  , serialisePaymentCredential
  , serialiseStakeCredential
  )
where

import Cardano.Api.Address
import Cardano.Api.Era
import Cardano.Api.Serialise.Raw
import Cardano.Api.Tx
import Cardano.Api.Value
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc

import RIO hiding (toList)

import Data.ByteString qualified as BS
import Data.Set qualified as Set
import GHC.IsList

-- | Check if a UTxO entry matches a 'UtxoPredicate'.
-- All present fields are combined with AND logic.
matchesUtxoPredicate
  :: IsCardanoEra era
  => UtxoRpc.UtxoPredicate
  -> TxOut CtxUTxO era
  -> Bool
matchesUtxoPredicate :: forall era.
IsCardanoEra era =>
UtxoPredicate -> TxOut CtxUTxO era -> Bool
matchesUtxoPredicate UtxoPredicate
p TxOut CtxUTxO era
txOut =
  (AnyUtxoPattern -> Bool) -> Maybe AnyUtxoPattern -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (AnyUtxoPattern -> TxOut CtxUTxO era -> Bool
forall era.
IsCardanoEra era =>
AnyUtxoPattern -> TxOut CtxUTxO era -> Bool
`matchesAnyUtxoPattern` TxOut CtxUTxO era
txOut) (UtxoPredicate
p UtxoPredicate
-> Getting
     (Maybe AnyUtxoPattern) UtxoPredicate (Maybe AnyUtxoPattern)
-> Maybe AnyUtxoPattern
forall s a. s -> Getting a s a -> a
^. Getting (Maybe AnyUtxoPattern) UtxoPredicate (Maybe AnyUtxoPattern)
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'match" a) =>
LensLike' f s a
UtxoRpc.maybe'match)
    Bool -> Bool -> Bool
&& Bool -> Bool
not ((UtxoPredicate -> Bool) -> [UtxoPredicate] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UtxoPredicate -> TxOut CtxUTxO era -> Bool
forall era.
IsCardanoEra era =>
UtxoPredicate -> TxOut CtxUTxO era -> Bool
`matchesUtxoPredicate` TxOut CtxUTxO era
txOut) (UtxoPredicate
p UtxoPredicate
-> Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
-> [UtxoPredicate]
forall s a. s -> Getting a s a -> a
^. Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
forall (f :: * -> *) s a.
(Functor f, HasField s "not" a) =>
LensLike' f s a
UtxoRpc.not))
    Bool -> Bool -> Bool
&& (UtxoPredicate -> Bool) -> [UtxoPredicate] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (UtxoPredicate -> TxOut CtxUTxO era -> Bool
forall era.
IsCardanoEra era =>
UtxoPredicate -> TxOut CtxUTxO era -> Bool
`matchesUtxoPredicate` TxOut CtxUTxO era
txOut) (UtxoPredicate
p UtxoPredicate
-> Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
-> [UtxoPredicate]
forall s a. s -> Getting a s a -> a
^. Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
forall (f :: * -> *) s a.
(Functor f, HasField s "allOf" a) =>
LensLike' f s a
UtxoRpc.allOf)
    Bool -> Bool -> Bool
&& ([UtxoPredicate] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (UtxoPredicate
p UtxoPredicate
-> Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
-> [UtxoPredicate]
forall s a. s -> Getting a s a -> a
^. Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
forall (f :: * -> *) s a.
(Functor f, HasField s "anyOf" a) =>
LensLike' f s a
UtxoRpc.anyOf) Bool -> Bool -> Bool
|| (UtxoPredicate -> Bool) -> [UtxoPredicate] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UtxoPredicate -> TxOut CtxUTxO era -> Bool
forall era.
IsCardanoEra era =>
UtxoPredicate -> TxOut CtxUTxO era -> Bool
`matchesUtxoPredicate` TxOut CtxUTxO era
txOut) (UtxoPredicate
p UtxoPredicate
-> Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
-> [UtxoPredicate]
forall s a. s -> Getting a s a -> a
^. Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
forall (f :: * -> *) s a.
(Functor f, HasField s "anyOf" a) =>
LensLike' f s a
UtxoRpc.anyOf))

-- | Check if a UTxO entry matches an 'AnyUtxoPattern'.
-- Delegates to the Cardano-specific 'TxOutputPattern' if present.
matchesAnyUtxoPattern
  :: IsCardanoEra era
  => UtxoRpc.AnyUtxoPattern
  -> TxOut CtxUTxO era
  -> Bool
matchesAnyUtxoPattern :: forall era.
IsCardanoEra era =>
AnyUtxoPattern -> TxOut CtxUTxO era -> Bool
matchesAnyUtxoPattern AnyUtxoPattern
pat TxOut CtxUTxO era
txOut =
  (TxOutputPattern -> Bool) -> Maybe TxOutputPattern -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TxOutputPattern -> TxOut CtxUTxO era -> Bool
forall era.
IsCardanoEra era =>
TxOutputPattern -> TxOut CtxUTxO era -> Bool
`matchesTxOutputPattern` TxOut CtxUTxO era
txOut) (AnyUtxoPattern
pat AnyUtxoPattern
-> Getting
     (Maybe TxOutputPattern) AnyUtxoPattern (Maybe TxOutputPattern)
-> Maybe TxOutputPattern
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe TxOutputPattern) AnyUtxoPattern (Maybe TxOutputPattern)
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'cardano" a) =>
LensLike' f s a
UtxoRpc.maybe'cardano)

-- | Check if a tx output matches a 'TxOutputPattern'.
-- Address and asset filters are combined with AND; absent fields are vacuously true.
matchesTxOutputPattern
  :: IsCardanoEra era
  => UtxoRpc.TxOutputPattern
  -> TxOut CtxUTxO era
  -> Bool
matchesTxOutputPattern :: forall era.
IsCardanoEra era =>
TxOutputPattern -> TxOut CtxUTxO era -> Bool
matchesTxOutputPattern TxOutputPattern
pat (TxOut AddressInEra era
addrInEra TxOutValue era
txOutValue TxOutDatum CtxUTxO era
_datum ReferenceScript era
_script) =
  (AddressPattern -> Bool) -> Maybe AddressPattern -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (AddressPattern -> AddressInEra era -> Bool
forall era.
IsCardanoEra era =>
AddressPattern -> AddressInEra era -> Bool
`matchesAddressPattern` AddressInEra era
addrInEra) (TxOutputPattern
pat TxOutputPattern
-> Getting
     (Maybe AddressPattern) TxOutputPattern (Maybe AddressPattern)
-> Maybe AddressPattern
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe AddressPattern) TxOutputPattern (Maybe AddressPattern)
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'address" a) =>
LensLike' f s a
UtxoRpc.maybe'address)
    Bool -> Bool -> Bool
&& (AssetPattern -> Bool) -> Maybe AssetPattern -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (AssetPattern -> Value -> Bool
`matchesAssetPattern` TxOutValue era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue era
txOutValue) (TxOutputPattern
pat TxOutputPattern
-> Getting
     (Maybe AssetPattern) TxOutputPattern (Maybe AssetPattern)
-> Maybe AssetPattern
forall s a. s -> Getting a s a -> a
^. Getting (Maybe AssetPattern) TxOutputPattern (Maybe AssetPattern)
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'asset" a) =>
LensLike' f s a
UtxoRpc.maybe'asset)

-- | Check if an address matches an 'AddressPattern'.
-- All present fields (exact, payment, delegation) must match (AND logic).
-- Byron addresses only support exact matching; payment\/delegation filters reject them.
matchesAddressPattern
  :: IsCardanoEra era
  => UtxoRpc.AddressPattern
  -> AddressInEra era
  -> Bool
matchesAddressPattern :: forall era.
IsCardanoEra era =>
AddressPattern -> AddressInEra era -> Bool
matchesAddressPattern AddressPattern
pat AddressInEra era
addr =
  Bool
exactMatch Bool -> Bool -> Bool
&& Bool
paymentMatch Bool -> Bool -> Bool
&& Bool
delegationMatch
 where
  -- proto3 optional bytes defaults to empty when absent
  matchesRawField :: ByteString -> ByteString -> Bool
matchesRawField ByteString
field ByteString
actual = ByteString -> Bool
BS.null ByteString
field Bool -> Bool -> Bool
|| ByteString
field ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
actual

  exactMatch :: Bool
exactMatch = ByteString -> ByteString -> Bool
matchesRawField (AddressPattern
pat AddressPattern
-> Getting ByteString AddressPattern ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString AddressPattern ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "exactAddress" a) =>
LensLike' f s a
UtxoRpc.exactAddress) (ByteString -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ AddressInEra era -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes AddressInEra era
addr
  paymentMatch :: Bool
paymentMatch = case AddressInEra era
addr of
    AddressInEra ShelleyAddressInEra{} (ShelleyAddress Network
_ Credential Payment
payCred StakeReference
_) ->
      ByteString -> ByteString -> Bool
matchesRawField (AddressPattern
pat AddressPattern
-> Getting ByteString AddressPattern ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString AddressPattern ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "paymentPart" a) =>
LensLike' f s a
UtxoRpc.paymentPart) (ByteString -> Bool)
-> (PaymentCredential -> ByteString) -> PaymentCredential -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PaymentCredential -> ByteString
serialisePaymentCredential (PaymentCredential -> Bool) -> PaymentCredential -> Bool
forall a b. (a -> b) -> a -> b
$
        Credential Payment -> PaymentCredential
fromShelleyPaymentCredential Credential Payment
payCred
    AddressInEra era
_ -> ByteString -> Bool
BS.null (ByteString -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ AddressPattern
pat AddressPattern
-> Getting ByteString AddressPattern ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString AddressPattern ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "paymentPart" a) =>
LensLike' f s a
UtxoRpc.paymentPart
  delegationMatch :: Bool
delegationMatch = case AddressInEra era
addr of
    AddressInEra ShelleyAddressInEra{} (ShelleyAddress Network
_ Credential Payment
_ StakeReference
stakeRef) ->
      case StakeReference -> StakeAddressReference
fromShelleyStakeReference StakeReference
stakeRef of
        StakeAddressByValue StakeCredential
cred ->
          ByteString -> ByteString -> Bool
matchesRawField (AddressPattern
pat AddressPattern
-> Getting ByteString AddressPattern ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString AddressPattern ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "delegationPart" a) =>
LensLike' f s a
UtxoRpc.delegationPart) (ByteString -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ StakeCredential -> ByteString
serialiseStakeCredential StakeCredential
cred
        StakeAddressReference
_ -> ByteString -> Bool
BS.null (ByteString -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ AddressPattern
pat AddressPattern
-> Getting ByteString AddressPattern ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString AddressPattern ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "delegationPart" a) =>
LensLike' f s a
UtxoRpc.delegationPart
    AddressInEra era
_ -> ByteString -> Bool
BS.null (ByteString -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ AddressPattern
pat AddressPattern
-> Getting ByteString AddressPattern ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString AddressPattern ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "delegationPart" a) =>
LensLike' f s a
UtxoRpc.delegationPart

-- | Serialise a 'PaymentCredential' to raw bytes (the key or script hash).
serialisePaymentCredential :: PaymentCredential -> ByteString
serialisePaymentCredential :: PaymentCredential -> ByteString
serialisePaymentCredential (PaymentCredentialByKey Hash PaymentKey
h) = Hash PaymentKey -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes Hash PaymentKey
h
serialisePaymentCredential (PaymentCredentialByScript ScriptHash
h) = ScriptHash -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes ScriptHash
h

-- | Serialise a 'StakeCredential' to raw bytes (the key or script hash).
serialiseStakeCredential :: StakeCredential -> ByteString
serialiseStakeCredential :: StakeCredential -> ByteString
serialiseStakeCredential (StakeCredentialByKey Hash StakeKey
h) = Hash StakeKey -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes Hash StakeKey
h
serialiseStakeCredential (StakeCredentialByScript ScriptHash
h) = ScriptHash -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes ScriptHash
h

-- | Check if a 'Value' contains a native asset matching an 'AssetPattern'.
-- Ada entries are always skipped; zero-quantity entries do not match.
matchesAssetPattern
  :: UtxoRpc.AssetPattern
  -> Value
  -> Bool
matchesAssetPattern :: AssetPattern -> Value -> Bool
matchesAssetPattern AssetPattern
pat Value
value =
  ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (AssetId, Quantity) -> Bool
matchesEntry (Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList Value
value)
 where
  patternPolicy :: ByteString
patternPolicy = AssetPattern
pat AssetPattern
-> Getting ByteString AssetPattern ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString AssetPattern ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "policyId" a) =>
LensLike' f s a
UtxoRpc.policyId
  patternTokenName :: ByteString
patternTokenName = AssetPattern
pat AssetPattern
-> Getting ByteString AssetPattern ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString AssetPattern ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "assetName" a) =>
LensLike' f s a
UtxoRpc.assetName
  matchesEntry :: (AssetId, Quantity) -> Bool
matchesEntry (AssetId PolicyId
policy AssetName
tokenName, Quantity Integer
qty) =
    (ByteString -> Bool
BS.null ByteString
patternPolicy Bool -> Bool -> Bool
|| PolicyId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes PolicyId
policy ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
patternPolicy)
      Bool -> Bool -> Bool
&& (ByteString -> Bool
BS.null ByteString
patternTokenName Bool -> Bool -> Bool
|| AssetName -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes AssetName
tokenName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
patternTokenName)
      Bool -> Bool -> Bool
&& Integer
qty Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0
  matchesEntry (AssetId
AdaAssetId, Quantity
_) = Bool
False

-- | Try to extract a set of exact addresses from the predicate for use with 'QueryUTxOByAddress'.
-- Returns 'Just' if the optimization is applicable, 'Nothing' otherwise.
extractAddressesFromPredicate :: UtxoRpc.UtxoPredicate -> Maybe (Set AddressAny)
extractAddressesFromPredicate :: UtxoPredicate -> Maybe (Set AddressAny)
extractAddressesFromPredicate UtxoPredicate
p =
  case (UtxoPredicate
p UtxoPredicate
-> Getting
     (Maybe AnyUtxoPattern) UtxoPredicate (Maybe AnyUtxoPattern)
-> Maybe AnyUtxoPattern
forall s a. s -> Getting a s a -> a
^. Getting (Maybe AnyUtxoPattern) UtxoPredicate (Maybe AnyUtxoPattern)
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'match" a) =>
LensLike' f s a
UtxoRpc.maybe'match, UtxoPredicate
p UtxoPredicate
-> Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
-> [UtxoPredicate]
forall s a. s -> Getting a s a -> a
^. Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
forall (f :: * -> *) s a.
(Functor f, HasField s "not" a) =>
LensLike' f s a
UtxoRpc.not, UtxoPredicate
p UtxoPredicate
-> Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
-> [UtxoPredicate]
forall s a. s -> Getting a s a -> a
^. Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
forall (f :: * -> *) s a.
(Functor f, HasField s "allOf" a) =>
LensLike' f s a
UtxoRpc.allOf, UtxoPredicate
p UtxoPredicate
-> Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
-> [UtxoPredicate]
forall s a. s -> Getting a s a -> a
^. Getting [UtxoPredicate] UtxoPredicate [UtxoPredicate]
forall (f :: * -> *) s a.
(Functor f, HasField s "anyOf" a) =>
LensLike' f s a
UtxoRpc.anyOf) of
    (Just AnyUtxoPattern
pat, [], [], []) -> AnyUtxoPattern -> Maybe (Set AddressAny)
extractAddressFromPattern AnyUtxoPattern
pat
    (Maybe AnyUtxoPattern
Nothing, [], [], anyPreds :: [UtxoPredicate]
anyPreds@(UtxoPredicate
_ : [UtxoPredicate]
_)) ->
      [Set AddressAny] -> Set AddressAny
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set AddressAny] -> Set AddressAny)
-> Maybe [Set AddressAny] -> Maybe (Set AddressAny)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UtxoPredicate -> Maybe (Set AddressAny))
-> [UtxoPredicate] -> Maybe [Set AddressAny]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse UtxoPredicate -> Maybe (Set AddressAny)
extractAddressesFromPredicate [UtxoPredicate]
anyPreds
    (Maybe AnyUtxoPattern, [UtxoPredicate], [UtxoPredicate],
 [UtxoPredicate])
_ -> Maybe (Set AddressAny)
forall a. Maybe a
Nothing
 where
  extractAddressFromPattern :: UtxoRpc.AnyUtxoPattern -> Maybe (Set AddressAny)
  extractAddressFromPattern :: AnyUtxoPattern -> Maybe (Set AddressAny)
extractAddressFromPattern AnyUtxoPattern
pat = do
    txoPat <- AnyUtxoPattern
pat AnyUtxoPattern
-> Getting
     (Maybe TxOutputPattern) AnyUtxoPattern (Maybe TxOutputPattern)
-> Maybe TxOutputPattern
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe TxOutputPattern) AnyUtxoPattern (Maybe TxOutputPattern)
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'cardano" a) =>
LensLike' f s a
UtxoRpc.maybe'cardano
    addrPat <- txoPat ^. UtxoRpc.maybe'address
    let exact = AddressPattern
addrPat AddressPattern
-> Getting ByteString AddressPattern ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString AddressPattern ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "exactAddress" a) =>
LensLike' f s a
UtxoRpc.exactAddress
    guard $ not (BS.null exact)
    addrAny <- either (const Nothing) Just $ deserialiseFromRawBytes AsAddressAny exact
    pure $ Set.singleton addrAny