{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Rpc.Server.Internal.UtxoRpc.Query
  ( readParamsMethod
  , readUtxosMethod
  , searchUtxosMethod
  , paginateByTxIn
  )
where

import Cardano.Api
import Cardano.Api.Experimental.Era
import Cardano.Api.Parser.Text qualified as P
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as U5c
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
import Cardano.Rpc.Server.Internal.Error
import Cardano.Rpc.Server.Internal.Monad
import Cardano.Rpc.Server.Internal.Orphans ()
import Cardano.Rpc.Server.Internal.UtxoRpc.Predicate
import Cardano.Rpc.Server.Internal.UtxoRpc.Type

import RIO hiding (toList)

import Control.Error.Util (hush)
import Data.Default
import Data.List (sortBy)
import Data.ProtoLens (defMessage)
import Data.Time.Clock (UTCTime)
import GHC.IsList
import Network.GRPC.Spec

-- | Handle the @ReadParams@ RPC method.
-- Queries the node for current protocol parameters and returns them
-- along with the ledger tip.
readParamsMethod
  :: MonadRpc e m
  => Proto UtxoRpc.ReadParamsRequest
  -> m (Proto UtxoRpc.ReadParamsResponse)
readParamsMethod :: forall e (m :: * -> *).
MonadRpc e m =>
Proto ReadParamsRequest -> m (Proto ReadParamsResponse)
readParamsMethod Proto ReadParamsRequest
_req = do
  -- TODO: implement field masks - they are ignored for now
  -- they need to be normalised beforehand, see: https://github.com/protocolbuffers/protobuf/blob/main/java/util/src/main/java/com/google/protobuf/util/FieldMaskTree.java#L76
  -- let fieldMask :: [Text] = req ^. #fieldMask . #paths
  nodeConnInfo <- m LocalNodeConnectInfo
forall field env (m :: * -> *).
(Has field env, MonadReader env m) =>
m field
grab
  AnyCardanoEra era <- liftIO . throwExceptT $ determineEra nodeConnInfo
  eon <- forEraInEon @Era era (error "Minimum Conway era required") pure
  let sbe = Era era -> ShelleyBasedEra era
forall era. Era era -> ShelleyBasedEra era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
eon

  let target = Target point
forall point. Target point
VolatileTip
  (pparams, chainPoint, blockNo, systemStart, eraHistory) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
    pparams <- throwEither =<< throwEither =<< queryProtocolParameters sbe
    chainPoint <- throwEither =<< queryChainPoint
    blockNo <- throwEither =<< queryChainBlockNo
    systemStart <- throwEither =<< querySystemStart
    eraHistory <- throwEither =<< queryEraHistory
    pure (pparams, chainPoint, blockNo, systemStart, eraHistory)

  timestamp <- slotToTimestamp systemStart eraHistory chainPoint

  pure $
    def
      & U5c.ledgerTip .~ mkChainPointMsg chainPoint blockNo timestamp
      & U5c.values . U5c.cardano .~ obtainCommonConstraints eon (protocolParamsToUtxoRpcPParams eon pparams)

-- | Handle the @ReadUtxos@ RPC method.
-- Looks up specific UTxO entries by their 'TxIn' keys and returns them
-- along with the ledger tip.
readUtxosMethod
  :: MonadRpc e m
  => Proto UtxoRpc.ReadUtxosRequest
  -> m (Proto UtxoRpc.ReadUtxosResponse)
readUtxosMethod :: forall e (m :: * -> *).
MonadRpc e m =>
Proto ReadUtxosRequest -> m (Proto ReadUtxosResponse)
readUtxosMethod Proto ReadUtxosRequest
req = do
  utxoFilter <-
    if Bool -> Bool
not ([Proto TxoRef] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Proto TxoRef] -> Bool) -> [Proto TxoRef] -> Bool
forall a b. (a -> b) -> a -> b
$ Proto ReadUtxosRequest
req Proto ReadUtxosRequest
-> Getting [Proto TxoRef] (Proto ReadUtxosRequest) [Proto TxoRef]
-> [Proto TxoRef]
forall s a. s -> Getting a s a -> a
^. Getting [Proto TxoRef] (Proto ReadUtxosRequest) [Proto TxoRef]
forall (f :: * -> *) s a.
(Functor f, HasField s "keys" a) =>
LensLike' f s a
U5c.keys)
      then Set TxIn -> QueryUTxOFilter
