content: -- | RPC handlers
  --
  -- Intended for unqualified import.
  module Network.GRPC.Server.Handler (
      RpcHandler(..)
    , hoistRpcHandler
      -- * Construction
    , mkRpcHandler
    , mkRpcHandlerNoDefMetadata
      -- * Hide type argument
    , SomeRpcHandler(..)
    , someRpcHandler
    , hoistSomeRpcHandler
      -- * Execution
    , runHandler
    ) where
  
  import Prelude hiding (lookup)
  
  import Control.Concurrent.Async
  import Control.Monad
  import Control.Monad.Catch
  import Control.Monad.IO.Class
  import Data.Kind
  import Data.Proxy
  import GHC.Stack
  import System.ThreadManager (KilledByThreadManager(..))
  
  import Network.GRPC.Common
  import Network.GRPC.Server.Call
  import Network.GRPC.Server.Context
  import Network.GRPC.Util.GHC
  import Network.GRPC.Util.HTTP2.Stream (ClientDisconnected(..))
  import Network.GRPC.Util.Session qualified as Session
  
  {-------------------------------------------------------------------------------
    Handlers
  
    This is essentially an untyped interface; for a typed layer, see
    "Network.GRPC.Server.Protobuf".
  -------------------------------------------------------------------------------}
  
  -- | Handler for an RPC request
  --
  -- To construct an 'RpcHandler', you have two options:
  --
  -- * Use the \"raw\" API by calling 'mkRpcHandler'; this gives you full control
  --   over the interaction with the client.
  -- * Use the API from "Network.GRPC.Server.StreamType" to define handlers that
  --   use the Protobuf stream types. This API is more convenient, and can be used
  --   to guarantee at compile-time  that you have a handler for every method of
  --   the services you support, but provides less flexibility (although it offers
  --   an \"escape\" to the full API through
  --   'Network.GRPC.Server.StreamType.RawMethod').
  --
  -- __Note on cancellation.__ The GRPC spec allows clients to \"cancel\" a
  -- request (<https://grpc.io/docs/guides/cancellation/>). This does not
  -- correspond to any specific message being sent across the network; instead,
  -- the client simply disappears. The spec is quite clear that it is the
  -- responsibility of the handler /itself/ to monitor for this. In @grapesy@ this
  -- works as follows:
  --
  -- * Handlers are /not/ terminated when a client disappears. This allows the
  --   handler to finish what it's doing, and terminate cleanly.
  -- * When a handler tries to receive a message from the client ('recvInput'), or
  --   send a message to the client ('sendOutput'), and the client disappeared,
  --   this will result in a 'Network.GRPC.Server.ClientDisconnected' exception,
  --   which the handler can catch and deal with.
  --
  -- Cancellation is always at the request of the /client/. If the /handler/
  -- terminates early (that is, before sending the final output and trailers), a
  -- 'Network.GRPC.Server.HandlerTerminated' exception will be raised and sent to
  -- the client as 'GrpcException' with 'GrpcUnknown' error code.
  data RpcHandler (m :: Type -> Type) (rpc :: k) = RpcHandler {
        -- | Handler proper
        runRpcHandler :: Call rpc -> m ()
      }
  
  -- | Hoist an 'RpcHandler' to a different monad
  --
  -- We do not make 'RpcHandler' an instance of @MFunctor@ (from the @mmorph@
  -- package) because @RpcHandler m@ is not a monad; this means that even though
  -- the types line up, the concepts do not.
  hoistRpcHandler ::
       (forall a. m a -> n a)
    -> RpcHandler m rpc
    -> RpcHandler n rpc
  hoistRpcHandler f (RpcHandler h) = RpcHandler (f . h)
  
  {-------------------------------------------------------------------------------
    Construction
  -------------------------------------------------------------------------------}
  
  -- | Constructor for 'RpcHandler'
  --
  -- When the handler sends its first message to the client, @grapesy@ must first
  -- send the initial metadata (of type 'ResponseInitialMetadata') to the client.
  -- This metadata can be updated at any point before that first message (for
  -- example, after receiving some messages from the client) by calling
  -- 'setResponseInitialMetadata'. If this function is never called, however, then
  -- we need a default value; 'mkRpcHandler' therefore calls
  -- 'setResponseInitialMetadata' once before the handler proper, relying on the
  -- 'Default' instance.
  --
  -- For RPCs where a sensible default does not exist (perhaps the initial
  -- response metadata needs the request metadata from the client, or even some
  -- messages from the client), you can use 'mkRpcHandlerNoDefMetadata'.
  mkRpcHandler ::
       ( Default (ResponseInitialMetadata rpc)
       , MonadIO m
       )
    => (Call rpc -> m ()) -> RpcHandler m rpc
  mkRpcHandler k = RpcHandler $ \call -> do
      liftIO $ setResponseInitialMetadata call def
      k call
  
  -- | Variant on 'mkRpcHandler' that does not call 'setResponseInitialMetadata'
  --
  -- You /must/ call 'setResponseInitialMetadata' before sending the first
  -- message. See 'mkRpcHandler' for additional discussion.
  mkRpcHandlerNoDefMetadata :: (Call rpc -> m ()) -> RpcHandler m rpc
  mkRpcHandlerNoDefMetadata = RpcHandler
  
  {-------------------------------------------------------------------------------
    Hide the type argument
  -------------------------------------------------------------------------------}
  
  -- | Wrapper around 'RpcHandler' that hides the type argument
  --
  -- Construct using 'someRpcHandler'.
  data SomeRpcHandler m = forall rpc.
       SupportsServerRpc rpc
    => SomeRpcHandler (Proxy rpc) (RpcHandler m rpc)
  
  -- | Constructor for 'SomeRpcHandler'
  someRpcHandler :: forall rpc m.
       SupportsServerRpc rpc
    => RpcHandler m rpc -> SomeRpcHandler m
  someRpcHandler = SomeRpcHandler Proxy
  
  hoistSomeRpcHandler ::
       (forall a. m a -> n a)
    -> SomeRpcHandler m
    -> SomeRpcHandler n
  hoistSomeRpcHandler f (SomeRpcHandler p h) =
      SomeRpcHandler p (hoistRpcHandler f h)
  
  {-------------------------------------------------------------------------------
    Execution
  -------------------------------------------------------------------------------}
  
  -- | Accept incoming call
  --
  -- If the handler throws an exception, we will /attempt/ to inform the client
  -- of what happened (see 'forwardException') before re-throwing the exception.
  runHandler :: forall rpc.
       HasCallStack
    => (forall x. IO x -> IO x)
    -> Call rpc
    -> RpcHandler IO rpc
    -> IO ()
  runHandler unmask call handler = do
      -- http2 will kill the handler when the client disappears, but we want the
      -- handler to be able to terminate cleanly. We therefore run the handler in
      -- a separate thread, and wait for that thread to terminate.
      handlerThread <- asyncLabelled "grapesy:handler" handler'
      waitForHandler unmask call handlerThread
    where
      -- The handler itself will run in a separate thread
      handler' :: IO ()
      handler' = do
          result <- try $ runRpcHandler handler call
          handlerTeardown result
  
      -- Deal with any exceptions thrown in the handler
      handlerTeardown :: Either SomeException () -> IO ()
      handlerTeardown (Right ()) = do
          -- Handler terminated successfully, but may not have sent final message.
          -- /If/ the final message was sent, 'forwardException' does nothing.
          forwarded <- forwardException call $ toException HandlerTerminated
          ignoreUncleanClose call $ ExitCaseSuccess ()
          when forwarded $
            -- The handler terminated before it sent the final message.
            throwM HandlerTerminated
      handlerTeardown (Left err) = do
          -- The handler threw an exception. Attempt to tell the client.
          _forwarded <- forwardException call err
          ignoreUncleanClose call $ ExitCaseException err
          throwM err
  
  -- | Close the connection to the client, ignoring errors
  --
  -- An unclean shutdown can have 2 causes:
  --
  -- 1. We lost communication during the call.
  --
  --    We have no way of telling the client that something went wrong.
  --
  -- 2. The handler failed to properly terminate the communication
  --    (send the final message and call 'waitForOutbound').
  --
  --    This is a bug in the handler, and is trickier to deal with. We don't
  --    really know what state the handler left the channel in; for example,
  --    we might have killed the thread halfway through sending a message.
  --
  --    So there not really anything we can do here (except perhaps show
  --    the exception in 'serverTopLevel').
  ignoreUncleanClose :: Call rpc -> ExitCase a -> IO ()
  ignoreUncleanClose Call{callChannel} reason =
      void $ Session.close callChannel reason
  
  -- | Wait for the handler to terminate
  --
  -- If we are interrupted while we wait, it depends on the interruption:
  --
  -- * If we are interrupted by 'HTTP2.KilledByHttp2ThreadManager', it means we
  --   got disconnected from the client. In this case, we shut down the channel
  --   (if it's not already shut down); /if/ the handler at this tries to
  --   communicate with the client, an exception will be raised. However, the
  --   handler /can/ terminate cleanly and, of course, typically will.
  --   Importantly, this avoids race conditions: even if the server and the client
  --   agree that no further communication takes place (the client sent their
  --   final message, the server sent the trailers), without the indireciton of
  --   this additional thread it can still happen that http2 kills the handler
  --   (after the client disconnects) before the handler has a chance to
  --   terminate.
  --
  -- * If we are interrupted by another kind of asynchronous exception, we /do/
  --   kill the handler (this might for example be a timeout).
  --
  -- This is in line with the overall design philosophy of communication in this
  -- library: exceptions will only be raised synchronously when communication is
  -- attempted, not asynchronously when we notice a problem.
  waitForHandler ::
       HasCallStack
    => (forall x. IO x -> IO x)
    -> Call rpc -> Async () -> IO ()
  waitForHandler unmask call handlerThread = loop
    where
      loop :: IO ()
      loop = unmask (wait handlerThread) `catch` handleException
  
      handleException :: SomeException -> IO ()
      handleException err
        | Just (KilledByThreadManager mErr) <- fromException err = do
            let exitReason :: ExitCase ()
                exitReason =
                  case mErr of
                    Nothing -> ExitCaseSuccess ()
                    Just exitWithException ->
                      ExitCaseException . toException $
                        ClientDisconnected exitWithException callStack
            ignoreUncleanClose call exitReason
            loop
  
        | otherwise = do
            -- If we get an exception while waiting on the handler, there
            -- are two possibilities:
            --
            -- 1. The exception was an asynchronous exception, thrown to us
            --    externally. In this case @cancalWith@ will throw the
            --    exception to the handler (and wait for it to terminate).
            -- 2. The exception was thrown by the handler itself. In this
            --    case @cancelWith@ is a no-op.
            cancelWith handlerThread err
            throwM err
  
  -- | Process exception thrown by a handler
  --
  -- Trace the exception and forward it to the client.
  --
  -- The attempt to forward it to the client is a best-effort only:
  --
  -- * The nature of the exception might mean that we cannot send anything to
  --   the client at all.
  -- * It is possible the exception was thrown /after/ the handler already send
  --   the trailers to the client.
  --
  -- We therefore catch and suppress all exceptions here. Returns @True@ if the
  -- forwarding was successful, @False@ if it raised an exception.
  forwardException :: Call rpc -> SomeException -> IO Bool
  forwardException call@Call{callContext} err = do
      trailers <- serverExceptionToClientError (serverParams callContext) err
      (True <$ sendProperTrailers call trailers) `catch` handler
   where
     handler :: SomeException -> IO Bool
     handler _e = return False
  