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

module Cardano.Rpc.Server.Internal.UtxoRpc.Query
  ( readParamsMethod
  , readUtxosMethod
  , searchUtxosMethod
  , readGenesisMethod
  , readEraSummaryMethod
  , 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.TimedCache (readThroughCache)
import Cardano.Rpc.Server.Internal.UtxoRpc.Predicate
import Cardano.Rpc.Server.Internal.UtxoRpc.Type
import Cardano.Rpc.Server.NodeKernelAccess

import Cardano.Crypto.Hash.Class qualified as Crypto (hashToBytes)
import Cardano.Ledger.Shelley.Genesis qualified as L (ShelleyGenesis, sgNetworkMagic)

import RIO hiding (toList)

import Control.Error.Util (hush)
import Data.Default
import Data.Map.Strict qualified as Map
import Data.ProtoLens (defMessage)
import Data.Text qualified as Text (pack)
import Data.Time.Clock (UTCTime)
import GHC.IsList
import Network.GRPC.Spec
import System.FS.API (MountPoint (..), SomeHasFS (..))
import System.FS.IO (ioHasFS)
import System.FilePath (takeDirectory)

-- | 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, chainBlockNo, systemStart, eraHistory) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
    pparams <- throwEither =<< throwEither =<< queryProtocolParameters sbe
    chainPoint <- throwEither =<< queryChainPoint
    chainBlockNo <- throwEither =<< queryChainBlockNo
    systemStart <- throwEither =<< querySystemStart
    eraHistory <- throwEither =<< queryEraHistory
    pure (pparams, chainPoint, chainBlockNo, systemStart, eraHistory)

  timestamp <- slotToTimestamp systemStart eraHistory chainPoint

  pure $
    def
      & U5c.ledgerTip .~ mkChainPointMsg chainPoint chainBlockNo 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.
-- Returns an empty response when no keys are provided, matching other
-- UTxO RPC implementations (Dolos, cardano-node-api, Dingo).
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
  | [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 = Proto ReadUtxosResponse -> m (Proto ReadUtxosResponse)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Proto ReadUtxosResponse
forall msg. Message msg => msg
defMessage
  | Bool
otherwise = do
      let keyCount :: Int
keyCount = [Proto TxoRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Proto TxoRef] -> Int) -> [Proto TxoRef] -> Int
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
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
keyCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxUtxoQueryKeys) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        GrpcError -> Text -> m ()
forall (m :: * -> *) a. MonadIO m => GrpcError -> Text -> m a
throwGrpcErrorWithMessage GrpcError
GrpcInvalidArgument (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
          Text
"too many keys: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
keyCount
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", maximum "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
maxUtxoQueryKeys
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; batch your requests"

      utxoFilter <- 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)

      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, chainBlockNo, systemStart, eraHistory) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
        utxo <- throwEither =<< throwEither =<< queryUtxo (convert eon) utxoFilter
        chainPoint <- throwEither =<< queryChainPoint
        chainBlockNo <- throwEither =<< queryChainBlockNo
        systemStart <- throwEither =<< querySystemStart
        eraHistory <- throwEither =<< queryEraHistory
        pure (utxo, chainPoint, chainBlockNo, systemStart, eraHistory)

      timestamp <- slotToTimestamp systemStart eraHistory chainPoint

      pure $
        defMessage
          & U5c.ledgerTip .~ mkChainPointMsg chainPoint chainBlockNo 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)

-- | Bounds per-request UTxO lookups the node performs: ReadUtxos keys and
-- SearchUtxos predicate address terms. SearchUtxos pagination caps at 10_000 per page.
maxUtxoQueryKeys :: Int
maxUtxoQueryKeys :: Int
maxUtxoQueryKeys = Int
20_000

-- | Handle the @SearchUtxos@ RPC method.
-- Filters the UTxO set by a predicate and returns a paginated result.
-- The predicate must contain exact address matches so the query can be
-- narrowed; broad predicates are rejected with @INVALID_ARGUMENT@.
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 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

  (compiledPredicate, utxoFilter) <- case 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 of
    Just Proto UtxoPredicate
p
      -- Counted on raw terms: repeated addresses would dodge a distinct-address
      -- cap, and compiling/merging the predicate still costs one step per term.
      | Bool -> Bool
not (Bool -> Bool)
-> ([Proto AnyUtxoPattern] -> Bool)
-> [Proto AnyUtxoPattern]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Proto AnyUtxoPattern] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Proto AnyUtxoPattern] -> Bool)
-> ([Proto AnyUtxoPattern] -> [Proto AnyUtxoPattern])
-> [Proto AnyUtxoPattern]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Proto AnyUtxoPattern] -> [Proto AnyUtxoPattern]
forall a. Int -> [a] -> [a]
drop Int
maxUtxoQueryKeys ([Proto AnyUtxoPattern] -> Bool) -> [Proto AnyUtxoPattern] -> Bool
forall a b. (a -> b) -> a -> b
$ Proto UtxoPredicate -> [Proto AnyUtxoPattern]
predicateLeaves Proto UtxoPredicate
p ->
          GrpcError -> Text -> m (CompiledUtxoPredicate, QueryUTxOFilter)