QueryUTxOByTxIn (Set TxIn -> QueryUTxOFilter)
-> ([TxIn] -> Set TxIn) -> [TxIn] -> QueryUTxOFilter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Item (Set TxIn)] -> Set TxIn
[TxIn] -> Set TxIn
forall l. IsList l => [Item l] -> l
fromList ([TxIn] -> QueryUTxOFilter) -> m [TxIn] -> m QueryUTxOFilter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Proto TxoRef -> m TxIn) -> [Proto TxoRef] -> m [TxIn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Proto TxoRef -> m TxIn
forall e (m :: * -> *). MonadRpc e m => Proto TxoRef -> m TxIn
txoRefToTxIn (Proto ReadUtxosRequest
req Proto ReadUtxosRequest
-> Getting [Proto TxoRef] (Proto ReadUtxosRequest) [Proto TxoRef]
-> [Proto TxoRef]
forall s a. s -> Getting a s a -> a
^. Getting [Proto TxoRef] (Proto ReadUtxosRequest) [Proto TxoRef]
forall (f :: * -> *) s a.
(Functor f, HasField s "keys" a) =>
LensLike' f s a
U5c.keys)
      else QueryUTxOFilter -> m QueryUTxOFilter
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryUTxOFilter
QueryUTxOWhole

  nodeConnInfo <- grab
  AnyCardanoEra era <- liftIO . throwExceptT $ determineEra nodeConnInfo
  eon <- forEraInEon @Era era (error "Minimum Conway era required") pure

  let target = Target point
forall point. Target point
VolatileTip
  (utxo, chainPoint, blockNo, systemStart, eraHistory) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
    utxo <- throwEither =<< throwEither =<< queryUtxo (convert eon) utxoFilter
    chainPoint <- throwEither =<< queryChainPoint
    blockNo <- throwEither =<< queryChainBlockNo
    systemStart <- throwEither =<< querySystemStart
    eraHistory <- throwEither =<< queryEraHistory
    pure (utxo, chainPoint, blockNo, systemStart, eraHistory)

  timestamp <- slotToTimestamp systemStart eraHistory chainPoint

  pure $
    defMessage
      & U5c.ledgerTip .~ mkChainPointMsg chainPoint blockNo timestamp
      & U5c.items .~ obtainCommonConstraints eon (utxoToUtxoRpcAnyUtxoData utxo)
 where
  txoRefToTxIn :: MonadRpc e m => Proto UtxoRpc.TxoRef -> m TxIn
  txoRefToTxIn :: forall e (m :: * -> *). MonadRpc e m => Proto TxoRef -> m TxIn
txoRefToTxIn Proto TxoRef
r = do
    txId' <- Either SerialiseAsRawBytesError TxId -> m TxId
forall e (m :: * -> *) a.
(Error e, HasCallStack, MonadIO m, Show e, Typeable e) =>
Either e a -> m a
throwEither (Either SerialiseAsRawBytesError TxId -> m TxId)
-> Either SerialiseAsRawBytesError TxId -> m TxId
forall a b. (a -> b) -> a -> b
$ AsType TxId -> ByteString -> Either SerialiseAsRawBytesError TxId
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes AsType TxId
AsTxId (ByteString -> Either SerialiseAsRawBytesError TxId)
-> ByteString -> Either SerialiseAsRawBytesError TxId
forall a b. (a -> b) -> a -> b
$ Proto TxoRef
r Proto TxoRef
-> Getting ByteString (Proto TxoRef) ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString (Proto TxoRef) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "hash" a) =>
LensLike' f s a
U5c.hash
    pure $ TxIn txId' (TxIx . fromIntegral $ r ^. U5c.index)

-- | Handle the @SearchUtxos@ RPC method.
-- Filters the UTxO set by a predicate and returns a paginated result.
-- When the predicate contains exact address matches, the query is narrowed
-- to those addresses; otherwise the entire UTxO set is fetched.
searchUtxosMethod
  :: MonadRpc e m
  => Proto UtxoRpc.SearchUtxosRequest
  -> m (Proto UtxoRpc.SearchUtxosResponse)
searchUtxosMethod :: forall e (m :: * -> *).
MonadRpc e m =>
Proto SearchUtxosRequest -> m (Proto SearchUtxosResponse)
searchUtxosMethod Proto SearchUtxosRequest
req = do
  -- TODO: field masks are ignored for now (same as readParamsMethod)
  let mPredicate :: Maybe UtxoPredicate
mPredicate = (Proto UtxoPredicate -> UtxoPredicate)
-> Maybe (Proto UtxoPredicate) -> Maybe UtxoPredicate
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Proto UtxoPredicate -> UtxoPredicate
forall msg. Proto msg -> msg
getProto (Maybe (Proto UtxoPredicate) -> Maybe UtxoPredicate)
-> Maybe (Proto UtxoPredicate) -> Maybe UtxoPredicate
forall a b. (a -> b) -> a -> b
$ Proto SearchUtxosRequest
req Proto SearchUtxosRequest
-> Getting
     (Maybe (Proto UtxoPredicate))
     (Proto SearchUtxosRequest)
     (Maybe (Proto UtxoPredicate))
-> Maybe (Proto UtxoPredicate)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Proto UtxoPredicate))
  (Proto SearchUtxosRequest)
  (Maybe (Proto UtxoPredicate))
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'predicate" a) =>
LensLike' f s a
U5c.maybe'predicate
      maxItems :: Int32
maxItems = Proto SearchUtxosRequest
req Proto SearchUtxosRequest
-> Getting Int32 (Proto SearchUtxosRequest) Int32 -> Int32
forall s a. s -> Getting a s a -> a
^. Getting Int32 (Proto SearchUtxosRequest) Int32
forall (f :: * -> *) s a.
(Functor f, HasField s "maxItems" a) =>
LensLike' f s a
U5c.maxItems
      startToken :: Maybe Text
startToken = Proto SearchUtxosRequest
req Proto SearchUtxosRequest
-> Getting (Maybe Text) (Proto SearchUtxosRequest) (Maybe Text)
-> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) (Proto SearchUtxosRequest) (Maybe Text)
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'startToken" a) =>
LensLike' f s a
U5c.maybe'startToken

  -- Determine query strategy: use address-based query if possible, otherwise fetch whole UTxO
  let utxoFilter :: QueryUTxOFilter
utxoFilter = case Maybe UtxoPredicate
mPredicate Maybe UtxoPredicate
-> (UtxoPredicate -> Maybe (Set AddressAny))
-> Maybe (Set AddressAny)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UtxoPredicate -> Maybe (Set AddressAny)
extractAddressesFromPredicate of
        Just Set AddressAny
addrs -> Set AddressAny -> QueryUTxOFilter
QueryUTxOByAddress Set AddressAny
addrs
        Maybe (Set AddressAny)
_ -> QueryUTxOFilter
QueryUTxOWhole

  nodeConnInfo <- m LocalNodeConnectInfo
forall field env (m :: * -> *).
(Has field env, MonadReader env m) =>
m field
grab
  AnyCardanoEra era <- liftIO . throwExceptT $ determineEra nodeConnInfo
  eon <- forEraInEon @Era era (error "Minimum Conway era required") pure

  let target = Target point
