-- | Server context
--
-- Intended for unqualified import.
module Network.GRPC.Server.Context (
    -- * Context
    ServerContext(..)
  , newServerContext
    -- * Configuration
  , ServerParams(..)
  ) where

import Control.Exception
import System.IO

import Network.GRPC.Common
import Network.GRPC.Common.Compression qualified as Compr
import Network.GRPC.Server.RequestHandler.API
import Network.GRPC.Spec
import Data.Text (Text)
import Data.Text qualified as Text

{-------------------------------------------------------------------------------
  Context

  TODO: <https://github.com/well-typed/grapesy/issues/130>
  The server context is more of a placeholder at the moment. The plan is to use
  it to keep things like server usage statistics etc.
-------------------------------------------------------------------------------}

data ServerContext = ServerContext {
      ServerContext -> ServerParams
serverParams :: ServerParams
    }

newServerContext :: ServerParams -> IO ServerContext
newServerContext :: ServerParams -> IO ServerContext
newServerContext ServerParams
serverParams = do
    ServerContext -> IO ServerContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerContext{
        ServerParams
serverParams :: ServerParams
serverParams :: ServerParams
serverParams
      }

{-------------------------------------------------------------------------------
  Configuration
-------------------------------------------------------------------------------}

data ServerParams = ServerParams {
      -- | Server compression preferences
      ServerParams -> Negotation
serverCompression :: Compr.Negotation

      -- | Top-level hook for request handlers
      --
      -- The most important responsibility of this function is to deal with
      -- any exceptions that the handler might throw, but in principle it has
      -- full control over how requests are handled.
      --
      -- The default merely logs any exceptions to 'stderr'.
    , ServerParams -> RequestHandler () -> RequestHandler ()
serverTopLevel :: RequestHandler () -> RequestHandler ()

      -- | Render handler-side exceptions for the client
      --
      -- When a handler throws an exception other than a 'GrpcException', we use
      -- this function to render that exception for the client (server-side
      -- logging is taken care of by 'serverTopLevel'). The default
      -- implementation simply calls 'displayException' on the exception, which
      -- means the full context is visible on the client, which is most useful
      -- for debugging. However, it is a potential security concern: if the
      -- exception happens to contain sensitive information, this information
      -- will also be visible on the client. You may therefore wish to override
      -- the default behaviour.
    , ServerParams -> SomeException -> IO (Maybe Text)
serverExceptionToClient :: SomeException -> IO (Maybe Text)

      -- | Override content-type for response to client.
      --
      -- Set to 'Nothing' to omit the content-type header completely
      -- (this is not conform the gRPC spec).
    , ServerParams -> Maybe ContentType
serverContentType :: Maybe ContentType

      -- | Verify that all request headers can be parsed
      --
      -- When enabled, we verify at the start of each request that all request
      -- headers are valid. By default we do /not/ do this, throwing an error
      -- only in scenarios where we really cannot continue.
      --
      -- Even if enabled, we will not attempt to parse @rpc@-specific metadata
      -- (merely that the metadata is syntactically correct). See
      -- 'Network.GRPC.Server.getRequestMetadata' for detailed discussion.
    , ServerParams -> Bool
serverVerifyHeaders :: Bool
    }

instance Default ServerParams where
  def :: ServerParams
def = ServerParams {
        serverCompression :: Negotation
serverCompression       = Negotation
forall a. Default a => a
def
      , serverTopLevel :: RequestHandler () -> RequestHandler ()
serverTopLevel          = RequestHandler () -> RequestHandler ()
defaultServerTopLevel
      , serverExceptionToClient :: SomeException -> IO (Maybe Text)
serverExceptionToClient = SomeException -> IO (Maybe Text)
defaultServerExceptionToClient
      , serverContentType :: Maybe ContentType
serverContentType       = ContentType -> Maybe ContentType
forall a. a -> Maybe a
Just ContentType
ContentTypeDefault
      , serverVerifyHeaders :: Bool
serverVerifyHeaders     = Bool
False
      }

defaultServerTopLevel :: RequestHandler () -> RequestHandler ()
defaultServerTopLevel :: RequestHandler () -> RequestHandler ()
defaultServerTopLevel RequestHandler ()
h forall x. IO x -> IO x
unmask Request
req Response -> IO ()
resp =
    RequestHandler ()
h IO x -> IO x
forall x. IO x -> IO x
unmask Request
req Response -> IO ()
resp IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO ()
handler
  where
    handler :: SomeException -> IO ()
    handler :: SomeException -> IO ()
handler = Handle -> SomeException -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr

-- | Default implementation for 'serverExceptionToClient'
--
-- We unwrap the 'SomeException' wrapper so that we do not include the exception
-- context in the output to the client (relevant for @ghc >= 9.10@ only).
--
-- See <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0330-exception-backtraces.rst>.
defaultServerExceptionToClient :: SomeException -> IO (Maybe Text)
defaultServerExceptionToClient :: SomeException -> IO (Maybe Text)
defaultServerExceptionToClient (SomeException e
e) =
    Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Server-side exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall e. Exception e => e -> String
displayException e
e)