content: {-# 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 handlers ctxt unmask request respond = do
      labelThisThread "grapesy:requestHandler"
  
      SomeRpcHandler (_ :: Proxy rpc) handler <-
        findHandler handlers request      `catch` setupFailure params respond
      (call :: Call rpc, mTimeout :: Maybe Timeout) <-
        setupCall connectionToClient ctxt `catch` setupFailure params respond
  
      imposeTimeout mTimeout $
        runHandler unmask call handler
    where
      ServerContext{serverParams = params} = ctxt
  
      connectionToClient :: ConnectionToClient
      connectionToClient = ConnectionToClient{request, respond}
  
      timeoutException :: GrpcException
      timeoutException = GrpcException {
            grpcError         = GrpcDeadlineExceeded
          , grpcErrorMessage  = Nothing
          , grpcErrorDetails  = Nothing
          , grpcErrorMetadata = []
          }
  
      imposeTimeout :: Maybe Timeout -> IO () -> IO ()
      imposeTimeout Nothing  = id
      imposeTimeout (Just t) = timeoutWith timeoutException (timeoutToMicro t)
  
  -- | Find handler (based on the path)
  --
  -- Throws 'CallSetupFailure' if no handler could be found.
  findHandler ::
       HandlerMap IO
    -> HTTP2.Request
    -> IO (SomeRpcHandler IO)
  findHandler handlers req = do
      -- TODO: <https://github.com/well-typed/grapesy/issues/131>
      -- We should do some request logging.
  
      resourceHeaders <-
        either throwM return . first CallSetupInvalidResourceHeaders $
          parseResourceHeaders rawHeaders
      let path = resourcePath 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 h) -> return h
        Right Nothing  -> throwM $ CallSetupUnimplementedMethod path
        Left err       -> throwM $ CallSetupHandlerLookupException err
    where
      rawHeaders :: RawResourceHeaders
      rawHeaders = RawResourceHeaders {
            rawPath   = fromMaybe "" $ HTTP2.requestPath   req
          , rawMethod = fromMaybe "" $ HTTP2.requestMethod 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 params sendResponse failure = do
      response <- mkFailureResponse params 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 params = \case
      CallSetupInvalidResourceHeaders (InvalidMethod method) ->
        return $
          HTTP2.responseBuilder
            HTTP.methodNotAllowed405
            [("Allow", "POST")]
            (Builder.byteString . mconcat $ [
                "Unexpected :method " <> method <> ".\n"
              , "The only method supported by gRPC is POST.\n"
              ])
      CallSetupInvalidResourceHeaders (InvalidPath path) ->
        return $
          HTTP2.responseBuilder HTTP.badRequest400 [] . Builder.byteString $
            "Invalid path " <> path
      CallSetupInvalidRequestHeaders invalid ->
        return $
          HTTP2.responseBuilder (statusInvalidHeaders invalid) [] $
            prettyInvalidHeaders invalid
      CallSetupUnsupportedCompression cid ->
        return $
          HTTP2.responseBuilder HTTP.badRequest400 [] . Builder.byteString $
            "Unsupported compression: " <> BS.UTF8.fromString (show cid)
      CallSetupUnimplementedMethod path -> do
        let trailersOnly :: TrailersOnly
            trailersOnly = properTrailersToTrailersOnly (
                grpcExceptionToTrailers $ grpcUnimplemented path
              , serverContentType
              )
        return $
          HTTP2.responseNoBody HTTP.ok200 $
            buildTrailersOnly contentTypeForUnknown trailersOnly
      CallSetupHandlerLookupException err -> do
        msg <- serverExceptionToClient err
        let trailersOnly :: TrailersOnly
            trailersOnly = properTrailersToTrailersOnly (
                grpcExceptionToTrailers $ GrpcException {
                    grpcError         = GrpcUnknown
                  , grpcErrorMessage  = msg
                  , grpcErrorDetails  = Nothing
                  , grpcErrorMetadata = []
                  }
              , serverContentType
              )
        return $
          HTTP2.responseNoBody HTTP.ok200 $
            buildTrailersOnly contentTypeForUnknown trailersOnly
    where
      ServerParams{
          serverExceptionToClient
        , serverContentType
        } = params
  
  -- | Variation on 'chooseContentType' that can be used when the RPC is unknown
  contentTypeForUnknown :: ContentType -> Maybe BS.UTF8.ByteString
  contentTypeForUnknown ContentTypeDefault       = Nothing
  contentTypeForUnknown (ContentTypeOverride ct) = Just ct
  
  grpcUnimplemented :: Path -> GrpcException
  grpcUnimplemented path = GrpcException {
        grpcError         = GrpcUnimplemented
      , grpcErrorMessage  = Just . Text.pack . BS.Char8.unpack $ mconcat [
                                  "Method "
                                , pathService path
                                , "."
                                , pathMethod path
                                , " not implemented"
                                ]
      , grpcErrorDetails  = Nothing
      , grpcErrorMetadata = []
      }
  
  {-------------------------------------------------------------------------------
    Auxiliary
  -------------------------------------------------------------------------------}
  
  -- | Timeout with a specific exception
  timeoutWith :: Exception e => e -> Integer -> IO a -> IO a
  timeoutWith e t io = do
      me <- myThreadId
  
      let timer :: IO ()
          timer = do
              UnboundedDelays.delay t
              throwTo me e
  
      bracket (forkIO timer) killThread $ \_ -> io
  