Context.hs

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

import Data.Text qualified as Text
import System.IO (stderr, hPrint)

import Network.GRPC.Common.Compression qualified as Compr
import Network.GRPC.Common.Exception
import Network.GRPC.Server.RequestHandler.API
import Network.GRPC.Util.Imports

{-------------------------------------------------------------------------------
  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 {
      serverParams :: ServerParams
    }

newServerContext :: ServerParams -> IO ServerContext
newServerContext serverParams = do
    return ServerContext{
        serverParams
      }

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

data ServerParams = ServerParams {
      -- | Server compression preferences
      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'.
    , 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.
    , serverExceptionToClient :: ExactException -> 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).
    , 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.
    , serverVerifyHeaders :: Bool
    }

instance Default ServerParams where
  def = ServerParams {
        serverCompression       = def
      , serverTopLevel          = defaultServerTopLevel
      , serverExceptionToClient = defaultServerExceptionToClient
      , serverContentType       = Just ContentTypeDefault
      , serverVerifyHeaders     = False
      }

defaultServerTopLevel :: RequestHandler () -> RequestHandler ()
defaultServerTopLevel h unmask req resp =
    h unmask req resp `catch` handler
  where
    handler :: ExactException -> IO ()
    handler = hPrint stderr

-- | Default implementation for 'serverExceptionToClient'
--
-- Exception annotations are not included: these reveal server implementation
-- details and are not typicall relevant or even meaningful to clients.
defaultServerExceptionToClient :: ExactException -> IO (Maybe Text)
defaultServerExceptionToClient exact = return $
    withoutAnnotations exact $ \e -> Just . Text.pack $ concat [
        "Server-side exception: "
      ,  displayException e
      ]