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

module Cardano.Rpc.Server
  ( runRpcServer
  )
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.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"))
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"))
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"))
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 String
  -> IO (RpcConfig, NetworkMagic)
  -- ^ action which reloads RPC configuration
  -> IO ()
runRpcServer :: Tracer IO String -> IO (RpcConfig, NetworkMagic) -> IO ()
runRpcServer Tracer IO String
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
$ String -> InsecureConfig
InsecureUnix String
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 String
tracer = (forall x. IO x -> m x) -> Tracer IO String -> Tracer m String
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 String
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 String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Exception when processing RPC request:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException 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 String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"RPC server fatal error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e