forall (m :: * -> *) a. MonadIO m => GrpcError -> Text -> m a
throwGrpcErrorWithMessage GrpcError
GrpcInvalidArgument (Text -> m (CompiledUtxoPredicate, QueryUTxOFilter))
-> Text -> m (CompiledUtxoPredicate, QueryUTxOFilter)
forall a b. (a -> b) -> a -> b
$
            Text
"predicate names more than "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
maxUtxoQueryKeys
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" address terms (repeated addresses count); batch your requests"
      | Just CompiledUtxoPredicate
compiled <- Proto UtxoPredicate -> Maybe CompiledUtxoPredicate
compileUtxoPredicate Proto UtxoPredicate
p ->
          (CompiledUtxoPredicate, QueryUTxOFilter)
-> m (CompiledUtxoPredicate, QueryUTxOFilter)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompiledUtxoPredicate
compiled, Set AddressAny -> QueryUTxOFilter
QueryUTxOByAddress (Set AddressAny -> QueryUTxOFilter)
-> Set AddressAny -> QueryUTxOFilter
forall a b. (a -> b) -> a -> b
$ CompiledUtxoPredicate -> Set AddressAny
compiledPredicateAddresses CompiledUtxoPredicate
compiled)
    Maybe (Proto UtxoPredicate)
_ ->
      GrpcError -> Text -> m (CompiledUtxoPredicate, QueryUTxOFilter)
forall (m :: * -> *) a. MonadIO m => GrpcError -> Text -> m a
throwGrpcErrorWithMessage
        GrpcError
GrpcInvalidArgument
        Text
"predicate too broad: must contain exact address match to avoid fetching the entire UTxO set"

  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, chainBlockNo, systemStart, eraHistory) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
    utxo <- throwEither =<< throwEither =<< queryUtxo (convert eon) utxoFilter
    chainPoint <- throwEither =<< queryChainPoint
    chainBlockNo <- throwEither =<< queryChainBlockNo
    systemStart <- throwEither =<< querySystemStart
    eraHistory <- throwEither =<< queryEraHistory
    pure (utxo, chainPoint, chainBlockNo, systemStart, eraHistory)

  timestamp <- slotToTimestamp systemStart eraHistory chainPoint

  obtainCommonConstraints eon $ do
    let (page, nextTok) =
          paginateByTxIn (matchesCompiledPredicate compiledPredicate) (unUTxO utxo) startToken maxItems

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

-- | Handle the @ReadGenesis@ RPC method.
-- Returns the chain's identity - the Shelley genesis hash and the CAIP-2 chain
-- identifier - together with the @cardano@ config, the Byron, Shelley, Alonzo
-- and Conway genesis parameters mapped by 'genesisBundleToProto'.
--
-- The whole Shelley genesis comes from the bundle's cache, so the file is only
-- read on a cache miss. The @FAILED_PRECONDITION@ that
-- 'readShelleyGenesisWithInitialFunds' raises for a genesis file that has
-- changed since the node started is therefore raised on cache misses only: a
-- file edited while the cache is warm goes unnoticed until the cache next
-- empties, which is at most five idle minutes later.
readGenesisMethod
  :: MonadRpc e m
  => Proto UtxoRpc.ReadGenesisRequest
  -> m (Proto UtxoRpc.ReadGenesisResponse)
readGenesisMethod :: forall e (m :: * -> *).
MonadRpc e m =>
Proto ReadGenesisRequest -> m (Proto ReadGenesisResponse)
readGenesisMethod Proto ReadGenesisRequest
_req = do
  -- TODO: field masks are ignored for now (same as readParamsMethod)
  nodeKernelAccess <- m NodeKernelAccess
forall e (m :: * -> *). MonadRpc e m => m NodeKernelAccess
grabNodeKernelAccess
  let genesisBundle@GenesisBundle
        { shelleyGenesisHash
        , shelleyGenesis = (shelleyGenesisFile, shelleyGenesisCache)
        } = genesisConfig nodeKernelAccess
  shelleyGenesis <-
    readThroughCache shelleyGenesisCache $
      readShelleyGenesisWithInitialFunds shelleyGenesisFile shelleyGenesisHash
  pure $
    defMessage
      & U5c.genesis .~ Crypto.hashToBytes (unGenesisHashShelley shelleyGenesisHash)
      & U5c.caip2 .~ networkMagicToCaip2 (L.sgNetworkMagic shelleyGenesis)
      & U5c.cardano .~ genesisBundleToProto genesisBundle shelleyGenesis

