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

module Network.GRPC.HighLevel.Server where

import qualified Control.Exception                         as CE
import           Control.Monad
import           Data.ByteString                           (ByteString)
import qualified Data.ByteString.Lazy                      as BL
import           Network.GRPC.LowLevel
import           Numeric.Natural
import           Proto3.Suite.Class
import           System.IO

type ServerCallMetadata = ServerCall ()

type ServiceServer service = service ServerRequest ServerResponse

data ServerRequest (streamType :: GRPCMethodType) request response where
  ServerNormalRequest :: ServerCallMetadata -> request -> ServerRequest 'Normal request response
  ServerReaderRequest :: ServerCallMetadata -> StreamRecv request -> ServerRequest 'ClientStreaming request response
  ServerWriterRequest :: ServerCallMetadata -> request -> StreamSend response -> ServerRequest 'ServerStreaming request response
  ServerBiDiRequest :: ServerCallMetadata -> StreamRecv request -> StreamSend response -> ServerRequest 'BiDiStreaming request response

data ServerResponse (streamType :: GRPCMethodType) response where
  ServerNormalResponse :: response -> MetadataMap -> StatusCode -> StatusDetails
                       -> ServerResponse 'Normal response
  ServerReaderResponse :: Maybe response -> MetadataMap -> StatusCode -> StatusDetails
                       -> ServerResponse 'ClientStreaming response
  ServerWriterResponse :: MetadataMap -> StatusCode -> StatusDetails
                       -> ServerResponse 'ServerStreaming response
  ServerBiDiResponse :: MetadataMap -> StatusCode -> StatusDetails
                     -> ServerResponse 'BiDiStreaming response

type ServerHandler a b =
  ServerCall a
  -> IO (b, MetadataMap, StatusCode, StatusDetails)

convertGeneratedServerHandler ::
  (ServerRequest 'Normal request response -> IO (ServerResponse 'Normal response))
  -> ServerHandler request response
convertGeneratedServerHandler :: (ServerRequest 'Normal request response
 -> IO (ServerResponse 'Normal response))
-> ServerHandler request response
convertGeneratedServerHandler ServerRequest 'Normal request response
-> IO (ServerResponse 'Normal response)
handler ServerCall request
call =
  do let call' :: ServerCall ()
call' = ServerCall request
call { payload :: ()
payload = () }
     ServerNormalResponse response
rsp MetadataMap
meta StatusCode
stsCode StatusDetails
stsDetails <-
       ServerRequest 'Normal request response
-> IO (ServerResponse 'Normal response)
handler (ServerCall () -> request -> ServerRequest 'Normal request response
forall request response.
ServerCall () -> request -> ServerRequest 'Normal request response
ServerNormalRequest ServerCall ()
call' (ServerCall request -> request
forall a. ServerCall a -> a
payload ServerCall request
call))
     (response, MetadataMap, StatusCode, StatusDetails)
-> IO (response, MetadataMap, StatusCode, StatusDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (response
rsp, MetadataMap
meta, StatusCode
stsCode, StatusDetails
stsDetails)

convertServerHandler :: (Message a, Message b)
                     => ServerHandler a b
                     -> ServerHandlerLL
convertServerHandler :: ServerHandler a b -> ServerHandlerLL
convertServerHandler ServerHandler a b
f ServerCall (MethodPayload 'Normal)
c = case ByteString -> Either ParseError a
forall a. Message a => ByteString -> Either ParseError a
fromByteString (ServerCall ByteString -> ByteString
forall a. ServerCall a -> a
payload ServerCall ByteString
ServerCall (MethodPayload 'Normal)
c) of
  Left ParseError
x  -> GRPCIOError
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
forall a e. Exception e => e -> a
CE.throw (String -> GRPCIOError
GRPCIODecodeError (String -> GRPCIOError) -> String -> GRPCIOError
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
x)
  Right a
x -> do (b
y, MetadataMap
tm, StatusCode
sc, StatusDetails
sd) <- ServerHandler a b
f ((ByteString -> a) -> ServerCall ByteString -> ServerCall a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> ByteString -> a
forall a b. a -> b -> a
const a
x) ServerCall ByteString
ServerCall (MethodPayload 'Normal)
c)
                (ByteString, MetadataMap, StatusCode, StatusDetails)
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ByteString
forall a. Message a => a -> ByteString
toBS b
y, MetadataMap
tm, StatusCode
sc, StatusDetails
sd)

type ServerReaderHandler a b
  =  ServerCall (MethodPayload 'ClientStreaming)
  -> StreamRecv a
  -> IO (Maybe b, MetadataMap, StatusCode, StatusDetails)

convertGeneratedServerReaderHandler ::
  (ServerRequest 'ClientStreaming request response -> IO (ServerResponse 'ClientStreaming response))
  -> ServerReaderHandler request response
convertGeneratedServerReaderHandler :: (ServerRequest 'ClientStreaming request response
 -> IO (ServerResponse 'ClientStreaming response))
-> ServerReaderHandler request response
convertGeneratedServerReaderHandler ServerRequest 'ClientStreaming request response
-> IO (ServerResponse 'ClientStreaming response)
handler ServerCall (MethodPayload 'ClientStreaming)
call StreamRecv request
recv =
  do ServerReaderResponse Maybe response
rsp MetadataMap
meta StatusCode
stsCode StatusDetails
stsDetails <-
       ServerRequest 'ClientStreaming request response
-> IO (ServerResponse 'ClientStreaming response)
handler (ServerCall ()
-> StreamRecv request
-> ServerRequest 'ClientStreaming request response
forall request response.
ServerCall ()
-> StreamRecv request
-> ServerRequest 'ClientStreaming request response
ServerReaderRequest ServerCall ()
ServerCall (MethodPayload 'ClientStreaming)
call StreamRecv request
recv)
     (Maybe response, MetadataMap, StatusCode, StatusDetails)
-> IO (Maybe response, MetadataMap, StatusCode, StatusDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe response
rsp, MetadataMap
meta, StatusCode
stsCode, StatusDetails
stsDetails)

convertServerReaderHandler :: (Message a, Message b)
                           => ServerReaderHandler a b
                           -> ServerReaderHandlerLL
convertServerReaderHandler :: ServerReaderHandler a b -> ServerReaderHandlerLL
convertServerReaderHandler ServerReaderHandler a b
f ServerCall (MethodPayload 'ClientStreaming)
c StreamRecv ByteString
recv =
  (Maybe b, MetadataMap, StatusCode, StatusDetails)
-> (Maybe ByteString, MetadataMap, StatusCode, StatusDetails)
forall (f :: * -> *) a b c d.
(Functor f, Message a) =>
(f a, b, c, d) -> (f ByteString, b, c, d)
serialize ((Maybe b, MetadataMap, StatusCode, StatusDetails)
 -> (Maybe ByteString, MetadataMap, StatusCode, StatusDetails))
-> IO (Maybe b, MetadataMap, StatusCode, StatusDetails)
-> IO (Maybe ByteString, MetadataMap, StatusCode, StatusDetails)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerReaderHandler a b
f ServerCall (MethodPayload 'ClientStreaming)
c (StreamRecv ByteString -> StreamRecv a
forall a. Message a => StreamRecv ByteString -> StreamRecv a
convertRecv StreamRecv ByteString
recv)
  where
    serialize :: (f a, b, c, d) -> (f ByteString, b, c, d)
serialize (f a
mmsg, b
m, c
sc, d
sd) = (a -> ByteString
forall a. Message a => a -> ByteString
toBS (a -> ByteString) -> f a -> f ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
mmsg, b
m, c
sc, d
sd)

type ServerWriterHandler a b =
     ServerCall a
  -> StreamSend b
  -> IO (MetadataMap, StatusCode, StatusDetails)

convertGeneratedServerWriterHandler ::
  (ServerRequest 'ServerStreaming request response -> IO (ServerResponse 'ServerStreaming response))
  -> ServerWriterHandler request response
convertGeneratedServerWriterHandler :: (ServerRequest 'ServerStreaming request response
 -> IO (ServerResponse 'ServerStreaming response))
-> ServerWriterHandler request response
convertGeneratedServerWriterHandler ServerRequest 'ServerStreaming request response
-> IO (ServerResponse 'ServerStreaming response)
handler ServerCall request
call StreamSend response
send =
  do let call' :: ServerCall ()
call' = ServerCall request
call { payload :: ()
payload = () }
     ServerWriterResponse MetadataMap
meta StatusCode
stsCode StatusDetails
stsDetails <-
       ServerRequest 'ServerStreaming request response
-> IO (ServerResponse 'ServerStreaming response)
handler (ServerCall ()
-> request
-> StreamSend response
-> ServerRequest 'ServerStreaming request response
forall request response.
ServerCall ()
-> request
-> StreamSend response
-> ServerRequest 'ServerStreaming request response
ServerWriterRequest ServerCall ()
call' (ServerCall request -> request
forall a. ServerCall a -> a
payload ServerCall request
call) StreamSend response
send)
     (MetadataMap, StatusCode, StatusDetails)
-> IO (MetadataMap, StatusCode, StatusDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (MetadataMap
meta, StatusCode
stsCode, StatusDetails
stsDetails)

convertServerWriterHandler :: (Message a, Message b) =>
                              ServerWriterHandler a b
                              -> ServerWriterHandlerLL
convertServerWriterHandler :: ServerWriterHandler a b -> ServerWriterHandlerLL
convertServerWriterHandler ServerWriterHandler a b
f ServerCall (MethodPayload 'ServerStreaming)
c StreamSend ByteString
send =
  ServerWriterHandler a b
f (ByteString -> a
forall p. Message p => ByteString -> p
convert (ByteString -> a) -> ServerCall ByteString -> ServerCall a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerCall ByteString
ServerCall (MethodPayload 'ServerStreaming)
c) (StreamSend ByteString -> StreamSend b
forall a. Message a => StreamSend ByteString -> StreamSend a
convertSend StreamSend ByteString
send)
  where
    convert :: ByteString -> p
convert ByteString
bs = case ByteString -> Either ParseError p
forall a. Message a => ByteString -> Either ParseError a
fromByteString ByteString
bs of
      Left ParseError
x  -> GRPCIOError -> p
forall a e. Exception e => e -> a
CE.throw (String -> GRPCIOError
GRPCIODecodeError (String -> GRPCIOError) -> String -> GRPCIOError
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
x)
      Right p
x -> p
x

type ServerRWHandler a b
  =  ServerCall (MethodPayload 'BiDiStreaming)
  -> StreamRecv a
  -> StreamSend b
  -> IO (MetadataMap, StatusCode, StatusDetails)

convertGeneratedServerRWHandler ::
  (ServerRequest 'BiDiStreaming request response -> IO (ServerResponse 'BiDiStreaming response))
  -> ServerRWHandler request response
convertGeneratedServerRWHandler :: (ServerRequest 'BiDiStreaming request response
 -> IO (ServerResponse 'BiDiStreaming response))
-> ServerRWHandler request response
convertGeneratedServerRWHandler ServerRequest 'BiDiStreaming request response
-> IO (ServerResponse 'BiDiStreaming response)
handler ServerCall (MethodPayload 'BiDiStreaming)
call StreamRecv request
recv StreamSend response
send =
  do ServerBiDiResponse MetadataMap
meta StatusCode
stsCode StatusDetails
stsDetails <-
       ServerRequest 'BiDiStreaming request response
-> IO (ServerResponse 'BiDiStreaming response)
handler (ServerCall ()
-> StreamRecv request
-> StreamSend response
-> ServerRequest 'BiDiStreaming request response
forall request response.
ServerCall ()
-> StreamRecv request
-> StreamSend response
-> ServerRequest 'BiDiStreaming request response
ServerBiDiRequest ServerCall ()
ServerCall (MethodPayload 'BiDiStreaming)
call StreamRecv request
recv StreamSend response
send)
     (MetadataMap, StatusCode, StatusDetails)
-> IO (MetadataMap, StatusCode, StatusDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (MetadataMap
meta, StatusCode
stsCode, StatusDetails
stsDetails)

convertServerRWHandler :: (Message a, Message b)
                       => ServerRWHandler a b
                       -> ServerRWHandlerLL
convertServerRWHandler :: ServerRWHandler a b -> ServerRWHandlerLL
convertServerRWHandler ServerRWHandler a b
f ServerCall (MethodPayload 'BiDiStreaming)
c StreamRecv ByteString
recv StreamSend ByteString
send =
  ServerRWHandler a b
f ServerCall (MethodPayload 'BiDiStreaming)
c (StreamRecv ByteString -> StreamRecv a
forall a. Message a => StreamRecv ByteString -> StreamRecv a
convertRecv StreamRecv ByteString
recv) (StreamSend ByteString -> StreamSend b
forall a. Message a => StreamSend ByteString -> StreamSend a
convertSend StreamSend ByteString
send)

convertRecv :: Message a => StreamRecv ByteString -> StreamRecv a
convertRecv :: StreamRecv ByteString -> StreamRecv a
convertRecv =
  (Either GRPCIOError (Maybe ByteString)
 -> Either GRPCIOError (Maybe a))
-> StreamRecv ByteString -> StreamRecv a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either GRPCIOError (Maybe ByteString)
  -> Either GRPCIOError (Maybe a))
 -> StreamRecv ByteString -> StreamRecv a)
-> (Either GRPCIOError (Maybe ByteString)
    -> Either GRPCIOError (Maybe a))
-> StreamRecv ByteString
-> StreamRecv a
forall a b. (a -> b) -> a -> b
$ \Either GRPCIOError (Maybe ByteString)
e -> do
    Maybe ByteString
msg <- Either GRPCIOError (Maybe ByteString)
e
    case Maybe ByteString
msg of
      Maybe ByteString
Nothing -> Maybe a -> Either GRPCIOError (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
      Just ByteString
bs -> case ByteString -> Either ParseError a
forall a. Message a => ByteString -> Either ParseError a
fromByteString ByteString
bs of
                   Left ParseError
x  -> GRPCIOError -> Either GRPCIOError (Maybe a)
forall a b. a -> Either a b
Left (String -> GRPCIOError
GRPCIODecodeError (String -> GRPCIOError) -> String -> GRPCIOError
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
x)
                   Right a
x -> Maybe a -> Either GRPCIOError (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)

convertSend :: Message a => StreamSend ByteString -> StreamSend a
convertSend :: StreamSend ByteString -> StreamSend a
convertSend StreamSend ByteString
s = StreamSend ByteString
s StreamSend ByteString -> (a -> ByteString) -> StreamSend a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Message a => a -> ByteString
toBS

toBS :: Message a => a -> ByteString
toBS :: a -> ByteString
toBS = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Message a => a -> ByteString
toLazyByteString

data Handler (a :: GRPCMethodType) where
  UnaryHandler        :: (Message c, Message d) => MethodName -> ServerHandler c d       -> Handler 'Normal
  ClientStreamHandler :: (Message c, Message d) => MethodName -> ServerReaderHandler c d -> Handler 'ClientStreaming
  ServerStreamHandler :: (Message c, Message d) => MethodName -> ServerWriterHandler c d -> Handler 'ServerStreaming
  BiDiStreamHandler   :: (Message c, Message d) => MethodName -> ServerRWHandler c d     -> Handler 'BiDiStreaming

data AnyHandler = forall (a :: GRPCMethodType). AnyHandler (Handler a)

anyHandlerMethodName :: AnyHandler -> MethodName
anyHandlerMethodName :: AnyHandler -> MethodName
anyHandlerMethodName (AnyHandler Handler a
m) = Handler a -> MethodName
forall (a :: GRPCMethodType). Handler a -> MethodName
handlerMethodName Handler a
m

handlerMethodName :: Handler a -> MethodName
handlerMethodName :: Handler a -> MethodName
handlerMethodName (UnaryHandler MethodName
m ServerHandler c d
_)        = MethodName
m
handlerMethodName (ClientStreamHandler MethodName
m ServerReaderHandler c d
_) = MethodName
m
handlerMethodName (ServerStreamHandler MethodName
m ServerWriterHandler c d
_) = MethodName
m
handlerMethodName (BiDiStreamHandler MethodName
m ServerRWHandler c d
_)   = MethodName
m

-- | Handles errors that result from trying to handle a call on the server.
-- For each error, takes a different action depending on the severity in the
-- context of handling a server call. This also tries to give an indication of
-- whether the error is our fault or user error.
handleCallError :: (String -> IO ())
                   -- ^ logging function
                   -> Either GRPCIOError a
                   -> IO ()
handleCallError :: (String -> IO ()) -> Either GRPCIOError a -> IO ()
handleCallError String -> IO ()
_ (Right a
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleCallError String -> IO ()
_ (Left GRPCIOError
GRPCIOTimeout) =
  -- Probably a benign timeout (such as a client disappearing), noop for now.
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleCallError String -> IO ()
_ (Left GRPCIOError
GRPCIOShutdown) =
  -- Server shutting down. Benign.
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleCallError String -> IO ()
logMsg (Left (GRPCIODecodeError String
e)) =
  String -> IO ()
logMsg (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Decoding error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
e
handleCallError String -> IO ()
logMsg (Left (GRPCIOHandlerException String
e)) =
  String -> IO ()
logMsg (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Handler exception caught: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
e
handleCallError String -> IO ()
logMsg (Left GRPCIOError
x) =
  String -> IO ()
logMsg (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ GRPCIOError -> String
forall a. Show a => a -> String
show GRPCIOError
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": This probably indicates a bug in gRPC-haskell. Please report this error."

loopWError :: Int
           -> ServerOptions
           -> IO (Either GRPCIOError a)
           -> IO ()
loopWError :: Int -> ServerOptions -> IO (Either GRPCIOError a) -> IO ()
loopWError Int
i o :: ServerOptions
o@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]
..} IO (Either GRPCIOError a)
f = do
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
100 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"i = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
   IO (Either GRPCIOError a)
f IO (Either GRPCIOError a)
-> (Either GRPCIOError a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO ()) -> Either GRPCIOError a -> IO ()
forall a. (String -> IO ()) -> Either GRPCIOError a -> IO ()
handleCallError String -> IO ()
optLogger
   Int -> ServerOptions -> IO (Either GRPCIOError a) -> IO ()
forall a.
Int -> ServerOptions -> IO (Either GRPCIOError a) -> IO ()
loopWError (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ServerOptions
o IO (Either GRPCIOError a)
f

-- TODO: options for setting initial/trailing metadata
handleLoop :: Server
           -> ServerOptions
           -> (Handler a, RegisteredMethod a)
           -> IO ()
handleLoop :: Server -> ServerOptions -> (Handler a, RegisteredMethod a) -> IO ()
handleLoop Server
s ServerOptions
o (UnaryHandler MethodName
_ ServerHandler c d
f, RegisteredMethod a
rm) =
  Int -> ServerOptions -> IO (Either GRPCIOError ()) -> IO ()
forall a.
Int -> ServerOptions -> IO (Either GRPCIOError a) -> IO ()
loopWError Int
0 ServerOptions
o (IO (Either GRPCIOError ()) -> IO ())
-> IO (Either GRPCIOError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Server
-> RegisteredMethod 'Normal
-> MetadataMap
-> ServerHandlerLL
-> IO (Either GRPCIOError ())
serverHandleNormalCall Server
s RegisteredMethod a
RegisteredMethod 'Normal
rm MetadataMap
forall a. Monoid a => a
mempty (ServerHandlerLL -> IO (Either GRPCIOError ()))
-> ServerHandlerLL -> IO (Either GRPCIOError ())
forall a b. (a -> b) -> a -> b
$ ServerHandler c d -> ServerHandlerLL
forall a b.
(Message a, Message b) =>
ServerHandler a b -> ServerHandlerLL
convertServerHandler ServerHandler c d
f
handleLoop Server
s ServerOptions
o (ClientStreamHandler MethodName
_ ServerReaderHandler c d
f, RegisteredMethod a
rm) =
  Int -> ServerOptions -> IO (Either GRPCIOError ()) -> IO ()
forall a.
Int -> ServerOptions -> IO (Either GRPCIOError a) -> IO ()
loopWError Int
0 ServerOptions
o (IO (Either GRPCIOError ()) -> IO ())
-> IO (Either GRPCIOError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Server
-> RegisteredMethod 'ClientStreaming
-> MetadataMap
-> ServerReaderHandlerLL
-> IO (Either GRPCIOError ())
serverReader Server
s RegisteredMethod a
RegisteredMethod 'ClientStreaming
rm MetadataMap
forall a. Monoid a => a
mempty (ServerReaderHandlerLL -> IO (Either GRPCIOError ()))
-> ServerReaderHandlerLL -> IO (Either GRPCIOError ())
forall a b. (a -> b) -> a -> b
$ ServerReaderHandler c d -> ServerReaderHandlerLL
forall a b.
(Message a, Message b) =>
ServerReaderHandler a b -> ServerReaderHandlerLL
convertServerReaderHandler ServerReaderHandler c d
f
handleLoop Server
s ServerOptions
o (ServerStreamHandler MethodName
_ ServerWriterHandler c d
f, RegisteredMethod a
rm) =
  Int -> ServerOptions -> IO (Either GRPCIOError ()) -> IO ()
forall a.
Int -> ServerOptions -> IO (Either GRPCIOError a) -> IO ()
loopWError Int
0 ServerOptions
o (IO (Either GRPCIOError ()) -> IO ())
-> IO (Either GRPCIOError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Server
-> RegisteredMethod 'ServerStreaming
-> MetadataMap
-> ServerWriterHandlerLL
-> IO (Either GRPCIOError ())
serverWriter Server
s RegisteredMethod a
RegisteredMethod 'ServerStreaming
rm MetadataMap
forall a. Monoid a => a
mempty (ServerWriterHandlerLL -> IO (Either GRPCIOError ()))
-> ServerWriterHandlerLL -> IO (Either GRPCIOError ())
forall a b. (a -> b) -> a -> b
$ ServerWriterHandler c d -> ServerWriterHandlerLL
forall a b.
(Message a, Message b) =>
ServerWriterHandler a b -> ServerWriterHandlerLL
convertServerWriterHandler ServerWriterHandler c d
f
handleLoop Server
s ServerOptions
o (BiDiStreamHandler MethodName
_ ServerRWHandler c d
f, RegisteredMethod a
rm) =
  Int -> ServerOptions -> IO (Either GRPCIOError ()) -> IO ()
forall a.
Int -> ServerOptions -> IO (Either GRPCIOError a) -> IO ()
loopWError Int
0 ServerOptions
o (IO (Either GRPCIOError ()) -> IO ())
-> IO (Either GRPCIOError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Server
-> RegisteredMethod 'BiDiStreaming
-> MetadataMap
-> ServerRWHandlerLL
-> IO (Either GRPCIOError ())
serverRW Server
s RegisteredMethod a
RegisteredMethod 'BiDiStreaming
rm MetadataMap
forall a. Monoid a => a
mempty (ServerRWHandlerLL -> IO (Either GRPCIOError ()))
-> ServerRWHandlerLL -> IO (Either GRPCIOError ())
forall a b. (a -> b) -> a -> b
$ ServerRWHandler c d -> ServerRWHandlerLL
forall a b.
(Message a, Message b) =>
ServerRWHandler a b -> ServerRWHandlerLL
convertServerRWHandler ServerRWHandler c d
f

data ServerOptions = ServerOptions
  { ServerOptions -> [Handler 'Normal]
optNormalHandlers       :: [Handler 'Normal]
    -- ^ Handlers for unary (non-streaming) calls.
  , ServerOptions -> [Handler 'ClientStreaming]
optClientStreamHandlers :: [Handler 'ClientStreaming]
    -- ^ Handlers for client streaming calls.
  , ServerOptions -> [Handler 'ServerStreaming]
optServerStreamHandlers :: [Handler 'ServerStreaming]
    -- ^ Handlers for server streaming calls.
  , ServerOptions -> [Handler 'BiDiStreaming]
optBiDiStreamHandlers   :: [Handler 'BiDiStreaming]
    -- ^ Handlers for bidirectional streaming calls.
  , ServerOptions -> Host
optServerHost           :: Host
    -- ^ Name of the host the server is running on.
  , ServerOptions -> Port
optServerPort           :: Port
    -- ^ Port on which to listen for requests.
  , ServerOptions -> Bool
optUseCompression       :: Bool
    -- ^ Whether to use compression when communicating with the client.
  , ServerOptions -> String
optUserAgentPrefix      :: String
    -- ^ Optional custom prefix to add to the user agent string.
  , ServerOptions -> String
optUserAgentSuffix      :: String
    -- ^ Optional custom suffix to add to the user agent string.
  , ServerOptions -> MetadataMap
optInitialMetadata      :: MetadataMap
    -- ^ Metadata to send at the beginning of each call.
  , ServerOptions -> Maybe ServerSSLConfig
optSSLConfig            :: Maybe ServerSSLConfig
    -- ^ Security configuration.
  , ServerOptions -> String -> IO ()
optLogger               :: String -> IO ()
    -- ^ Logging function to use to log errors in handling calls.
  , ServerOptions -> Maybe Natural
optMaxReceiveMessageLength :: Maybe Natural
  }

defaultOptions :: ServerOptions
defaultOptions :: ServerOptions
defaultOptions = ServerOptions :: [Handler 'Normal]
-> [Handler 'ClientStreaming]
-> [Handler 'ServerStreaming]
-> [Handler 'BiDiStreaming]
-> Host
-> Port
-> Bool
-> String
-> String
-> MetadataMap
-> Maybe ServerSSLConfig
-> (String -> IO ())
-> Maybe Natural
-> ServerOptions
ServerOptions
  { optNormalHandlers :: [Handler 'Normal]
optNormalHandlers       = []
  , optClientStreamHandlers :: [Handler 'ClientStreaming]
optClientStreamHandlers = []
  , optServerStreamHandlers :: [Handler 'ServerStreaming]
optServerStreamHandlers = []
  , optBiDiStreamHandlers :: [Handler 'BiDiStreaming]
optBiDiStreamHandlers   = []
  , optServerHost :: Host
optServerHost           = Host
"localhost"
  , optServerPort :: Port
optServerPort           = Port
50051
  , optUseCompression :: Bool
optUseCompression       = Bool
False
  , optUserAgentPrefix :: String
optUserAgentPrefix      = String
"grpc-haskell/0.0.0"
  , optUserAgentSuffix :: String
optUserAgentSuffix      = String
""
  , optInitialMetadata :: MetadataMap
optInitialMetadata      = MetadataMap
forall a. Monoid a => a
mempty
  , optSSLConfig :: Maybe ServerSSLConfig
optSSLConfig            = Maybe ServerSSLConfig
forall a. Maybe a
Nothing
  , optLogger :: String -> IO ()
optLogger               = Handle -> String -> IO ()
hPutStrLn Handle
stderr
  , optMaxReceiveMessageLength :: Maybe Natural
optMaxReceiveMessageLength = Maybe Natural
forall a. Maybe a
Nothing
  }

serverLoop :: ServerOptions -> IO ()
serverLoop :: ServerOptions -> IO ()
serverLoop ServerOptions
_opts = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Registered method-based serverLoop NYI"
{-
  withGRPC $ \grpc ->
    withServer grpc (mkConfig opts) $ \server -> do
      let rmsN = zip (optNormalHandlers opts) $ normalMethods server
      let rmsCS = zip (optClientStreamHandlers opts) $ cstreamingMethods server
      let rmsSS = zip (optServerStreamHandlers opts) $ sstreamingMethods server
      let rmsB = zip (optBiDiStreamHandlers opts) $ bidiStreamingMethods server
      --TODO: Perhaps assert that no methods disappeared after registration.
      let loop :: forall a. (Handler a, RegisteredMethod a) -> IO ()
          loop = handleLoop server
      asyncsN <- mapM async $ map loop rmsN
      asyncsCS <- mapM async $ map loop rmsCS
      asyncsSS <- mapM async $ map loop rmsSS
      asyncsB <- mapM async $ map loop rmsB
      asyncUnk <- async $ loopWError 0 $ unknownHandler server
      waitAnyCancel $ asyncUnk : asyncsN ++ asyncsCS ++ asyncsSS ++ asyncsB
      return ()
  where
    mkConfig ServerOptions{..} =
      ServerConfig
        {  host = "localhost"
         , port = optServerPort
         , methodsToRegisterNormal = map handlerMethodName optNormalHandlers
         , methodsToRegisterClientStreaming =
             map handlerMethodName optClientStreamHandlers
         , methodsToRegisterServerStreaming =
             map handlerMethodName optServerStreamHandlers
         , methodsToRegisterBiDiStreaming =
             map handlerMethodName optBiDiStreamHandlers
         , serverArgs =
             ([CompressionAlgArg GrpcCompressDeflate | optUseCompression]
              ++
              [UserAgentPrefix optUserAgentPrefix
               , UserAgentSuffix optUserAgentSuffix])
        }
    unknownHandler s =
      --TODO: is this working?
      U.serverHandleNormalCall s mempty $ \call _ -> do
        logMsg $ "Requested unknown endpoint: " ++ show (U.callMethod call)
        return ("", mempty, StatusNotFound,
                StatusDetails "Unknown method")
-}