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

module Cardano.Rpc.Server
  ( runRpcServer

    -- * Traces
  , TraceRpc (..)
  , TraceRpcSubmit (..)
  , TraceRpcQuery (..)
  , TraceSpanEvent (..)
  )
where

import Cardano.Api
import Cardano.Rpc.Proto.Api.Node qualified as Rpc
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
import Cardano.Rpc.Proto.Api.UtxoRpc.Submit qualified as UtxoRpc
import Cardano.Rpc.Server.Config
import Cardano.Rpc.Server.Internal.Env
import Cardano.Rpc.Server.Internal.Monad
import Cardano.Rpc.Server.Internal.Node
import Cardano.Rpc.Server.Internal.Orphans ()
import Cardano.Rpc.Server.Internal.Tracing
import Cardano.Rpc.Server.Internal.UtxoRpc.Query
import Cardano.Rpc.Server.Internal.UtxoRpc.Submit

import RIO

import Control.Tracer
import Network.GRPC.Common
import Network.GRPC.Server
import Network.GRPC.Server.Protobuf
import Network.GRPC.Server.Run
import Network.GRPC.Server.StreamType

-- Server top level
methodsNodeRpc
  :: MonadRpc e m
  => Methods m (ProtobufMethodsOf Rpc.Node)
methodsNodeRpc :: forall e (m :: * -> *).
MonadRpc e m =>
Methods m (ProtobufMethodsOf Node)
methodsNodeRpc =
  ServerHandler' 'NonStreaming m (Protobuf Node "getEra")
-> Methods m '[Protobuf Node "getProtocolParamsJson"]
-> Methods
     m '[Protobuf Node "getEra", Protobuf Node "getProtocolParamsJson"]
forall {k} (rpc :: k) (styp :: StreamingType) (m :: * -> *)
       (rpcs1 :: [k]).
(SupportsServerRpc rpc, Default (ResponseInitialMetadata rpc),
 Default (ResponseTrailingMetadata rpc),
 SupportsStreamingType rpc styp) =>
ServerHandler' styp m rpc
-> Methods m rpcs1 -> Methods m (rpc : rpcs1)
Method ((Input (Protobuf Node "getEra")
 -> m (Output (Protobuf Node "getEra")))
-> ServerHandler' 'NonStreaming m (Protobuf Node "getEra")
forall {k} (rpc :: k) (m :: * -> *).
SupportsStreamingType rpc 'NonStreaming =>
(Input rpc -> m (Output rpc)) -> ServerHandler' 'NonStreaming m rpc
mkNonStreaming Input (Protobuf Node "getEra")
-> m (Output (Protobuf Node "getEra"))
Proto Empty -> m (Proto CurrentEra)
forall e (m :: * -> *).
MonadRpc e m =>
Proto Empty -> m (Proto CurrentEra)
getEraMethod)
    (Methods m '[Protobuf Node "getProtocolParamsJson"]
 -> Methods m (ProtobufMethodsOf Node))