-- | Re-read the Shelley genesis file to recover the network's initial funds.
--
-- The genesis consensus keeps in memory is compacted, with the initial funds
-- erased, so the file is the only place they can come from.
readShelleyGenesisWithInitialFunds
  :: forall e m
   . MonadRpc e m
  => ShelleyGenesisFile In
  -- ^ Path to the Shelley genesis file, as the node was configured with it
  -> GenesisHashShelley
  -- ^ Blake2b-256 hash the node computed over that file at startup
  -> m L.ShelleyGenesis
readShelleyGenesisWithInitialFunds :: forall e (m :: * -> *).
MonadRpc e m =>
ShelleyGenesisFile 'In -> GenesisHashShelley -> m ShelleyGenesis
readShelleyGenesisWithInitialFunds shelleyGenesisFile :: ShelleyGenesisFile 'In
shelleyGenesisFile@(File [Char]
path) GenesisHashShelley
bootGenesisHash = do
  -- 'readShelleyGenesis' is the node's own boot-time path: it reads the bytes,
  -- hashes them and checks them against the hash we pass in, then decodes.
  -- Running it at IO because its 'MonadIOTransError' needs a 'MonadCatch' that
  -- 'MonadRpc' does not provide.
  ShelleyConfig bootGenesis _ <-
    (ShelleyGenesisError -> m ShelleyConfig)
-> (ShelleyConfig -> m ShelleyConfig)
-> Either ShelleyGenesisError ShelleyConfig
-> m ShelleyConfig
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ShelleyGenesisError -> m ShelleyConfig
forall a. ShelleyGenesisError -> m a
rejectGenesisFile ShelleyConfig -> m ShelleyConfig
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Either ShelleyGenesisError ShelleyConfig -> m ShelleyConfig)
-> m (Either ShelleyGenesisError ShelleyConfig) -> m ShelleyConfig
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either ShelleyGenesisError ShelleyConfig)
-> m (Either ShelleyGenesisError ShelleyConfig)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExceptT ShelleyGenesisError IO ShelleyConfig
-> IO (Either ShelleyGenesisError ShelleyConfig)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ShelleyGenesisFile 'In
-> Maybe GenesisHashShelley
-> ExceptT ShelleyGenesisError IO ShelleyConfig
forall (m :: * -> *) (t :: (* -> *) -> * -> *).
MonadIOTransError ShelleyGenesisError t m =>
ShelleyGenesisFile 'In
-> Maybe GenesisHashShelley -> t m ShelleyConfig
readShelleyGenesis ShelleyGenesisFile 'In
shelleyGenesisFile (GenesisHashShelley -> Maybe GenesisHashShelley
forall a. a -> Maybe a
Just GenesisHashShelley
bootGenesisHash)))
  -- An injection file is named relative to the genesis file's own directory,
  -- which is where consensus mounts it when it injects the funds itself.
  let genesisDirectory = HasFS IO HandleIO -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS IO HandleIO -> SomeHasFS IO)
-> ([Char] -> HasFS IO HandleIO) -> [Char] -> SomeHasFS IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> HasFS IO HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS (MountPoint -> HasFS IO HandleIO)
-> ([Char] -> MountPoint) -> [Char] -> HasFS IO HandleIO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> MountPoint
MountPoint ([Char] -> SomeHasFS IO) -> [Char] -> SomeHasFS IO
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
takeDirectory [Char]
path
  either (rejectInitialFunds . displayException) pure
    =<< tryAny (liftIO $ resolveShelleyInitialFunds genesisDirectory bootGenesis)
 where
  -- Both helpers carry explicit signatures because their result type is
  -- polymorphic, which MonoLocalBinds would otherwise refuse to generalise on
  -- GHC 9.6 and 9.10.
  rejectGenesisFile :: ShelleyGenesisError -> m a
  rejectGenesisFile :: forall a. ShelleyGenesisError -> m a
rejectGenesisFile = \case
    -- Deliberately not 'renderShelleyGenesisError' for this one: its wording
    -- blames the hash given in the node's configuration file, whereas the hash
    -- we compare against is the one the node itself computed at startup.
    ShelleyGenesisHashMismatch{} ->
      GrpcError -> Text -> m a
