{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Cardano.Rpc.Server
( runRpcServer
)
where
import Cardano.Api
import Cardano.Rpc.Proto.Api.Node qualified as Rpc
import Cardano.Rpc.Server.Config
import Cardano.Rpc.Server.Internal.Monad
import RIO
import Control.Tracer
import Data.ProtoLens (defMessage)
import Data.ProtoLens.Field (field)
import Network.GRPC.Common
import Network.GRPC.Server.Protobuf
import Network.GRPC.Server.Run
import Network.GRPC.Server.StreamType
import Network.GRPC.Spec hiding (Identity)
import Proto.Google.Protobuf.Empty
getEraMethod :: MonadRpc e m => Proto Empty -> m (Proto Rpc.CurrentEra)
getEraMethod :: forall e (m :: * -> *).
MonadRpc e m =>
Proto Empty -> m (Proto CurrentEra)
getEraMethod Proto Empty
_ = Proto CurrentEra -> m (Proto CurrentEra)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Proto CurrentEra
mockNodeResponse
mockNodeResponse :: Proto Rpc.CurrentEra
mockNodeResponse :: Proto CurrentEra
mockNodeResponse = CurrentEra -> Proto CurrentEra
forall msg. msg -> Proto msg
Proto (CurrentEra -> Proto CurrentEra) -> CurrentEra -> Proto CurrentEra
forall a b. (a -> b) -> a -> b
$ CurrentEra
forall msg. Message msg => msg
defMessage CurrentEra -> (CurrentEra -> CurrentEra) -> CurrentEra
forall a b. a -> (a -> b) -> b
& forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
field @"era" ((Era -> Identity Era) -> CurrentEra -> Identity CurrentEra)
-> Era -> CurrentEra -> CurrentEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Era
Rpc.Conway
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 '[] -> Methods m '[Protobuf Node "getEra"]
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 '[]
forall {k} (m :: * -> *). Methods m '[]
NoMoreMethods
runRpcServer
:: Tracer IO String
-> IO (RpcConfig, NetworkMagic)
-> IO ()
runRpcServer :: Tracer IO String -> IO (RpcConfig, NetworkMagic) -> IO ()
runRpcServer Tracer IO String
tracer IO (RpcConfig, NetworkMagic)
loadRpcConfig = (HasCallStack => IO ()) -> IO ()
handleExceptions ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
( RpcConfig
{ isEnabled = Identity isEnabled
, rpcSocketPath = Identity (File rpcSocketPathFp)
}
, _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
}
when isEnabled $
runServerWithHandlers def config $
mconcat
[ fromMethods methodsNodeRpc
]
where
handleExceptions :: (HasCallStack => IO ()) -> IO ()
handleExceptions :: (HasCallStack => IO ()) -> IO ()
handleExceptions = (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 ->
String -> IO ()
putTrace (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
putTrace :: String -> IO ()
putTrace = Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer