{-# 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]
..} =
(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
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
}