forall (m :: * -> *) a. MonadIO m => GrpcError -> Text -> m a
throwGrpcErrorWithMessage GrpcError
GrpcFailedPrecondition (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$
        Text
"The Shelley genesis file "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
tshow [Char]
path
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has changed since the node started, so it no longer describes the genesis the node is running on."
    ShelleyGenesisError
err -> GrpcError -> Text -> m a
forall (m :: * -> *) a. MonadIO m => GrpcError -> Text -> m a
throwGrpcErrorWithMessage GrpcError
GrpcInternal (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ ShelleyGenesisError -> Text
renderShelleyGenesisError ShelleyGenesisError
err

  rejectInitialFunds :: String -> m a
  rejectInitialFunds :: forall a. [Char] -> m a
rejectInitialFunds [Char]
reason =
    GrpcError -> Text -> m a
forall (m :: * -> *) a. MonadIO m => GrpcError -> Text -> m a
throwGrpcErrorWithMessage GrpcError
GrpcInternal (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$
      Text
"Cannot resolve the initial funds of the Shelley genesis file "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
tshow [Char]
path
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
reason

-- | Handle the @ReadEraSummary@ RPC method.
-- Returns the node's hard-fork era summary: one entry per era the node's
-- ledger state has seen so far, with name and start/end boundaries. See
-- 'eraSummariesToProto' for exactly which fields are populated.
readEraSummaryMethod
  :: MonadRpc e m
  => Proto UtxoRpc.ReadEraSummaryRequest
  -> m (Proto UtxoRpc.ReadEraSummaryResponse)
readEraSummaryMethod :: forall e (m :: * -> *).
MonadRpc e m =>
Proto ReadEraSummaryRequest -> m (Proto ReadEraSummaryResponse)
readEraSummaryMethod Proto ReadEraSummaryRequest
_req = do
  -- TODO: field masks are ignored for now (same as readParamsMethod)
  nodeKernelAccess <- m NodeKernelAccess
forall e (m :: * -> *). MonadRpc e m => m NodeKernelAccess
grabNodeKernelAccess
  summary <- readHardForkSummary nodeKernelAccess
  pure $
    defMessage & U5c.cardano .~ eraSummariesToProto (nodeKernelSystemStart nodeKernelAccess) summary

-- | The CAIP-2 chain identifier for a Cardano network, keyed on the Shelley
-- network magic.
-- This follows Dolos, the reference UTxO RPC implementation: the three
-- well-known networks get their conventional names, and any other network is
-- identified by its magic.
networkMagicToCaip2 :: Word32 -> Text
networkMagicToCaip2 :: Word32 -> Text
networkMagicToCaip2 = \case
  Word32
764824073 -> Text
"cardano:mainnet"
  Word32
1 -> Text
"cardano:preprod"
  Word32
2 -> Text
"cardano:preview"
  Word32
magic -> Text
"cardano:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word32 -> Text
forall a. Show a => a -> Text
tshow Word32
magic

-- | Paginate a 'Map' of UTxO entries using cursor-based pagination.
-- The map is already ordered by 'TxIn'\'s 'Ord' instance (lexicographic on 'TxId', then numeric
-- on 'TxIx'), so no sort is needed.
-- 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
  :: (a -> Bool)
  -- ^ keep only entries whose value satisfies the predicate
  -> Map TxIn a
  -- ^ UTxO entries to paginate, in the map's key order
  -> 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.
(a -> Bool)
-> Map TxIn a -> Maybe Text -> Int32 -> ([(TxIn, a)], Maybe Text)
paginateByTxIn a -> Bool
keep Map TxIn a
items Maybe Text
startToken Int32
maxItems = ([(TxIn, a)]
page, Maybe Text
nextToken)
 where
  -- 'Map.split' excludes the cursor key itself.
  afterCursor :: Map TxIn a
afterCursor =
    Map TxIn a -> (TxIn -> Map TxIn a) -> Maybe TxIn -> Map TxIn a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map TxIn a
items (\TxIn
cursor -> (Map TxIn a, Map TxIn a) -> Map TxIn a
forall a b. (a, b) -> b
snd ((Map TxIn a, Map TxIn a) -> Map TxIn a)
-> (Map TxIn a, Map TxIn a) -> Map TxIn a
forall a b. (a -> b) -> a -> b
$ TxIn -> Map TxIn a -> (Map TxIn a, Map TxIn a)
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split TxIn
cursor Map TxIn a
items) (Maybe TxIn -> Map TxIn a) -> Maybe TxIn -> Map 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
  -- Lazy: 'take'/'drop' below force only the page plus one match.
  matching :: [(TxIn, a)]
matching = ((TxIn, a) -> Bool) -> [(TxIn, a)] -> [(TxIn, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Bool
keep (a -> Bool) -> ((TxIn, a) -> a) -> (TxIn, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, a) -> a
forall a b. (a, b) -> b
snd) ([(TxIn, a)] -> [(TxIn, a)]) -> [(TxIn, a)] -> [(TxIn, a)]
forall a b. (a -> b) -> a -> b
$ Map TxIn a -> [(TxIn, a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map TxIn a
afterCursor
  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)]
matching
  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)]
matching
  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