{-# 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
  , 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.List (sortBy)
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
      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)

-- | 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 mPredicate :: Maybe (Proto UtxoPredicate)
mPredicate = 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

  utxoFilter <- case Maybe (Proto UtxoPredicate)
mPredicate Maybe (Proto UtxoPredicate)
-> (Proto 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
>>= Proto UtxoPredicate -> Maybe (Set AddressAny)
extractAddressesFromPredicate of
    Just Set AddressAny
addrs -> QueryUTxOFilter -> m QueryUTxOFilter
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QueryUTxOFilter -> m QueryUTxOFilter)
-> QueryUTxOFilter -> m QueryUTxOFilter
forall a b. (a -> b) -> a -> b
$ Set AddressAny -> QueryUTxOFilter
QueryUTxOByAddress Set AddressAny
addrs
    Maybe (Set AddressAny)
Nothing ->
      GrpcError -> Text -> m 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 filtered =
          ([(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)])
-> (Proto UtxoPredicate
    -> [(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)])
-> Maybe (Proto 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 (\Proto 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
$ Proto UtxoPredicate -> TxOut CtxUTxO era -> Bool
forall era.
IsCardanoEra era =>
Proto UtxoPredicate -> TxOut CtxUTxO era -> Bool
matchesUtxoPredicate Proto 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 (Proto 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 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
    { genesisConfig =
      genesisBundle@GenesisBundle
        { shelleyGenesisHash
        , shelleyGenesis = (shelleyGenesisFile, shelleyGenesisCache)
        }
    } <-
    m NodeKernelAccess
forall e (m :: * -> *). MonadRpc e m => m NodeKernelAccess
grabNodeKernelAccess
  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

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