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

-- Individual handlers

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

-- Mock node response
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

-- 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 '[] -> 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)
  -- ^ 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 ()
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
          }

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

  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