forall point. Target point
VolatileTip
  (utxo, chainPoint, blockNo, systemStart, eraHistory) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
    utxo <- throwEither =<< throwEither =<< queryUtxo (convert eon) utxoFilter
    chainPoint <- throwEither =<< queryChainPoint
    blockNo <- throwEither =<< queryChainBlockNo
    systemStart <- throwEither =<< querySystemStart
    eraHistory <- throwEither =<< queryEraHistory
    pure (utxo, chainPoint, blockNo, systemStart, eraHistory)

  timestamp <- slotToTimestamp systemStart eraHistory chainPoint

  obtainCommonConstraints eon $ do
    let filtered =
          ([(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)])
-> (UtxoPredicate
    -> [(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)])
-> Maybe UtxoPredicate
-> [(TxIn, TxOut CtxUTxO era)]
-> [(TxIn, TxOut CtxUTxO era)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)]
forall a. a -> a
id (\UtxoPredicate
p -> ((TxIn, TxOut CtxUTxO era) -> Bool)
-> [(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (((TxIn, TxOut CtxUTxO era) -> Bool)
 -> [(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)])
-> ((TxIn, TxOut CtxUTxO era) -> Bool)
-> [(TxIn, TxOut CtxUTxO era)]
-> [(TxIn, TxOut CtxUTxO era)]
forall a b. (a -> b) -> a -> b
$ UtxoPredicate -> TxOut CtxUTxO era -> Bool
forall era.
IsCardanoEra era =>
UtxoPredicate -> TxOut CtxUTxO era -> Bool
matchesUtxoPredicate UtxoPredicate
p (TxOut CtxUTxO era -> Bool)
-> ((TxIn, TxOut CtxUTxO era) -> TxOut CtxUTxO era)
-> (TxIn, TxOut CtxUTxO era)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO era) -> TxOut CtxUTxO era
forall a b. (a, b) -> b
snd) Maybe UtxoPredicate
mPredicate ([(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)])
-> [(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)]
forall a b. (a -> b) -> a -> b
$
            UTxO era -> [Item (UTxO era)]
forall l. IsList l => l -> [Item l]
toList UTxO era
utxo

    let (page, nextTok) = paginateByTxIn filtered startToken maxItems

    pure $
      defMessage
        & U5c.ledgerTip .~ mkChainPointMsg chainPoint blockNo timestamp
        & U5c.items .~ map (uncurry txInTxOutToAnyUtxoData) page
        & U5c.maybe'nextToken .~ nextTok

-- | Paginate a list of UTxO entries using cursor-based pagination.
-- Items are sorted by 'TxIn'\'s 'Ord' instance (lexicographic on 'TxId', then numeric on 'TxIx').
-- The start token is the 'renderTxIn' of the last item on the previous page;
-- all items up to and including it are skipped, so the next page begins
-- immediately after that cursor.
paginateByTxIn
  :: [(TxIn, a)]
  -- ^ UTxO entries to paginate
  -> Maybe Text
  -- ^ start token: the 'renderTxIn' of the last 'TxIn' from the previous page,
  -- or 'Nothing' for the first page
  -> Int32
  -- ^ maximum number of items per page (0 defaults to 'defaultPageSize',
  -- capped at 'maxPageSize')
  -> ([(TxIn, a)], Maybe Text)
  -- ^ page of results and the next start token ('Nothing' when there are no more pages)
paginateByTxIn :: forall a.
[(TxIn, a)] -> Maybe Text -> Int32 -> ([(TxIn, a)], Maybe Text)
paginateByTxIn [(TxIn, a)]
items Maybe Text
startToken Int32
maxItems = ([(TxIn, a)]
page, Maybe Text
nextToken)
 where
  sorted :: [(TxIn, a)]
sorted = ((TxIn, a) -> (TxIn, a) -> Ordering) -> [(TxIn, a)] -> [(TxIn, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (TxIn -> TxIn -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (TxIn -> TxIn -> Ordering)
-> ((TxIn, a) -> TxIn) -> (TxIn, a) -> (TxIn, a) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (TxIn, a) -> TxIn
forall a b. (a, b) -> a
fst) [(TxIn, a)]
items
  afterToken :: [(TxIn, a)]
afterToken = [(TxIn, a)] -> (TxIn -> [(TxIn, a)]) -> Maybe TxIn -> [(TxIn, a)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(TxIn, a)]
sorted TxIn -> [(TxIn, a)]
dropAfterCursor (Maybe TxIn -> [(TxIn, a)]) -> Maybe TxIn -> [(TxIn, a)]
forall a b. (a -> b) -> a -> b
$ Either [Char] TxIn -> Maybe TxIn
forall a b. Either a b -> Maybe b
hush (Either [Char] TxIn -> Maybe TxIn)
-> (Text -> Either [Char] TxIn) -> Text -> Maybe TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser TxIn -> Text -> Either [Char] TxIn
forall a. Parser a -> Text -> Either [Char] a
P.runParser Parser TxIn
parseTxIn (Text -> Maybe TxIn) -> Maybe Text -> Maybe TxIn
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
startToken
  dropAfterCursor :: TxIn -> [(TxIn, a)]
dropAfterCursor TxIn
cursor = ((TxIn, a) -> Bool) -> [(TxIn, a)] -> [(TxIn, a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(TxIn
txIn, a
_) -> TxIn
txIn TxIn -> TxIn -> Bool
forall a. Ord a => a -> a -> Bool
<= TxIn
cursor) [(TxIn, a)]
sorted
  limit :: Int
limit = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (if Int32
maxItems Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
0 then Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
maxItems else Int
defaultPageSize) Int
maxPageSize
  page :: [(TxIn, a)]
page = Int -> [(TxIn, a)] -> [(TxIn, a)]
forall a. Int -> [a] -> [a]
take Int
limit [(TxIn, a)]
afterToken
  hasMore :: Bool
hasMore = Bool -> Bool
not (Bool -> Bool) -> ([(TxIn, a)] -> Bool) -> [(TxIn, a)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, a)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(TxIn, a)] -> Bool) -> [(TxIn, a)] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [(TxIn, a)] -> [(TxIn, a)]
forall a. Int -> [a] -> [a]
drop Int
limit [(TxIn, a)]
afterToken
  nextToken :: Maybe Text
nextToken = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
hasMore
    Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text)
-> ((TxIn, a) -> Text) -> (TxIn, a) -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> Text
renderTxIn (TxIn -> Text) -> ((TxIn, a) -> TxIn) -> (TxIn, a) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, a) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, a) -> Maybe Text) -> (TxIn, a) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [(TxIn, a)] -> (TxIn, a)
forall a. HasCallStack => [a] -> a
last [(TxIn, a)]
page
  defaultPageSize :: Int
defaultPageSize = Int
100
  maxPageSize :: Int
maxPageSize = Int
10_000

slotToTimestamp
  :: HasCallStack
  => MonadIO m
  => SystemStart -> EraHistory -> ChainPoint -> m UTCTime
slotToTimestamp :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
SystemStart -> EraHistory -> ChainPoint -> m UTCTime
slotToTimestamp SystemStart
systemStart EraHistory
eraHistory = \case
  ChainPoint
ChainPointAtGenesis ->
    let SystemStart UTCTime
t = SystemStart
systemStart in UTCTime -> m UTCTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
t
  ChainPoint SlotNo
slotNo Hash BlockHeader
_ ->
    Either PastHorizonException UTCTime -> m UTCTime
forall e (m :: * -> *) a.
(Error e, HasCallStack, MonadIO m, Show e, Typeable e) =>
Either e a -> m a
throwEither (Either PastHorizonException UTCTime -> m UTCTime)
-> Either PastHorizonException UTCTime -> m UTCTime
forall a b. (a -> b) -> a -> b
$ SystemStart
-> EraHistory -> SlotNo -> Either PastHorizonException UTCTime
slotToUTCTime SystemStart
systemStart EraHistory
eraHistory SlotNo
slotNo