{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

import Cardano.Api
import Cardano.Api.Parser.Text qualified as P
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.Type

import RIO hiding (toList)

import Data.Default
import Data.ProtoLens (defMessage)
import Data.Text.Encoding qualified as T
import GHC.IsList
import Network.GRPC.Spec

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 (error "Minimum Conway era required") pure
  let sbe = ConwayEraOnwards era -> ShelleyBasedEra era
forall era. ConwayEraOnwards era -> ShelleyBasedEra era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert ConwayEraOnwards era
eon

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

  pure $
    def
      & #ledgerTip .~ mkChainPointMsg chainPoint blockNo
      & #values . #cardano .~ conwayEraOnwardsConstraints eon (inject pparams)

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
      | Just Proto TxoRefArray
txoRefs <- Proto ReadUtxosRequest
req Proto ReadUtxosRequest
-> Getting
     (Maybe (Proto TxoRefArray))
     (Proto ReadUtxosRequest)
     (Maybe (Proto TxoRefArray))
-> Maybe (Proto TxoRefArray)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Proto TxoRefArray))
  (Proto ReadUtxosRequest)
  (Maybe (Proto TxoRefArray))
#maybe'txoRefs ->
          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 TxoRefArray
txoRefs Proto TxoRefArray
-> Getting [Proto TxoRef] (Proto TxoRefArray) [Proto TxoRef]
-> [Proto TxoRef]
forall s a. s -> Getting a s a -> a
^. Getting [Proto TxoRef] (Proto TxoRefArray) [Proto TxoRef]
#items)
      | Just Proto AddressArray
addressesProto <- Proto ReadUtxosRequest
req Proto ReadUtxosRequest
-> Getting
     (Maybe (Proto AddressArray))
     (Proto ReadUtxosRequest)
     (Maybe (Proto AddressArray))
-> Maybe (Proto AddressArray)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Proto AddressArray))
  (Proto ReadUtxosRequest)
  (Maybe (Proto AddressArray))
#maybe'addresses ->
          Set AddressAny -> QueryUTxOFilter
QueryUTxOByAddress (Set AddressAny -> QueryUTxOFilter)
-> ([AddressAny] -> Set AddressAny)
-> [AddressAny]
-> QueryUTxOFilter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Item (Set AddressAny)] -> Set AddressAny
[AddressAny] -> Set AddressAny
forall l. IsList l => [Item l] -> l
fromList ([AddressAny] -> QueryUTxOFilter)
-> m [AddressAny] -> m QueryUTxOFilter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> m AddressAny) -> [ByteString] -> m [AddressAny]
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 ByteString -> m AddressAny
forall e (m :: * -> *). MonadRpc e m => ByteString -> m AddressAny
readAddress (Proto AddressArray
addressesProto Proto AddressArray
-> Getting [ByteString] (Proto AddressArray) [ByteString]
-> [ByteString]
forall s a. s -> Getting a s a -> a
^. Getting [ByteString] (Proto AddressArray) [ByteString]
#items)
      | Bool
otherwise -> 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 (error "Minimum Shelley era required") pure

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

  pure $
    defMessage
      & #ledgerTip .~ mkChainPointMsg chainPoint blockNo
      & #items .~ cardanoEraConstraints era (inject 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
#hash
    pure $ TxIn txId' (TxIx . fromIntegral $ r ^. #index)

  readAddress :: MonadRpc e m => ByteString -> m AddressAny
  readAddress :: forall e (m :: * -> *). MonadRpc e m => ByteString -> m AddressAny
readAddress =
    Either StringException AddressAny -> m AddressAny
forall e (m :: * -> *) a.
(Error e, HasCallStack, MonadIO m, Show e, Typeable e) =>
Either e a -> m a
throwEither (Either StringException AddressAny -> m AddressAny)
-> (Text -> Either StringException AddressAny)
-> Text
-> m AddressAny
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> StringException)
-> Either [Char] AddressAny -> Either StringException AddressAny
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first HasCallStack => [Char] -> StringException
[Char] -> StringException
stringException (Either [Char] AddressAny -> Either StringException AddressAny)
-> (Text -> Either [Char] AddressAny)
-> Text
-> Either StringException AddressAny
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser AddressAny -> Text -> Either [Char] AddressAny
forall a. Parser a -> Text -> Either [Char] a
P.runParser Parser AddressAny
forall addr. SerialiseAddress addr => Parser addr
parseAddressAny (Text -> m AddressAny)
-> (ByteString -> m Text) -> ByteString -> m AddressAny
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Either UnicodeException Text -> m Text
forall e (m :: * -> *) a.
(Error e, HasCallStack, MonadIO m, Show e, Typeable e) =>
Either e a -> m a
throwEither (Either UnicodeException Text -> m Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
T.decodeUtf8'