wip

Author: carbolymer

cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Predicate.hs

@@ -17,6 +17,7 @@ import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
 
 import RIO hiding (toList)
 
+import Control.Monad (guard)
 import Data.ByteString qualified as BS
 import Data.Set (Set)
 import Data.Set qualified as Set
@@ -29,42 +30,25 @@ matchesUtxoPredicate
   -> TxOut CtxUTxO era
   -> Bool
 matchesUtxoPredicate p txOut =
-  matchField && notField && allOfField && anyOfField
- where
-  matchField = case p ^. U5c.maybe'match of
-    Nothing -> True
-    Just pat -> matchesAnyUtxoPattern pat txOut
-  notField = all (\sub -> Prelude.not $ matchesUtxoPredicate sub txOut) (p ^. U5c.not)
-  allOfField = case p ^. U5c.allOf of
-    [] -> True
-    ps -> all (`matchesUtxoPredicate` txOut) ps
-  anyOfField = case p ^. U5c.anyOf of
-    [] -> True
-    ps -> any (`matchesUtxoPredicate` txOut) ps
+  all (`matchesAnyUtxoPattern` txOut) (p ^. U5c.maybe'match)
+    && not (any (`matchesUtxoPredicate` txOut) (p ^. U5c.not))
+    && all (`matchesUtxoPredicate` txOut) (p ^. U5c.allOf)
+    && (null (p ^. U5c.anyOf) || any (`matchesUtxoPredicate` txOut) (p ^. U5c.anyOf))
 
 matchesAnyUtxoPattern
   :: UtxoRpc.AnyUtxoPattern
   -> TxOut CtxUTxO era
   -> Bool
 matchesAnyUtxoPattern pat txOut =
-  case pat ^. U5c.maybe'utxoPattern of
-    Just (UtxoRpc.AnyUtxoPattern'Cardano txOutputPattern) ->
-      matchesTxOutputPattern txOutputPattern txOut
-    Nothing -> True
+  all (`matchesTxOutputPattern` txOut) (pat ^. U5c.maybe'cardano)
 
 matchesTxOutputPattern
   :: UtxoRpc.TxOutputPattern
   -> TxOut CtxUTxO era
   -> Bool
 matchesTxOutputPattern pat (TxOut addrInEra txOutValue _datum _script) =
-  addressMatches && assetMatches
- where
-  addressMatches = case pat ^. U5c.maybe'address of
-    Nothing -> True
-    Just addrPat -> matchesAddressPattern addrPat addrInEra
-  assetMatches = case pat ^. U5c.maybe'asset of
-    Nothing -> True
-    Just assetPat -> matchesAssetPattern assetPat (txOutValueToValue txOutValue)
+  all (`matchesAddressPattern` addrInEra) (pat ^. U5c.maybe'address)
+    && all (`matchesAssetPattern` txOutValueToValue txOutValue) (pat ^. U5c.maybe'asset)
 
 matchesAddressPattern
   :: UtxoRpc.AddressPattern
@@ -73,23 +57,22 @@ matchesAddressPattern
 matchesAddressPattern pat addr =
   exactMatch && paymentMatch && delegationMatch
  where
-  exact = pat ^. U5c.exactAddress
+  matchesRawField field actual = BS.null field || field == actual
+
   exactMatch = case addr of
-    AddressInEra ByronAddressInAnyEra a -> BS.null exact || serialiseToRawBytes a == exact
-    AddressInEra ShelleyAddressInEra{} a -> BS.null exact || serialiseToRawBytes a == exact
-  payment = pat ^. U5c.paymentPart
+    AddressInEra ByronAddressInAnyEra a -> matchesRawField (pat ^. U5c.exactAddress) $ serialiseToRawBytes a
+    AddressInEra ShelleyAddressInEra{} a -> matchesRawField (pat ^. U5c.exactAddress) $ serialiseToRawBytes a
   paymentMatch = case addr of
     AddressInEra ShelleyAddressInEra{} (ShelleyAddress _ payCred _) ->
-      BS.null payment || serialisePaymentCredential (fromShelleyPaymentCredential payCred) == payment
-    _ -> BS.null payment
-  deleg = pat ^. U5c.delegationPart
+      matchesRawField (pat ^. U5c.paymentPart) . serialisePaymentCredential $ fromShelleyPaymentCredential payCred
+    _ -> BS.null $ pat ^. U5c.paymentPart
   delegationMatch = case addr of
     AddressInEra ShelleyAddressInEra{} (ShelleyAddress _ _ stakeRef) ->
       case fromShelleyStakeReference stakeRef of
         StakeAddressByValue cred ->
-          BS.null deleg || serialiseStakeCredential cred == deleg
-        _ -> BS.null deleg
-    _ -> BS.null deleg
+          matchesRawField (pat ^. U5c.delegationPart) $ serialiseStakeCredential cred
+        _ -> BS.null $ pat ^. U5c.delegationPart
+    _ -> BS.null $ pat ^. U5c.delegationPart
 
 serialisePaymentCredential :: PaymentCredential -> ByteString
 serialisePaymentCredential (PaymentCredentialByKey h) = serialiseToRawBytes h
@@ -119,22 +102,16 @@ matchesAssetPattern pat value =
 extractAddressesFromPredicate :: UtxoRpc.UtxoPredicate -> Maybe (Set AddressAny)
 extractAddressesFromPredicate p =
   case (p ^. U5c.maybe'match, p ^. U5c.not, p ^. U5c.allOf, p ^. U5c.anyOf) of
-    -- Simple match with exact_address only
     (Just pat, [], [], []) -> extractAddressFromPattern pat
-    -- any_of where each has an exact address
     (Nothing, [], [], anyPreds@(_ : _)) ->
-      foldM (\acc sub -> Set.union acc <$> extractAddressesFromPredicate sub) Set.empty anyPreds
+      Set.unions <$> traverse extractAddressesFromPredicate anyPreds
     _ -> Nothing
  where
   extractAddressFromPattern :: UtxoRpc.AnyUtxoPattern -> Maybe (Set AddressAny)
-  extractAddressFromPattern pat =
-    case pat ^. U5c.maybe'utxoPattern of
-      Just (UtxoRpc.AnyUtxoPattern'Cardano txoPat) -> do
-        addrPat <- txoPat ^. U5c.maybe'address
-        let exact = addrPat ^. U5c.exactAddress
-        if BS.null exact
-          then Nothing
-          else do
-            addrAny <- either (const Nothing) Just $ deserialiseFromRawBytes AsAddressAny exact
-            Just (Set.singleton addrAny)
-      Nothing -> Nothing
+  extractAddressFromPattern pat = do
+    txoPat <- pat ^. U5c.maybe'cardano
+    addrPat <- txoPat ^. U5c.maybe'address
+    let exact = addrPat ^. U5c.exactAddress
+    guard $ not (BS.null exact)
+    addrAny <- either (const Nothing) Just $ deserialiseFromRawBytes AsAddressAny exact
+    pure $ Set.singleton addrAny