{-# LANGUAGE OverloadedStrings #-}

-- | Request handler
--
-- This is not part of the library's public API.
--
-- Intended for unqualified import.
module Network.GRPC.Server.RequestHandler (
    -- * Definition
    RequestHandler
  , requestHandlerToServer
    -- * Construction
  , requestHandler
  ) where

import Control.Concurrent
import Control.Concurrent.Thread.Delay qualified as UnboundedDelays
import Control.Exception (evaluate)
import Control.Monad.Catch
import Data.Bifunctor
import Data.ByteString.Builder qualified as Builder
import Data.ByteString.Char8 qualified as BS.Char8
import Data.ByteString.UTF8 qualified as BS.UTF8
import Data.Maybe (fromMaybe)
import Data.Proxy
import Data.Text qualified as Text
import Network.HTTP.Types qualified as HTTP
import Network.HTTP2.Server qualified as HTTP2

import Network.GRPC.Server.Call
import Network.GRPC.Server.Context (ServerContext (..), ServerParams(..))
import Network.GRPC.Server.Handler
import Network.GRPC.Server.HandlerMap (HandlerMap)
import Network.GRPC.Server.HandlerMap qualified as HandlerMap
import Network.GRPC.Server.RequestHandler.API
import Network.GRPC.Server.Session (CallSetupFailure(..))
import Network.GRPC.Spec
import Network.GRPC.Spec.Serialization
import Network.GRPC.Util.GHC
import Network.GRPC.Util.Session.Server

{-------------------------------------------------------------------------------
  Construct request handler
-------------------------------------------------------------------------------}

-- | Construct request handler
requestHandler :: HandlerMap IO -> ServerContext -> RequestHandler ()
requestHandler :: HandlerMap IO -> ServerContext -> RequestHandler ()
requestHandler HandlerMap IO
handlers ServerContext
ctxt forall x. IO x -> IO x
unmask Request
request Response -> IO ()
respond = do
    ThreadLabel -> IO ()
forall (m :: * -> *). MonadIO m => ThreadLabel -> m ()
labelThisThread ThreadLabel
"grapesy:requestHandler"

    SomeRpcHandler (_ :: Proxy rpc) handler <-
      HandlerMap IO -> Request -> IO (SomeRpcHandler IO)
findHandler HandlerMap IO
handlers Request
request      IO (SomeRpcHandler IO)
-> (CallSetupFailure -> IO (SomeRpcHandler IO))
-> IO (SomeRpcHandler IO)
forall e a.
(HasCallStack, Exception e) =>
IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` ServerParams
-> (Response -> IO ())
-> CallSetupFailure
-> IO (SomeRpcHandler IO)
forall a.
ServerParams -> (Response -> IO ()) -> CallSetupFailure -> IO a
setupFailure ServerParams
params Response -> IO ()
respond
    (call :: Call rpc, mTimeout :: Maybe Timeout) <-
      setupCall connectionToClient ctxt `catch` setupFailure params respond

    imposeTimeout mTimeout $
      runHandler unmask call handler
  where
    ServerContext{serverParams :: ServerContext -> ServerParams
serverParams = ServerParams
params} = ServerContext
ctxt

    connectionToClient :: ConnectionToClient
    connectionToClient :: ConnectionToClient
connectionToClient = ConnectionToClient{Request
request :: Request
request :: Request
request, Response -> IO ()
respond :: Response -> IO ()
respond :: Response -> IO ()
respond}

    timeoutException :: GrpcException
    timeoutException :: GrpcException
timeoutException = GrpcException {
          grpcError :: GrpcError
grpcError         = GrpcError
GrpcDeadlineExceeded
        , grpcErrorMessage :: Maybe Text
grpcErrorMessage  = Maybe Text
forall a. Maybe a
Nothing
        , grpcErrorDetails :: Maybe ByteString
grpcErrorDetails  = Maybe ByteString
forall a. Maybe a
Nothing
        , grpcErrorMetadata :: [CustomMetadata]
grpcErrorMetadata = []
        }

    imposeTimeout :: Maybe Timeout -> IO () -> IO ()
    imposeTimeout :: Maybe Timeout -> IO () -> IO ()
imposeTimeout Maybe Timeout
Nothing  = IO () -> IO ()
forall a. a -> a
id
    imposeTimeout (Just Timeout
t) = GrpcException -> Integer -> IO () -> IO ()
forall e a. Exception e => e -> Integer -> IO a -> IO a
timeoutWith GrpcException
timeoutException (Timeout -> Integer
timeoutToMicro Timeout
t)

-- | Find handler (based on the path)
--
-- Throws 'CallSetupFailure' if no handler could be found.
findHandler ::
     HandlerMap IO
  -> HTTP2.Request
  -> IO (SomeRpcHandler IO)
findHandler :: HandlerMap IO -> Request -> IO (SomeRpcHandler IO)
findHandler HandlerMap IO
handlers Request
req = do
    -- TODO: <https://github.com/well-typed/grapesy/issues/131>
    -- We should do some request logging.

    resourceHeaders <-
      (CallSetupFailure -> IO ResourceHeaders)
-> (ResourceHeaders -> IO ResourceHeaders)
-> Either CallSetupFailure ResourceHeaders
-> IO ResourceHeaders
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CallSetupFailure -> IO ResourceHeaders
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM ResourceHeaders -> IO ResourceHeaders
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CallSetupFailure ResourceHeaders -> IO ResourceHeaders)
-> (Either InvalidResourceHeaders ResourceHeaders
    -> Either CallSetupFailure ResourceHeaders)
-> Either InvalidResourceHeaders ResourceHeaders
-> IO ResourceHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InvalidResourceHeaders -> CallSetupFailure)
-> Either InvalidResourceHeaders ResourceHeaders
-> Either CallSetupFailure ResourceHeaders
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first InvalidResourceHeaders -> CallSetupFailure
CallSetupInvalidResourceHeaders (Either InvalidResourceHeaders ResourceHeaders
 -> IO ResourceHeaders)
-> Either InvalidResourceHeaders ResourceHeaders
-> IO ResourceHeaders
forall a b. (a -> b) -> a -> b
$
        RawResourceHeaders -> Either InvalidResourceHeaders ResourceHeaders
parseResourceHeaders RawResourceHeaders
rawHeaders
    let path = ResourceHeaders -> Path
resourcePath ResourceHeaders
resourceHeaders

    -- We have to be careful looking up the handler; there might be pure
    -- exceptions in the list of handlers (most commonly @undefined@).
    mHandler <- try $ evaluate $ HandlerMap.lookup path handlers
    case mHandler of
      Right (Just SomeRpcHandler IO
h) -> SomeRpcHandler IO -> IO (SomeRpcHandler IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SomeRpcHandler IO
h
      Right Maybe (SomeRpcHandler IO)
Nothing  -> CallSetupFailure -> IO (SomeRpcHandler IO)
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (CallSetupFailure -> IO (SomeRpcHandler IO))
-> CallSetupFailure -> IO (SomeRpcHandler IO)
forall a b. (a -> b) -> a -> b
$ Path -> CallSetupFailure
CallSetupUnimplementedMethod Path
path
      Left SomeException
err       -> CallSetupFailure -> IO (SomeRpcHandler IO)
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (CallSetupFailure -> IO (SomeRpcHandler IO))
-> CallSetupFailure -> IO (SomeRpcHandler IO)
forall a b. (a -> b) -> a -> b
$ SomeException -> CallSetupFailure
CallSetupHandlerLookupException SomeException
err
  where
    rawHeaders :: RawResourceHeaders
    rawHeaders :: RawResourceHeaders
rawHeaders = RawResourceHeaders {
          rawPath :: ByteString
rawPath   = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Maybe ByteString
HTTP2.requestPath   Request
req
        , rawMethod :: ByteString
rawMethod = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Maybe ByteString
HTTP2.requestMethod Request
req
        }

-- | Call setup failure
--
-- Something went wrong during call setup. No response has been sent to the
-- client at all yet. We try to tell the client what happened, but ignore any
-- exceptions that might arise from doing so.
setupFailure ::
     ServerParams
  -> (HTTP2.Response -> IO ())
  -> CallSetupFailure
  -> IO a
setupFailure :: forall a.
ServerParams -> (Response -> IO ()) -> CallSetupFailure -> IO a
setupFailure ServerParams
params Response -> IO ()
sendResponse CallSetupFailure
failure = do
    response <- ServerParams -> CallSetupFailure -> IO Response
mkFailureResponse ServerParams
params CallSetupFailure
failure
    _ :: Either SomeException () <- try $ sendResponse response
    throwM failure

{-------------------------------------------------------------------------------
  Failures
-------------------------------------------------------------------------------}

-- | Turn setup failure into response to the client
--
-- The gRPC spec mandates that we /always/ return HTTP 200 OK, but it does not
-- explicitly say what to do when the request is malformed (not conform the
-- gRPC specification). We choose to return HTTP errors in this case.
--
-- See <https://datatracker.ietf.org/doc/html/rfc7231#section-6.5> for
-- a discussion of the HTTP error codes, specifically
--
-- * 400 Bad Request
--   <https://datatracker.ietf.org/doc/html/rfc7231#section-6.5.1>
-- * 405 Method Not Allowed
--   <https://datatracker.ietf.org/doc/html/rfc7231#section-6.5.5>
--   <https://datatracker.ietf.org/doc/html/rfc7231#section-7.4.1>
--
-- Testing out-of-spec errors can be bit awkward. One option is @curl@:
--
-- > curl --verbose --http2 --http2-prior-knowledge http://127.0.0.1:50051/
mkFailureResponse :: ServerParams -> CallSetupFailure -> IO HTTP2.Response
mkFailureResponse :: ServerParams -> CallSetupFailure -> IO Response
mkFailureResponse ServerParams
params = \case
    CallSetupInvalidResourceHeaders (InvalidMethod ByteString
method) ->
      Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> Builder -> Response
HTTP2.responseBuilder
          Status
HTTP.methodNotAllowed405
          [(HeaderName
"Allow", ByteString
"POST")]
          (ByteString -> Builder
Builder.byteString (ByteString -> Builder)
-> ([ByteString] -> ByteString) -> [ByteString] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> Builder) -> [ByteString] -> Builder
forall a b. (a -> b) -> a -> b
$ [
              ByteString
"Unexpected :method " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
method ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
".\n"
            , ByteString
"The only method supported by gRPC is POST.\n"
            ])
    CallSetupInvalidResourceHeaders (InvalidPath ByteString
path) ->
      Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> Builder -> Response
HTTP2.responseBuilder Status
HTTP.badRequest400 [] (Builder -> Response)
-> (ByteString -> Builder) -> ByteString -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
Builder.byteString (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
          ByteString
"Invalid path " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
path
    CallSetupInvalidRequestHeaders InvalidHeaders HandledSynthesized
invalid ->
      Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> Builder -> Response
HTTP2.responseBuilder (InvalidHeaders HandledSynthesized -> Status
statusInvalidHeaders InvalidHeaders HandledSynthesized
invalid) [] (Builder -> Response) -> Builder -> Response
forall a b. (a -> b) -> a -> b
$
          InvalidHeaders HandledSynthesized -> Builder
prettyInvalidHeaders InvalidHeaders HandledSynthesized
invalid
    CallSetupUnsupportedCompression CompressionId
cid ->
      Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> Builder -> Response
HTTP2.responseBuilder Status
HTTP.badRequest400 [] (Builder -> Response)
-> (ByteString -> Builder) -> ByteString -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
Builder.byteString (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
          ByteString
"Unsupported compression: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ThreadLabel -> ByteString
BS.UTF8.fromString (CompressionId -> ThreadLabel
forall a. Show a => a -> ThreadLabel
show CompressionId
cid)
    CallSetupUnimplementedMethod Path
path -> do
      let trailersOnly :: TrailersOnly
          trailersOnly :: TrailersOnly
trailersOnly = (ProperTrailers_ Undecorated, HKD Undecorated (Maybe ContentType))
-> TrailersOnly
forall (f :: * -> *).
(ProperTrailers_ f, HKD f (Maybe ContentType)) -> TrailersOnly_ f
properTrailersToTrailersOnly (
              GrpcException -> ProperTrailers_ Undecorated
grpcExceptionToTrailers (GrpcException -> ProperTrailers_ Undecorated)
-> GrpcException -> ProperTrailers_ Undecorated
forall a b. (a -> b) -> a -> b
$ Path -> GrpcException
grpcUnimplemented Path
path
            , Maybe ContentType
HKD Undecorated (Maybe ContentType)
serverContentType
            )
      Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> Response
HTTP2.responseNoBody Status
HTTP.ok200 (ResponseHeaders -> Response) -> ResponseHeaders -> Response
forall a b. (a -> b) -> a -> b
$
          (ContentType -> Maybe ByteString)
-> TrailersOnly -> ResponseHeaders
buildTrailersOnly ContentType -> Maybe ByteString
contentTypeForUnknown TrailersOnly
trailersOnly
    CallSetupHandlerLookupException SomeException
err -> do
      msg <- SomeException -> IO (Maybe Text)
serverExceptionToClient SomeException
err
      let trailersOnly :: TrailersOnly
          trailersOnly = (ProperTrailers_ Undecorated, HKD Undecorated (Maybe ContentType))
-> TrailersOnly
forall (f :: * -> *).
(ProperTrailers_ f, HKD f (Maybe ContentType)) -> TrailersOnly_ f
properTrailersToTrailersOnly (
              GrpcException -> ProperTrailers_ Undecorated
grpcExceptionToTrailers (GrpcException -> ProperTrailers_ Undecorated)
-> GrpcException -> ProperTrailers_ Undecorated
forall a b. (a -> b) -> a -> b
$ GrpcException {
                  grpcError :: GrpcError
grpcError         = GrpcError
GrpcUnknown
                , grpcErrorMessage :: Maybe Text
grpcErrorMessage  = Maybe Text
msg
                , grpcErrorDetails :: Maybe ByteString
grpcErrorDetails  = Maybe ByteString
forall a. Maybe a
Nothing
                , grpcErrorMetadata :: [CustomMetadata]
grpcErrorMetadata = []
                }
            , Maybe ContentType
HKD Undecorated (Maybe ContentType)
serverContentType
            )
      return $
        HTTP2.responseNoBody HTTP.ok200 $
          buildTrailersOnly contentTypeForUnknown trailersOnly
  where
    ServerParams{
        SomeException -> IO (Maybe Text)
serverExceptionToClient :: SomeException -> IO (Maybe Text)
serverExceptionToClient :: ServerParams -> SomeException -> IO (Maybe Text)
serverExceptionToClient
      , Maybe ContentType
serverContentType :: Maybe ContentType
serverContentType :: ServerParams -> Maybe ContentType
serverContentType
      } = ServerParams
params

-- | Variation on 'chooseContentType' that can be used when the RPC is unknown
contentTypeForUnknown :: ContentType -> Maybe BS.UTF8.ByteString
contentTypeForUnknown :: ContentType -> Maybe ByteString
contentTypeForUnknown ContentType
ContentTypeDefault       = Maybe ByteString
forall a. Maybe a
Nothing
contentTypeForUnknown (ContentTypeOverride ByteString
ct) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
ct

grpcUnimplemented :: Path -> GrpcException
grpcUnimplemented :: Path -> GrpcException
grpcUnimplemented Path
path = GrpcException {
      grpcError :: GrpcError
grpcError         = GrpcError
GrpcUnimplemented
    , grpcErrorMessage :: Maybe Text
grpcErrorMessage  = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> (ByteString -> Text) -> ByteString -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadLabel -> Text
Text.pack (ThreadLabel -> Text)
-> (ByteString -> ThreadLabel) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ThreadLabel
BS.Char8.unpack (ByteString -> Maybe Text) -> ByteString -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [
                                ByteString
"Method "
                              , Path -> ByteString
pathService Path
path
                              , ByteString
"."
                              , Path -> ByteString
pathMethod Path
path
                              , ByteString
" not implemented"
                              ]
    , grpcErrorDetails :: Maybe ByteString
grpcErrorDetails  = Maybe ByteString
forall a. Maybe a
Nothing
    , grpcErrorMetadata :: [CustomMetadata]
grpcErrorMetadata = []
    }

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Timeout with a specific exception
timeoutWith :: Exception e => e -> Integer -> IO a -> IO a
timeoutWith :: forall e a. Exception e => e -> Integer -> IO a -> IO a
timeoutWith e
e Integer
t IO a
io = do
    me <- IO ThreadId
myThreadId

    let timer :: IO ()
        timer = do
            Integer -> IO ()
UnboundedDelays.delay Integer
t
            ThreadId -> e -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
me e
e

    bracket (forkIO timer) killThread $ \ThreadId
_ -> IO a
io