2016-07-27 00:21:35 +02:00
|
|
|
{-# LANGUAGE DataKinds #-}
|
|
|
|
{-# LANGUAGE GADTs #-}
|
|
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2016-07-14 18:53:28 +02:00
|
|
|
|
|
|
|
module Network.GRPC.HighLevel.Server.Unregistered where
|
|
|
|
|
2016-08-17 23:12:22 +02:00
|
|
|
import Control.Arrow
|
2016-07-27 00:48:25 +02:00
|
|
|
import Control.Concurrent
|
2016-07-28 01:50:48 +02:00
|
|
|
import Control.Concurrent.Async (async, wait)
|
2016-07-27 00:21:35 +02:00
|
|
|
import qualified Control.Exception as CE
|
2016-07-14 18:53:28 +02:00
|
|
|
import Control.Monad
|
|
|
|
import Data.Foldable (find)
|
2016-07-27 00:21:35 +02:00
|
|
|
import Data.Protobuf.Wire.Class
|
2016-07-14 18:53:28 +02:00
|
|
|
import Network.GRPC.HighLevel.Server
|
|
|
|
import Network.GRPC.LowLevel
|
2016-07-27 00:21:35 +02:00
|
|
|
import qualified Network.GRPC.LowLevel.Call.Unregistered as U
|
2016-07-14 18:53:28 +02:00
|
|
|
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
|
|
|
|
|
|
|
|
dispatchLoop :: Server
|
2016-08-17 23:12:22 +02:00
|
|
|
-> (String -> IO ())
|
2016-08-09 18:30:47 +02:00
|
|
|
-> MetadataMap
|
|
|
|
-> [Handler 'Normal]
|
|
|
|
-> [Handler 'ClientStreaming]
|
|
|
|
-> [Handler 'ServerStreaming]
|
|
|
|
-> [Handler 'BiDiStreaming]
|
|
|
|
-> IO ()
|
2016-08-17 23:12:22 +02:00
|
|
|
dispatchLoop s logger md hN hC hS hB =
|
2016-08-09 18:30:47 +02:00
|
|
|
forever $ U.withServerCallAsync s $ \sc ->
|
|
|
|
case findHandler sc allHandlers of
|
|
|
|
Just (AnyHandler ah) -> case ah of
|
|
|
|
UnaryHandler _ h -> unaryHandler sc h
|
|
|
|
ClientStreamHandler _ h -> csHandler sc h
|
|
|
|
ServerStreamHandler _ h -> ssHandler sc h
|
|
|
|
BiDiStreamHandler _ h -> bdHandler sc h
|
|
|
|
Nothing -> unknownHandler sc
|
|
|
|
where
|
|
|
|
allHandlers = map AnyHandler hN ++ map AnyHandler hC
|
|
|
|
++ map AnyHandler hS ++ map AnyHandler hB
|
|
|
|
|
|
|
|
findHandler sc = find ((== U.callMethod sc) . anyHandlerMethodName)
|
|
|
|
|
|
|
|
unaryHandler :: (Message a, Message b) => U.ServerCall -> ServerHandler a b -> IO ()
|
|
|
|
unaryHandler sc h =
|
|
|
|
handleError $
|
|
|
|
U.serverHandleNormalCall' s sc md $ \_sc' bs ->
|
|
|
|
convertServerHandler h (const bs <$> U.convertCall sc)
|
|
|
|
|
|
|
|
csHandler :: (Message a, Message b) => U.ServerCall -> ServerReaderHandler a b -> IO ()
|
|
|
|
csHandler sc = handleError . U.serverReader s sc md . convertServerReaderHandler
|
|
|
|
|
|
|
|
ssHandler :: (Message a, Message b) => U.ServerCall -> ServerWriterHandler a b -> IO ()
|
|
|
|
ssHandler sc = handleError . U.serverWriter s sc md . convertServerWriterHandler
|
|
|
|
|
|
|
|
bdHandler :: (Message a, Message b) => U.ServerCall -> ServerRWHandler a b -> IO ()
|
|
|
|
bdHandler sc = handleError . U.serverRW s sc md . convertServerRWHandler
|
2016-07-27 00:21:35 +02:00
|
|
|
|
2016-08-09 18:30:47 +02:00
|
|
|
unknownHandler :: U.ServerCall -> IO ()
|
|
|
|
unknownHandler sc = void $ U.serverHandleNormalCall' s sc md $ \_ _ ->
|
|
|
|
return (mempty, mempty, StatusNotFound, StatusDetails "unknown method")
|
2016-07-27 00:21:35 +02:00
|
|
|
|
2016-08-09 18:30:47 +02:00
|
|
|
handleError :: IO a -> IO ()
|
2016-08-17 23:12:22 +02:00
|
|
|
handleError = (handleCallError logger . left herr =<<) . CE.try
|
2016-08-09 18:30:47 +02:00
|
|
|
where herr (e :: CE.SomeException) = GRPCIOHandlerException (show e)
|
2016-07-14 18:53:28 +02:00
|
|
|
|
|
|
|
serverLoop :: ServerOptions -> IO ()
|
2016-07-28 01:50:48 +02:00
|
|
|
serverLoop ServerOptions{..} = do
|
2016-07-27 00:48:25 +02:00
|
|
|
-- We run the loop in a new thread so that we can kill the serverLoop thread.
|
|
|
|
-- Without this fork, we block on a foreign call, which can't be interrupted.
|
2016-07-28 01:50:48 +02:00
|
|
|
tid <- async $ withGRPC $ \grpc ->
|
2016-07-15 01:33:56 +02:00
|
|
|
withServer grpc config $ \server -> do
|
2016-07-14 18:53:28 +02:00
|
|
|
dispatchLoop server
|
2016-08-17 23:12:22 +02:00
|
|
|
optLogger
|
2016-07-26 22:16:44 +02:00
|
|
|
optInitialMetadata
|
2016-07-14 18:53:28 +02:00
|
|
|
optNormalHandlers
|
|
|
|
optClientStreamHandlers
|
|
|
|
optServerStreamHandlers
|
|
|
|
optBiDiStreamHandlers
|
2016-07-28 01:50:48 +02:00
|
|
|
wait tid
|
2016-07-14 18:53:28 +02:00
|
|
|
where
|
2016-08-09 18:30:47 +02:00
|
|
|
config = ServerConfig
|
2016-10-26 23:43:11 +02:00
|
|
|
{ host = optServerHost
|
2016-08-09 18:30:47 +02:00
|
|
|
, port = optServerPort
|
|
|
|
, methodsToRegisterNormal = []
|
|
|
|
, methodsToRegisterClientStreaming = []
|
|
|
|
, methodsToRegisterServerStreaming = []
|
|
|
|
, methodsToRegisterBiDiStreaming = []
|
|
|
|
, serverArgs =
|
|
|
|
[CompressionAlgArg GrpcCompressDeflate | optUseCompression]
|
|
|
|
++
|
|
|
|
[ UserAgentPrefix optUserAgentPrefix
|
|
|
|
, UserAgentSuffix optUserAgentSuffix
|
|
|
|
]
|
2016-08-17 18:55:06 +02:00
|
|
|
, sslConfig = optSSLConfig
|
2016-08-09 18:30:47 +02:00
|
|
|
}
|