{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.GRPC.HighLevel.Server.Unregistered where

import           Control.Arrow
import           Control.Concurrent.MVar                   (newEmptyMVar,
                                                            putMVar,
                                                            takeMVar)
import qualified Control.Exception                         as CE
import           Control.Monad
import           Data.Foldable                             (find)
import           Network.GRPC.HighLevel.Server
import           Network.GRPC.LowLevel
import           Network.GRPC.LowLevel.Server              (forkServer)
import qualified Network.GRPC.LowLevel.Call.Unregistered   as U
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
import           Proto3.Suite.Class

dispatchLoop :: Server
             -> (String -> IO ())
             -> MetadataMap
             -> [Handler 'Normal]
             -> [Handler 'ClientStreaming]
             -> [Handler 'ServerStreaming]
             -> [Handler 'BiDiStreaming]
             -> IO ()
dispatchLoop :: Server
-> (String -> IO ())
-> MetadataMap
-> [Handler 'Normal]
-> [Handler 'ClientStreaming]
-> [Handler 'ServerStreaming]
-> [Handler 'BiDiStreaming]
-> IO ()
dispatchLoop Server
s String -> IO ()
logger MetadataMap
md [Handler 'Normal]
hN [Handler 'ClientStreaming]
hC [Handler 'ServerStreaming]
hS [Handler 'BiDiStreaming]
hB =
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> (ServerCall -> IO ()) -> IO ()
U.withServerCallAsync Server
s ((ServerCall -> IO ()) -> IO ()) -> (ServerCall -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ServerCall
sc ->
    case ServerCall -> [AnyHandler] -> Maybe AnyHandler
forall (t :: * -> *).
Foldable t =>
ServerCall -> t AnyHandler -> Maybe AnyHandler
findHandler ServerCall
sc [AnyHandler]
allHandlers of
      Just (AnyHandler Handler a
ah) -> case Handler a
ah of
        UnaryHandler MethodName
_ ServerHandler c d
h        -> ServerCall -> ServerHandler c d -> IO ()
forall a b.
(Message a, Message b) =>
ServerCall -> ServerHandler a b -> IO ()
unaryHandler ServerCall
sc ServerHandler c d
h
        ClientStreamHandler MethodName
_ ServerReaderHandler c d
h -> ServerCall -> ServerReaderHandler c d -> IO ()
forall a b.
(Message a, Message b) =>
ServerCall -> ServerReaderHandler a b -> IO ()
csHandler ServerCall
sc ServerReaderHandler c d
h
        ServerStreamHandler MethodName
_ ServerWriterHandler c d
h -> ServerCall -> ServerWriterHandler c d -> IO ()
forall a b.
(Message a, Message b) =>
ServerCall -> ServerWriterHandler a b -> IO ()
ssHandler ServerCall
sc ServerWriterHandler c d
h
        BiDiStreamHandler MethodName
_ ServerRWHandler c d
h   -> ServerCall -> ServerRWHandler c d -> IO ()
forall a b.
(Message a, Message b) =>
ServerCall -> ServerRWHandler a b -> IO ()
bdHandler ServerCall
sc ServerRWHandler c d
h
      Maybe AnyHandler
Nothing                   -> ServerCall -> IO ()
unknownHandler ServerCall
sc
  where
    allHandlers :: [AnyHandler]
allHandlers = (Handler 'Normal -> AnyHandler)
-> [Handler 'Normal] -> [AnyHandler]
forall a b. (a -> b) -> [a] -> [b]
map Handler 'Normal -> AnyHandler
forall (a :: GRPCMethodType). Handler a -> AnyHandler
AnyHandler [Handler 'Normal]
hN [AnyHandler] -> [AnyHandler] -> [AnyHandler]
forall a. [a] -> [a] -> [a]
++ (Handler 'ClientStreaming -> AnyHandler)
-> [Handler 'ClientStreaming] -> [AnyHandler]
forall a b. (a -> b) -> [a] -> [b]
map Handler 'ClientStreaming -> AnyHandler
forall (a :: GRPCMethodType). Handler a -> AnyHandler
AnyHandler [Handler 'ClientStreaming]
hC
                  [AnyHandler] -> [AnyHandler] -> [AnyHandler]
forall a. [a] -> [a] -> [a]
++ (Handler 'ServerStreaming -> AnyHandler)
-> [Handler 'ServerStreaming] -> [AnyHandler]
forall a b. (a -> b) -> [a] -> [b]
map Handler 'ServerStreaming -> AnyHandler
forall (a :: GRPCMethodType). Handler a -> AnyHandler
AnyHandler [Handler 'ServerStreaming]
hS [AnyHandler] -> [AnyHandler] -> [AnyHandler]
forall a. [a] -> [a] -> [a]
++ (Handler 'BiDiStreaming -> AnyHandler)
-> [Handler 'BiDiStreaming] -> [AnyHandler]
forall a b. (a -> b) -> [a] -> [b]
map Handler 'BiDiStreaming -> AnyHandler
forall (a :: GRPCMethodType). Handler a -> AnyHandler
AnyHandler [Handler 'BiDiStreaming]
hB

    findHandler :: ServerCall -> t AnyHandler -> Maybe AnyHandler
findHandler ServerCall
sc = (AnyHandler -> Bool) -> t AnyHandler -> Maybe AnyHandler
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((MethodName -> MethodName -> Bool
forall a. Eq a => a -> a -> Bool
== ServerCall -> MethodName
U.callMethod ServerCall
sc) (MethodName -> Bool)
-> (AnyHandler -> MethodName) -> AnyHandler -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyHandler -> MethodName
anyHandlerMethodName)

    unaryHandler :: (Message a, Message b) => U.ServerCall -> ServerHandler a b -> IO ()
    unaryHandler :: ServerCall -> ServerHandler a b -> IO ()
unaryHandler ServerCall
sc ServerHandler a b
h =
      IO (Either GRPCIOError ()) -> IO ()
forall a. IO a -> IO ()
handleError (IO (Either GRPCIOError ()) -> IO ())
-> IO (Either GRPCIOError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        Server
-> ServerCall
-> MetadataMap
-> ServerHandler
-> IO (Either GRPCIOError ())
U.serverHandleNormalCall' Server
s ServerCall
sc MetadataMap
md (ServerHandler -> IO (Either GRPCIOError ()))
-> ServerHandler -> IO (Either GRPCIOError ())
forall a b. (a -> b) -> a -> b
$ \ServerCall
_sc' ByteString
bs ->
          ServerHandler a b -> ServerHandlerLL
forall a b.
(Message a, Message b) =>
ServerHandler a b -> ServerHandlerLL
convertServerHandler ServerHandler a b
h (ByteString -> () -> ByteString
forall a b. a -> b -> a
const ByteString
bs (() -> ByteString) -> ServerCall () -> ServerCall ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerCall -> ServerCall ()
U.convertCall ServerCall
sc)

    csHandler :: (Message a, Message b) => U.ServerCall -> ServerReaderHandler a b -> IO ()
    csHandler :: ServerCall -> ServerReaderHandler a b -> IO ()
csHandler ServerCall
sc = IO (Either GRPCIOError ()) -> IO ()
forall a. IO a -> IO ()
handleError (IO (Either GRPCIOError ()) -> IO ())
-> ((ServerCall ()
     -> StreamRecv a
     -> IO (Maybe b, MetadataMap, StatusCode, StatusDetails))
    -> IO (Either GRPCIOError ()))
-> (ServerCall ()
    -> StreamRecv a
    -> IO (Maybe b, MetadataMap, StatusCode, StatusDetails))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server
-> ServerCall
-> MetadataMap
-> ServerReaderHandlerLL
-> IO (Either GRPCIOError ())
U.serverReader Server
s ServerCall
sc MetadataMap
md ((ServerCall ()
  -> IO (Either GRPCIOError (Maybe ByteString))
  -> IO (Maybe ByteString, MetadataMap, StatusCode, StatusDetails))
 -> IO (Either GRPCIOError ()))
-> ((ServerCall ()
     -> StreamRecv a
     -> IO (Maybe b, MetadataMap, StatusCode, StatusDetails))
    -> ServerCall ()
    -> IO (Either GRPCIOError (Maybe ByteString))
    -> IO (Maybe ByteString, MetadataMap, StatusCode, StatusDetails))
-> (ServerCall ()
    -> StreamRecv a
    -> IO (Maybe b, MetadataMap, StatusCode, StatusDetails))
-> IO (Either GRPCIOError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerCall ()
 -> StreamRecv a
 -> IO (Maybe b, MetadataMap, StatusCode, StatusDetails))
-> ServerCall ()
-> IO (Either GRPCIOError (Maybe ByteString))
-> IO (Maybe ByteString, MetadataMap, StatusCode, StatusDetails)
forall a b.
(Message a, Message b) =>
ServerReaderHandler a b -> ServerReaderHandlerLL
convertServerReaderHandler

    ssHandler :: (Message a, Message b) => U.ServerCall -> ServerWriterHandler a b -> IO ()
    ssHandler :: ServerCall -> ServerWriterHandler a b -> IO ()
ssHandler ServerCall
sc = IO (Either GRPCIOError ()) -> IO ()
forall a. IO a -> IO ()
handleError (IO (Either GRPCIOError ()) -> IO ())
-> (ServerWriterHandler a b -> IO (Either GRPCIOError ()))
-> ServerWriterHandler a b
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server
-> ServerCall
-> MetadataMap
-> ServerWriterHandlerLL
-> IO (Either GRPCIOError ())
U.serverWriter Server
s ServerCall
sc MetadataMap
md ((ServerCall ByteString
  -> (ByteString -> IO (Either GRPCIOError ()))
  -> IO (MetadataMap, StatusCode, StatusDetails))
 -> IO (Either GRPCIOError ()))
-> (ServerWriterHandler a b
    -> ServerCall ByteString
    -> (ByteString -> IO (Either GRPCIOError ()))
    -> IO (MetadataMap, StatusCode, StatusDetails))
-> ServerWriterHandler a b
-> IO (Either GRPCIOError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerWriterHandler a b
-> ServerCall ByteString
-> (ByteString -> IO (Either GRPCIOError ()))
-> IO (MetadataMap, StatusCode, StatusDetails)
forall a b.
(Message a, Message b) =>
ServerWriterHandler a b -> ServerWriterHandlerLL
convertServerWriterHandler

    bdHandler :: (Message a, Message b) => U.ServerCall -> ServerRWHandler a b -> IO ()
    bdHandler :: ServerCall -> ServerRWHandler a b -> IO ()
bdHandler ServerCall
sc = IO (Either GRPCIOError ()) -> IO ()
forall a. IO a -> IO ()
handleError (IO (Either GRPCIOError ()) -> IO ())
-> ((ServerCall ()
     -> StreamRecv a
     -> StreamSend b
     -> IO (MetadataMap, StatusCode, StatusDetails))
    -> IO (Either GRPCIOError ()))
-> (ServerCall ()
    -> StreamRecv a
    -> StreamSend b
    -> IO (MetadataMap, StatusCode, StatusDetails))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server
-> ServerCall
-> MetadataMap
-> ServerRWHandlerLL
-> IO (Either GRPCIOError ())
U.serverRW Server
s ServerCall
sc MetadataMap
md ((ServerCall ()
  -> IO (Either GRPCIOError (Maybe ByteString))
  -> (ByteString -> IO (Either GRPCIOError ()))
  -> IO (MetadataMap, StatusCode, StatusDetails))
 -> IO (Either GRPCIOError ()))
-> ((ServerCall ()
     -> StreamRecv a
     -> StreamSend b
     -> IO (MetadataMap, StatusCode, StatusDetails))
    -> ServerCall ()
    -> IO (Either GRPCIOError (Maybe ByteString))
    -> (ByteString -> IO (Either GRPCIOError ()))
    -> IO (MetadataMap, StatusCode, StatusDetails))
-> (ServerCall ()
    -> StreamRecv a
    -> StreamSend b
    -> IO (MetadataMap, StatusCode, StatusDetails))
-> IO (Either GRPCIOError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerCall ()
 -> StreamRecv a
 -> StreamSend b
 -> IO (MetadataMap, StatusCode, StatusDetails))
-> ServerCall ()
-> IO (Either GRPCIOError (Maybe ByteString))
-> (ByteString -> IO (Either GRPCIOError ()))
-> IO (MetadataMap, StatusCode, StatusDetails)
forall a b.
(Message a, Message b) =>
ServerRWHandler a b -> ServerRWHandlerLL
convertServerRWHandler

    unknownHandler :: U.ServerCall -> IO ()
    unknownHandler :: ServerCall -> IO ()
unknownHandler ServerCall
sc = IO (Either GRPCIOError ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either GRPCIOError ()) -> IO ())
-> IO (Either GRPCIOError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Server
-> ServerCall
-> MetadataMap
-> ServerHandler
-> IO (Either GRPCIOError ())
U.serverHandleNormalCall' Server
s ServerCall
sc MetadataMap
md (ServerHandler -> IO (Either GRPCIOError ()))
-> ServerHandler -> IO (Either GRPCIOError ())
forall a b. (a -> b) -> a -> b
$ \ServerCall
_ ByteString
_ ->
      (ByteString, MetadataMap, StatusCode, StatusDetails)
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
forall a. Monoid a => a
mempty, MetadataMap
forall a. Monoid a => a
mempty, StatusCode
StatusNotFound, ByteString -> StatusDetails
StatusDetails ByteString
"unknown method")

    handleError :: IO a -> IO ()
    handleError :: IO a -> IO ()
handleError = ((String -> IO ()) -> Either GRPCIOError a -> IO ()
forall a. (String -> IO ()) -> Either GRPCIOError a -> IO ()
handleCallError String -> IO ()
logger (Either GRPCIOError a -> IO ())
-> (Either SomeException a -> Either GRPCIOError a)
-> Either SomeException a
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> GRPCIOError)
-> Either SomeException a -> Either GRPCIOError a
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left SomeException -> GRPCIOError
herr (Either SomeException a -> IO ())
-> IO (Either SomeException a) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO (Either SomeException a) -> IO ())
-> (IO a -> IO (Either SomeException a)) -> IO a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
CE.try
      where herr :: SomeException -> GRPCIOError
herr (SomeException
e :: CE.SomeException) = String -> GRPCIOError
GRPCIOHandlerException (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)

serverLoop :: ServerOptions -> IO ()
serverLoop :: ServerOptions -> IO ()
serverLoop ServerOptions{Bool
String
[Handler 'BiDiStreaming]
[Handler 'ServerStreaming]
[Handler 'ClientStreaming]
[Handler 'Normal]
Maybe Natural
Maybe ServerSSLConfig
Host
Port
MetadataMap
String -> IO ()
optMaxReceiveMessageLength :: ServerOptions -> Maybe Natural
optLogger :: ServerOptions -> String -> IO ()
optSSLConfig :: ServerOptions -> Maybe ServerSSLConfig
optInitialMetadata :: ServerOptions -> MetadataMap
optUserAgentSuffix :: ServerOptions -> String
optUserAgentPrefix :: ServerOptions -> String
optUseCompression :: ServerOptions -> Bool
optServerPort :: ServerOptions -> Port
optServerHost :: ServerOptions -> Host
optBiDiStreamHandlers :: ServerOptions -> [Handler 'BiDiStreaming]
optServerStreamHandlers :: ServerOptions -> [Handler 'ServerStreaming]
optClientStreamHandlers :: ServerOptions -> [Handler 'ClientStreaming]
optNormalHandlers :: ServerOptions -> [Handler 'Normal]
optMaxReceiveMessageLength :: Maybe Natural
optLogger :: String -> IO ()
optSSLConfig :: Maybe ServerSSLConfig
optInitialMetadata :: MetadataMap
optUserAgentSuffix :: String
optUserAgentPrefix :: String
optUseCompression :: Bool
optServerPort :: Port
optServerHost :: Host
optBiDiStreamHandlers :: [Handler 'BiDiStreaming]
optServerStreamHandlers :: [Handler 'ServerStreaming]
optClientStreamHandlers :: [Handler 'ClientStreaming]
optNormalHandlers :: [Handler 'Normal]
..} =
  -- In the GRPC library, "doc/core/epoll-polling-engine.md" seems
  -- to indicate that the thread which actually awakens from sleep
  -- on file descriptor events may differ from the one which seeks
  -- to "pluck" the resulting event.
  --
  -- Thus it seems possible that "dispatchLoop" may be waiting on
  -- a condition variable when the "serverLoop" thread is killed.
  --
  -- Note that "pthread_cond_timedwait" never returns EINTR; see:
  -- <https://pubs.opengroup.org/onlinepubs/7908799/xsh/pthread_cond_wait.html>
  --
  -- Therefore to awaken "dispatchLoop" we must initiate a GRPC
  -- shutdown; it would not suffice to kill its Haskell thread.
  -- (Presumably a GRPC shutdown broadcasts on relvant condition
  -- variables; regardless, we do see it awaken "dispatchLoop".)
  --
  -- The "withServer" cleanup code will initiate a GRPC shutdown.
  -- We arrange to trigger it by leaving the "serverLoop" thread
  -- in an interruptible sleep ("takeMVar") while "dispatchLoop"
  -- runs in its own thread.
  (GRPC -> IO ()) -> IO ()
forall a. (GRPC -> IO a) -> IO a
withGRPC ((GRPC -> IO ()) -> IO ()) -> (GRPC -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GRPC
grpc ->
    GRPC -> ServerConfig -> (Server -> IO ()) -> IO ()
forall a. GRPC -> ServerConfig -> (Server -> IO a) -> IO a
withServer GRPC
grpc ServerConfig
config ((Server -> IO ()) -> IO ()) -> (Server -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server
server -> do
      -- Killing the "serverLoop" thread triggers the "withServer"
      -- cleanup code, which initiates a shutdown, which in turn
      -- kills the "dispatchLoop" thread and any other thread we
      -- may have started with "forkServer".
      MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
      Bool
launched <- Server -> IO () -> IO Bool
forkServer Server
server (IO () -> IO Bool) -> IO () -> IO Bool
forall a b. (a -> b) -> a -> b
$
        Server
-> (String -> IO ())
-> MetadataMap
-> [Handler 'Normal]
-> [Handler 'ClientStreaming]
-> [Handler 'ServerStreaming]
-> [Handler 'BiDiStreaming]
-> IO ()
dispatchLoop Server
server
                     String -> IO ()
optLogger
                     MetadataMap
optInitialMetadata
                     [Handler 'Normal]
optNormalHandlers
                     [Handler 'ClientStreaming]
optClientStreamHandlers
                     [Handler 'ServerStreaming]
optServerStreamHandlers
                     [Handler 'BiDiStreaming]
optBiDiStreamHandlers
        IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`CE.finally` MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
launched (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done
  where
    config :: ServerConfig
config = ServerConfig :: Host
-> Port
-> [MethodName]
-> [MethodName]
-> [MethodName]
-> [MethodName]
-> [Arg]
-> Maybe ServerSSLConfig
-> ServerConfig
ServerConfig
      { host :: Host
host                             = Host
optServerHost
      , port :: Port
port                             = Port
optServerPort
      , methodsToRegisterNormal :: [MethodName]
methodsToRegisterNormal          = []
      , methodsToRegisterClientStreaming :: [MethodName]
methodsToRegisterClientStreaming = []
      , methodsToRegisterServerStreaming :: [MethodName]
methodsToRegisterServerStreaming = []
      , methodsToRegisterBiDiStreaming :: [MethodName]
methodsToRegisterBiDiStreaming   = []
      , serverArgs :: [Arg]
serverArgs                       =
          [CompressionAlgorithm -> Arg
CompressionAlgArg CompressionAlgorithm
GrpcCompressDeflate | Bool
optUseCompression]
          [Arg] -> [Arg] -> [Arg]
forall a. [a] -> [a] -> [a]
++
          [ String -> Arg
UserAgentPrefix String
optUserAgentPrefix
          , String -> Arg
UserAgentSuffix String
optUserAgentSuffix
          ]
          [Arg] -> [Arg] -> [Arg]
forall a. [a] -> [a] -> [a]
++
          (Natural -> [Arg]) -> Maybe Natural -> [Arg]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Arg -> [Arg]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arg -> [Arg]) -> (Natural -> Arg) -> Natural -> [Arg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Arg
MaxReceiveMessageLength) Maybe Natural
optMaxReceiveMessageLength
      , sslConfig :: Maybe ServerSSLConfig
sslConfig = Maybe ServerSSLConfig
optSSLConfig
      }