-> (Methods m '[]
    -> Methods m '[Protobuf Node "getProtocolParamsJson"])
-> Methods m '[]
-> Methods m (ProtobufMethodsOf Node)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerHandler'
  'NonStreaming m (Protobuf Node "getProtocolParamsJson")
-> Methods m '[]
-> Methods m '[Protobuf Node "getProtocolParamsJson"]
forall {k} (rpc :: k) (styp :: StreamingType) (m :: * -> *)
       (rpcs1 :: [k]).
(SupportsServerRpc rpc, Default (ResponseInitialMetadata rpc),
 Default (ResponseTrailingMetadata rpc),
 SupportsStreamingType rpc styp) =>
ServerHandler' styp m rpc
-> Methods m rpcs1 -> Methods m (rpc : rpcs1)
Method ((Input (Protobuf Node "getProtocolParamsJson")
 -> m (Output (Protobuf Node "getProtocolParamsJson")))
-> ServerHandler'
     'NonStreaming m (Protobuf Node "getProtocolParamsJson")
forall {k} (rpc :: k) (m :: * -> *).
SupportsStreamingType rpc 'NonStreaming =>
(Input rpc -> m (Output rpc)) -> ServerHandler' 'NonStreaming m rpc
mkNonStreaming Input (Protobuf Node "getProtocolParamsJson")
-> m (Output (Protobuf Node "getProtocolParamsJson"))
Proto Empty -> m (Proto ProtocolParamsJson)
forall e (m :: * -> *).
MonadRpc e m =>
Proto Empty -> m (Proto ProtocolParamsJson)
getProtocolParamsJsonMethod)
    (Methods m '[] -> Methods m (ProtobufMethodsOf Node))
-> Methods m '[] -> Methods m (ProtobufMethodsOf Node)
forall a b. (a -> b) -> a -> b
$ Methods m '[]
forall {k} (m :: * -> *). Methods m '[]
NoMoreMethods

methodsUtxoRpc
  :: MonadRpc e m
  => Methods m (ProtobufMethodsOf UtxoRpc.QueryService)
methodsUtxoRpc :: forall e (m :: * -> *).
MonadRpc e m =>
Methods m (ProtobufMethodsOf QueryService)
methodsUtxoRpc =
  ServerHandler' 'NonStreaming m (Protobuf QueryService "readParams")
-> Methods m '[Protobuf QueryService "readUtxos"]
-> Methods
     m
     '[Protobuf QueryService "readParams",
       Protobuf QueryService "readUtxos"]
forall {k} (rpc :: k) (styp :: StreamingType) (m :: * -> *)
       (rpcs1 :: [k]).
(SupportsServerRpc rpc, Default (ResponseInitialMetadata rpc),
 Default (ResponseTrailingMetadata rpc),
 SupportsStreamingType rpc styp) =>
ServerHandler' styp m rpc
-> Methods m rpcs1 -> Methods m (rpc : rpcs1)
Method ((Input (Protobuf QueryService "readParams")
 -> m (Output (Protobuf QueryService "readParams")))
-> ServerHandler'
     'NonStreaming m (Protobuf QueryService "readParams")
forall {k} (rpc :: k) (m :: * -> *).
SupportsStreamingType rpc 'NonStreaming =>
(Input rpc -> m (Output rpc)) -> ServerHandler' 'NonStreaming m rpc
mkNonStreaming ((Input (Protobuf QueryService "readParams")
  -> m (Output (Protobuf QueryService "readParams")))
 -> ServerHandler'
      'NonStreaming m (Protobuf QueryService "readParams"))
-> (Input (Protobuf QueryService "readParams")
    -> m (Output (Protobuf QueryService "readParams")))
-> ServerHandler'
     'NonStreaming m (Protobuf QueryService "readParams")
forall a b. (a -> b) -> a -> b
$ (TraceSpanEvent -> TraceRpcQuery)
-> m (Proto ReadParamsResponse) -> m (Proto ReadParamsResponse)
forall t' t e (m :: * -> *) a.
(t ~ TraceRpc, Inject t' t, NFData a, Has (Tracer m t) e,
 MonadReader e m, MonadUnliftIO m) =>
(TraceSpanEvent -> t') -> m a -> m a
wrapInSpan TraceSpanEvent -> TraceRpcQuery
TraceRpcQueryParamsSpan (m (Proto ReadParamsResponse) -> m (Proto ReadParamsResponse))
-> (Proto ReadParamsRequest -> m (Proto ReadParamsResponse))
-> Proto ReadParamsRequest
-> m (Proto ReadParamsResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proto ReadParamsRequest -> m (Proto ReadParamsResponse)
forall e (m :: * -> *).
MonadRpc e m =>
Proto ReadParamsRequest -> m (Proto ReadParamsResponse)
readParamsMethod)
    (Methods m '[Protobuf QueryService "readUtxos"]
 -> Methods m (ProtobufMethodsOf QueryService))
-> (Methods m '[]
    -> Methods m '[Protobuf QueryService "readUtxos"])
-> Methods m '[]
-> Methods m (ProtobufMethodsOf QueryService)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerHandler' 'NonStreaming m (Protobuf QueryService "readUtxos")
-> Methods m '[] -> Methods m '[Protobuf QueryService "readUtxos"]
forall {k} (rpc :: k) (styp :: StreamingType) (m :: * -> *)
       (rpcs1 :: [k]).
(SupportsServerRpc rpc, Default (ResponseInitialMetadata rpc),
 Default (ResponseTrailingMetadata rpc),
 SupportsStreamingType rpc styp) =>
ServerHandler' styp m rpc
-> Methods m rpcs1 -> Methods m (rpc : rpcs1)
Method ((Input (Protobuf QueryService "readUtxos")
 -> m (Output (Protobuf QueryService "readUtxos")))
-> ServerHandler'
     'NonStreaming m (Protobuf QueryService "readUtxos")
forall {k} (rpc :: k) (m :: * -> *).
SupportsStreamingType rpc 'NonStreaming =>
(Input rpc -> m (Output rpc)) -> ServerHandler' 'NonStreaming m rpc
mkNonStreaming ((Input (Protobuf QueryService "readUtxos")
  -> m (Output (Protobuf QueryService "readUtxos")))
 -> ServerHandler'
      'NonStreaming m (Protobuf QueryService "readUtxos"))
-> (Input (Protobuf QueryService "readUtxos")
    -> m (Output (Protobuf QueryService "readUtxos")))
-> ServerHandler'
     'NonStreaming m (Protobuf QueryService "readUtxos")
forall a b. (a -> b) -> a -> b
$ (TraceSpanEvent -> TraceRpcQuery)
-> m (Proto ReadUtxosResponse) -> m (Proto ReadUtxosResponse)
forall t' t e (m :: * -> *) a.
(t ~ TraceRpc, Inject t' t, NFData a, Has (Tracer m t) e,
 MonadReader e m, MonadUnliftIO m) =>
(TraceSpanEvent -> t') -> m a -> m a
wrapInSpan TraceSpanEvent -> TraceRpcQuery
TraceRpcQueryReadUtxosSpan (m (Proto ReadUtxosResponse) -> m (Proto ReadUtxosResponse))
-> (Proto ReadUtxosRequest -> m (Proto ReadUtxosResponse))
-> Proto ReadUtxosRequest
-> m (Proto ReadUtxosResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proto ReadUtxosRequest -> m (Proto ReadUtxosResponse)
forall e (m :: * -> *).
MonadRpc e m =>
Proto ReadUtxosRequest -> m (Proto ReadUtxosResponse)
readUtxosMethod)
    (Methods m '[] -> Methods m (ProtobufMethodsOf QueryService))
-> Methods m '[] -> Methods m (ProtobufMethodsOf QueryService)
forall a b. (a -> b) -> a -> b
$ Methods m '[]
forall {k} (m :: * -> *). Methods m '[]
NoMoreMethods

methodsUtxoRpcSubmit
  :: MonadRpc e m
  => Methods m (ProtobufMethodsOf UtxoRpc.SubmitService)
methodsUtxoRpcSubmit :: forall e (m :: * -> *).
MonadRpc e m =>
Methods m (ProtobufMethodsOf SubmitService)
methodsUtxoRpcSubmit =
  ServerHandler' 'NonStreaming m (Protobuf SubmitService "submitTx")
-> Methods m '[] -> Methods m '[Protobuf SubmitService "submitTx"]
forall {k} (rpc :: k) (styp :: StreamingType) (m :: * -> *)
       (rpcs1 :: [k]).
(SupportsServerRpc rpc, Default (ResponseInitialMetadata rpc),
 Default (ResponseTrailingMetadata rpc),
 SupportsStreamingType rpc styp) =>
ServerHandler' styp m rpc
-> Methods m rpcs1 -> Methods m (rpc : rpcs1)
Method ((Input (Protobuf SubmitService "submitTx")
 -> m (Output (Protobuf SubmitService "submitTx")))
-> ServerHandler'
     'NonStreaming m (Protobuf SubmitService "submitTx")
forall {k} (rpc :: k) (m :: * -> *).
SupportsStreamingType rpc 'NonStreaming =>
(Input rpc -> m (Output rpc)) -> ServerHandler' 'NonStreaming m rpc
mkNonStreaming ((Input (Protobuf SubmitService "submitTx")
  -> m (Output (Protobuf SubmitService "submitTx")))
 -> ServerHandler'
      'NonStreaming m (Protobuf SubmitService "submitTx"))
-> (Input (Protobuf SubmitService "submitTx")
    -> m (Output (Protobuf SubmitService "submitTx")))
-> ServerHandler'
     'NonStreaming m (Protobuf SubmitService "submitTx")
forall a b. (a -> b) -> a -> b
$ (TraceSpanEvent -> TraceRpcSubmit)
-> m (Proto SubmitTxResponse) -> m (Proto SubmitTxResponse)
forall t' t e (m :: * -> *) a.
(t ~ TraceRpc, Inject t' t, NFData a, Has (Tracer m t) e,
 MonadReader e m, MonadUnliftIO m) =>
(TraceSpanEvent -> t') -> m a -> m a
wrapInSpan TraceSpanEvent -> TraceRpcSubmit
TraceRpcSubmitSpan (m (Proto SubmitTxResponse) -> m (Proto SubmitTxResponse))
-> (Proto SubmitTxRequest -> m (Proto SubmitTxResponse))
-> Proto SubmitTxRequest
-> m (Proto SubmitTxResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proto SubmitTxRequest -> m (Proto SubmitTxResponse)
forall e (m :: * -> *).
MonadRpc e m =>
Proto SubmitTxRequest -> m (Proto SubmitTxResponse)
submitTxMethod) Methods m '[]
forall {k} (m :: * -> *). Methods m '[]
NoMoreMethods

runRpcServer
  :: Tracer IO TraceRpc
  -> IO (RpcConfig, NetworkMagic)
  -- ^ action which reloads RPC configuration
  -> IO ()
runRpcServer :: Tracer IO TraceRpc -> IO (RpcConfig, NetworkMagic) -> IO ()
runRpcServer Tracer IO TraceRpc
tracer IO (RpcConfig, NetworkMagic)
loadRpcConfig = (HasCallStack => IO ()) -> IO ()
handleFatalExceptions ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  ( rpcConfig@RpcConfig
      { isEnabled = Identity isEnabled
      , rpcSocketPath = Identity (File rpcSocketPathFp)
      , nodeSocketPath = Identity nodeSocketPath
      }
    , networkMagic
    ) <-
    IO (RpcConfig, NetworkMagic)
loadRpcConfig
  let config =
        ServerConfig
          { serverInsecure :: Maybe InsecureConfig
serverInsecure = InsecureConfig -> Maybe InsecureConfig
forall a. a -> Maybe a
Just (InsecureConfig -> Maybe InsecureConfig)
-> InsecureConfig -> Maybe InsecureConfig
forall a b. (a -> b) -> a -> b
$ FilePath -> InsecureConfig
InsecureUnix FilePath
rpcSocketPathFp
          , serverSecure :: Maybe SecureConfig
serverSecure = Maybe SecureConfig
forall a. Maybe a
Nothing
          }
      rpcEnv =
        RpcEnv
          { config :: RpcConfig
config = RpcConfig
rpcConfig
          , tracer :: forall (m :: * -> *). MonadIO m => Tracer m TraceRpc
tracer = (forall x. IO x -> m x) -> Tracer IO TraceRpc -> Tracer m TraceRpc
forall (m :: * -> *) (n :: * -> *) s.
(forall x. m x -> n x) -> Tracer m s -> Tracer n s
natTracer IO x -> m x
forall x. IO x -> m x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Tracer IO TraceRpc
tracer
          , rpcLocalNodeConnectInfo :: LocalNodeConnectInfo
rpcLocalNodeConnectInfo = SocketPath -> NetworkMagic -> LocalNodeConnectInfo
mkLocalNodeConnectInfo SocketPath
nodeSocketPath NetworkMagic
networkMagic
          }

  -- TODO this is logged by node configuration already, so it would make sense to log it again when
  -- configuration gets reloaded
  -- traceWith tracer $ "RPC configuration: " <> show rpcConfig

  when isEnabled $
    runRIO rpcEnv $
      withRunInIO $ \forall a. RIO RpcEnv a -> IO a
runInIO ->
        ServerParams -> ServerConfig -> [SomeRpcHandler IO] -> IO ()
runServerWithHandlers ServerParams
serverParams ServerConfig
config ([SomeRpcHandler IO] -> IO ())
-> ([SomeRpcHandler (RIO RpcEnv)] -> [SomeRpcHandler IO])
-> [SomeRpcHandler (RIO RpcEnv)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeRpcHandler (RIO RpcEnv) -> SomeRpcHandler IO)
-> [SomeRpcHandler (RIO RpcEnv)] -> [SomeRpcHandler IO]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. RIO RpcEnv a -> IO a)
-> SomeRpcHandler (RIO RpcEnv) -> SomeRpcHandler IO
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> SomeRpcHandler m -> SomeRpcHandler n
hoistSomeRpcHandler RIO RpcEnv a -> IO a
forall a. RIO RpcEnv a -> IO a
runInIO) ([SomeRpcHandler (RIO RpcEnv)] -> IO ())
-> [SomeRpcHandler (RIO RpcEnv)] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [[SomeRpcHandler (RIO RpcEnv)]] -> [SomeRpcHandler (RIO RpcEnv)]
forall a. Monoid a => [a] -> a
mconcat
            [ Methods
  (RIO RpcEnv)
  '[Protobuf Node "getEra", Protobuf Node "getProtocolParamsJson"]
-> [SomeRpcHandler (RIO RpcEnv)]
forall {k} (m :: * -> *) (rpcs :: [k]).
MonadIO m =>
Methods m rpcs -> [SomeRpcHandler m]
fromMethods Methods
  (RIO RpcEnv)
  '[Protobuf Node "getEra", Protobuf Node "getProtocolParamsJson"]
Methods (RIO RpcEnv) (ProtobufMethodsOf Node)
forall e (m :: * -> *).
MonadRpc e m =>
Methods m (ProtobufMethodsOf Node)
methodsNodeRpc
            , Methods
  (RIO RpcEnv)
  '[Protobuf QueryService "readParams",
    Protobuf QueryService "readUtxos"]
-> [SomeRpcHandler (RIO RpcEnv)]
forall {k} (m :: * -> *) (rpcs :: [k]).
MonadIO m =>
Methods m rpcs -> [SomeRpcHandler m]
fromMethods Methods
  (RIO RpcEnv)
  '[Protobuf QueryService "readParams",
    Protobuf QueryService "readUtxos"]
Methods (RIO RpcEnv) (ProtobufMethodsOf QueryService)
forall e (m :: * -> *).
MonadRpc e m =>
Methods m (ProtobufMethodsOf QueryService)
methodsUtxoRpc
            , Methods (RIO RpcEnv) '[Protobuf SubmitService "submitTx"]
-> [SomeRpcHandler (RIO RpcEnv)]
forall {k} (m :: * -> *) (rpcs :: [k]).
MonadIO m =>
Methods m rpcs -> [SomeRpcHandler m]
fromMethods Methods (RIO RpcEnv) '[Protobuf SubmitService "submitTx"]
Methods (RIO RpcEnv) (ProtobufMethodsOf SubmitService)
forall e (m :: * -> *).
MonadRpc e m =>
Methods m (ProtobufMethodsOf SubmitService)
methodsUtxoRpcSubmit
            ]
 where
  serverParams :: ServerParams
  serverParams :: ServerParams
serverParams = ServerParams
forall a. Default a => a
def{serverTopLevel = topLevelHandler}

  -- Top level hook for request handlers, handle exceptions
  topLevelHandler :: RequestHandler () -> RequestHandler ()
  topLevelHandler :: RequestHandler () -> RequestHandler ()
topLevelHandler RequestHandler ()
h forall x. IO x -> IO x
unmask Request
req Response -> IO ()
resp = IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny (RequestHandler ()
h IO x -> IO x
forall x. IO x -> IO x
unmask Request
req Response -> IO ()
resp) ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeException
e ->
    Tracer IO TraceRpc -> TraceRpc -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TraceRpc
tracer (TraceRpc -> IO ()) -> TraceRpc -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> TraceRpc
TraceRpcError SomeException
e

  handleFatalExceptions :: (HasCallStack => IO ()) -> IO ()
  handleFatalExceptions :: (HasCallStack => IO ()) -> IO ()
handleFatalExceptions = (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny ((SomeException -> IO ()) -> IO () -> IO ())
-> (SomeException -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeException
e ->
    Tracer IO TraceRpc -> TraceRpc -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TraceRpc
tracer (TraceRpc -> IO ()) -> TraceRpc -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> TraceRpc
TraceRpcFatalError SomeException
e