├── Setup.hs ├── test └── Spec.hs ├── .gitignore ├── stack.yaml ├── ChangeLog.md ├── prepare.sh ├── package.yaml ├── src └── Network │ └── GRPC │ ├── Server │ ├── Helpers.hs │ ├── Wai.hs │ ├── Handlers.hs │ └── Handlers │ │ └── NoLens.hs │ └── Server.hs ├── LICENSE └── README.md /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | http2-server-grpc.cabal 3 | warp-grpc.cabal 4 | *~ 5 | stack.yaml.lock 6 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.7 2 | packages: 3 | - . 4 | extra-deps: 5 | - 'http2-grpc-types-0.4.0.0' 6 | - 'proto3-wire-1.0.0' 7 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for warp-grpc 2 | 3 | ## Unreleased changes 4 | 5 | ## 0.1.0.3 6 | 7 | Add bidirectional and general stream handlers. 8 | -------------------------------------------------------------------------------- /prepare.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | mkdir -p gen 4 | mkdir -p gen-bin 5 | mkdir -p protos 6 | 7 | curl 'https://raw.githubusercontent.com/moul/pb/master/grpcbin/grpcbin.proto' > protos/grpcbin.proto 8 | 9 | stack install --local-bin-path=gen-bin proto-lens-protoc 10 | 11 | protolens="`pwd`/gen-bin/proto-lens-protoc" 12 | 13 | if [ -x "${protolens}" ] 14 | then 15 | echo "using ${protolens}" ; 16 | else 17 | echo "no proto-lens-protoc" 18 | exit 2 19 | fi; 20 | 21 | protoc "--plugin=protoc-gen-haskell-protolens=${protolens}" \ 22 | --haskell-protolens_out=./gen \ 23 | ./protos/grpcbin.proto 24 | 25 | echo "# Generated modules:" 26 | find gen -name "*.hs" | sed -e 's/gen\///' | sed -e 's/\.hs$//' | tr '/' '.' 27 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: warp-grpc 2 | version: 0.1.0.4 3 | github: "lucasdicioccio/warp-grpc" 4 | license: BSD3 5 | author: "Lucas DiCioccio" 6 | maintainer: "lucas@dicioccio.fr" 7 | copyright: "2017 Lucas DiCioccio" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | synopsis: A minimal gRPC server on top of Warp. 14 | category: Networking 15 | 16 | description: Please see the README on Github at 17 | 18 | dependencies: 19 | - base >= 4.11 && < 5 20 | - async >= 2.2.1 && < 3 21 | - binary >= 0.8.5 && < 0.9 22 | - bytestring >= 0.10.8 && < 0.11 23 | - case-insensitive >= 1.2.0 && < 1.3 24 | - http2-grpc-types >= 0.3 && < 0.5 25 | - http-types >= 0.12 && < 0.13 26 | - proto-lens >= 0.3 && < 0.6 27 | - wai >= 3.2 && < 3.3 28 | - warp >= 3.2.24 && < 3.3 29 | - warp-tls >= 3.2 && < 3.3 30 | - proto3-wire >= 1 && < 1.1 31 | 32 | library: 33 | source-dirs: src 34 | -------------------------------------------------------------------------------- /src/Network/GRPC/Server/Helpers.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | module Network.GRPC.Server.Helpers where 4 | 5 | import qualified Data.ByteString.Char8 as ByteString 6 | import Data.Maybe (fromMaybe) 7 | import Network.GRPC.HTTP2.Types (GRPCStatus(..), trailerForStatusCode, grpcStatusH, grpcMessageH) 8 | import Network.Wai (Request) 9 | import Network.Wai.Handler.Warp (http2dataTrailers, defaultHTTP2Data, modifyHTTP2Data, HTTP2Data) 10 | 11 | -- | Helper to set the GRPCStatus on the trailers reply. 12 | modifyGRPCStatus :: Request -> GRPCStatus -> IO () 13 | modifyGRPCStatus req = modifyHTTP2Data req . makeGRPCTrailers 14 | 15 | makeGRPCTrailers :: GRPCStatus -> (Maybe HTTP2Data -> Maybe HTTP2Data) 16 | makeGRPCTrailers (GRPCStatus s msg) h2data = 17 | Just $! (fromMaybe defaultHTTP2Data h2data) { http2dataTrailers = trailers } 18 | where 19 | trailers = if ByteString.null msg then [status] else [status, message] 20 | status = (grpcStatusH, trailerForStatusCode s) 21 | message = (grpcMessageH, msg) 22 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Lucas DiCioccio (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Network/GRPC/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | module Network.GRPC.Server ( 8 | runGrpc 9 | , UnaryHandler 10 | , ServerStreamHandler 11 | , ServerStream(..) 12 | , ClientStreamHandler 13 | , ClientStream(..) 14 | , BiDiStreamHandler 15 | , BiDiStream(..) 16 | , BiDiStep(..) 17 | , GeneralStreamHandler 18 | , IncomingStream(..) 19 | , OutgoingStream(..) 20 | -- * registration 21 | , ServiceHandler 22 | , unary 23 | , serverStream 24 | , clientStream 25 | , bidiStream 26 | , generalStream 27 | -- * registration 28 | , GRPCStatus (..) 29 | , throwIO 30 | , GRPCStatusMessage 31 | , GRPCStatusCode (..) 32 | -- * to work directly with WAI 33 | , grpcApp 34 | , grpcService 35 | ) where 36 | 37 | import Control.Exception (throwIO) 38 | import Network.GRPC.HTTP2.Encoding (Compression) 39 | import Network.GRPC.HTTP2.Types (GRPCStatus(..), GRPCStatusCode(..), GRPCStatusMessage) 40 | import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS) 41 | import Network.Wai.Handler.Warp (Settings) 42 | 43 | import Network.GRPC.Server.Handlers (UnaryHandler, unary, ServerStreamHandler, ServerStream(..), serverStream, ClientStreamHandler, ClientStream(..), clientStream, BiDiStreamHandler, BiDiStream(..), BiDiStep(..), bidiStream, GeneralStreamHandler, IncomingStream(..), OutgoingStream(..), generalStream) 44 | import Network.GRPC.Server.Wai (ServiceHandler(..), grpcApp, grpcService) 45 | 46 | -- | Helper to constructs and serve a gRPC over HTTP2 application. 47 | -- 48 | -- You may want to use 'grpcApp' for adding middlewares to your gRPC server. 49 | runGrpc 50 | :: TLSSettings 51 | -- ^ TLS settings for the HTTP2 server. 52 | -> Settings 53 | -- ^ Warp settings. 54 | -> [ServiceHandler] 55 | -- ^ List of ServiceHandler. Refer to 'grcpApp' 56 | -> [Compression] 57 | -- ^ Compression methods used. 58 | -> IO () 59 | runGrpc tlsSettings settings handlers compressions = 60 | runTLS tlsSettings settings (grpcApp compressions handlers) 61 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # THIS REPO IS MOVING 2 | 3 | NOTE: we'll be moving the code in this repository to https://github.com/haskell-grpc-native . 4 | 5 | 6 | 7 | 8 | # warp-grpc 9 | 10 | A gRPC server implementation on top of Warp's HTTP2 handler. The lib also 11 | contains a demo sever using the awesome `grpcb.in` Proto. The current release 12 | is an advanced technical demo, expect a few breaking changes. 13 | 14 | ## Design 15 | 16 | The library implements gRPC using a WAI middleware for a set of gRPC endpoints. 17 | Endpoint handlers differ depending of the streaming/unary-ty of individual 18 | RPCs. Bidirectional streams will be supported next. 19 | 20 | There is little specification around the expected allowed observable states in 21 | gRPC, hence the types this library presents make conservative choices: unary 22 | RPCs expect an input before providing an output. Client stream allows to return 23 | an output only when the client has stopped streaming. Server streams wait for 24 | an input before starting to iterate sending outputs. 25 | 26 | ## Usage 27 | 28 | Generate some `proto-lens` code from `.proto` files, ideally in a separate 29 | library. Import this library and the generated proto-lens code to implement 30 | handlers for the `service` stanzas defined in the `.proto` files (see 31 | Haddocks). Finally, serve `warp` over TLS`. 32 | 33 | ## Example 34 | 35 | Please refer to https://github.com/lucasdicioccio/warp-grpc-example for an example. 36 | 37 | ## Next steps 38 | 39 | * Helper to set metadatas (a.k.a., headers and trailers). 40 | - (API-breaking) some or all handlers will get an IO-step to return extra metadata 41 | * Helper to map request headerlists into client metadatas (probably in `http2-grpc-types`) 42 | 43 | ## Limitations 44 | 45 | * Only supports "h2" with TLS (I'd argue it's a feature, not a bug. Don't @-me) 46 | * Some valid gRPC applications may not be expressible directly on top of warp 47 | because sending HTTP2 trailers (i.e., signalling the server's desire to stop 48 | sending messages) is correlated with closing the HTTP2 stream (i.e., stop 49 | accepting client messages). Hence it's not feasible to create a bidirectional 50 | stream that terminates on the server end while continuing to ingest client 51 | messages. This use case, however, seems like a corner case. 52 | -------------------------------------------------------------------------------- /src/Network/GRPC/Server/Wai.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Network.GRPC.Server.Wai where 5 | 6 | import Control.Exception (Handler(..), catches, SomeException, throwIO) 7 | import Data.ByteString.Char8 (ByteString) 8 | import qualified Data.ByteString.Char8 as ByteString 9 | import Data.ByteString.Lazy (fromStrict) 10 | import Data.Binary.Builder (Builder) 11 | import Data.Maybe (fromMaybe) 12 | import qualified Data.CaseInsensitive as CI 13 | import qualified Data.List as List 14 | import Network.GRPC.HTTP2.Encoding (Compression, Encoding(..), Decoding(..), grpcCompressionHV, uncompressed) 15 | import Network.GRPC.HTTP2.Types (GRPCStatus(..), GRPCStatusCode(..), grpcStatusH, grpcMessageH, grpcContentTypeHV, grpcEncodingH, grpcAcceptEncodingH) 16 | import Network.HTTP.Types (status200, status404) 17 | import Network.Wai (Application, Request(..), rawPathInfo, responseLBS, responseStream, requestHeaders) 18 | 19 | import Network.GRPC.Server.Helpers (modifyGRPCStatus) 20 | 21 | -- | A Wai Handler for a request. 22 | type WaiHandler = 23 | Decoding 24 | -- ^ Compression for the request inputs. 25 | -> Encoding 26 | -- ^ Compression for the request outputs. 27 | -> Request 28 | -- ^ Request object. 29 | -> (Builder -> IO ()) 30 | -- ^ Write a data chunk in the reply. 31 | -> IO () 32 | -- ^ Flush the output. 33 | -> IO () 34 | 35 | -- | Untyped gRPC Service handler. 36 | data ServiceHandler = ServiceHandler { 37 | grpcHandlerPath :: ByteString 38 | -- ^ Path to the Service to be handled. 39 | , grpcWaiHandler :: WaiHandler 40 | -- ^ Actual request handler. 41 | } 42 | 43 | -- | Build a WAI 'Application' from a list of ServiceHandler. 44 | -- 45 | -- Currently, gRPC calls are lookuped up by traversing the list of ServiceHandler. 46 | -- This lookup may be inefficient for large amount of servics. 47 | grpcApp :: [Compression] -> [ServiceHandler] -> Application 48 | grpcApp compressions services = 49 | grpcService compressions services err404app 50 | where 51 | err404app :: Application 52 | err404app req rep = 53 | rep $ responseLBS status404 [] $ fromStrict ("not found: " <> rawPathInfo req) 54 | 55 | -- | Aborts a GRPC handler with a given GRPCStatus. 56 | closeEarly :: GRPCStatus -> IO a 57 | closeEarly = throwIO 58 | 59 | -- | Build a WAI 'Middleware' from a list of ServiceHandler. 60 | -- 61 | -- Currently, gRPC calls are lookuped up by traversing the list of ServiceHandler. 62 | -- This lookup may be inefficient for large amount of services. 63 | grpcService :: [Compression] -> [ServiceHandler] -> (Application -> Application) 64 | grpcService compressions services app = \req rep -> do 65 | case lookupHandler (rawPathInfo req) services of 66 | Just handler -> 67 | -- Handler that catches early GRPC termination and other exceptions. 68 | -- 69 | -- Other exceptions are turned into GRPC status INTERNAL (rather 70 | -- than returning a 500). 71 | -- 72 | -- These exceptions are swallowed from the WAI "onException" 73 | -- handler, so we'll need a better way to handle this case. 74 | let grpcHandler write flush = 75 | (doHandle handler req write flush) 76 | `catches` [ Handler $ \(e::GRPCStatus) -> modifyGRPCStatus req e 77 | , Handler $ \(e::SomeException) -> modifyGRPCStatus req (GRPCStatus INTERNAL $ ByteString.pack $ show e ) 78 | ] 79 | in (rep $ responseStream status200 hdrs200 grpcHandler) 80 | Nothing -> 81 | app req rep 82 | where 83 | hdrs200 = [ 84 | ("content-type", grpcContentTypeHV) 85 | , ("trailer", CI.original grpcStatusH) 86 | , ("trailer", CI.original grpcMessageH) 87 | ] 88 | lookupHandler :: ByteString -> [ServiceHandler] -> Maybe WaiHandler 89 | lookupHandler p plainHandlers = grpcWaiHandler <$> 90 | List.find (\(ServiceHandler rpcPath _) -> rpcPath == p) plainHandlers 91 | doHandle handler req write flush = do 92 | let bestCompression = lookupEncoding req compressions 93 | let pickedCompression = fromMaybe (Encoding uncompressed) bestCompression 94 | 95 | let hopefulDecompression = lookupDecoding req compressions 96 | let pickedDecompression = fromMaybe (Decoding uncompressed) hopefulDecompression 97 | 98 | _ <- handler pickedDecompression pickedCompression req write flush 99 | modifyGRPCStatus req (GRPCStatus OK "WAI handler ended.") 100 | 101 | -- | Looks-up header for encoding outgoing messages. 102 | requestAcceptEncodingNames :: Request -> [ByteString] 103 | requestAcceptEncodingNames req = fromMaybe [] $ 104 | ByteString.split ',' <$> lookup grpcAcceptEncodingH (requestHeaders req) 105 | 106 | -- | Looks-up the compression to use from a set of known algorithms. 107 | lookupEncoding :: Request -> [Compression] -> Maybe Encoding 108 | lookupEncoding req compressions = fmap Encoding $ 109 | safeHead [ c | c <- compressions 110 | , n <- requestAcceptEncodingNames req 111 | , n == grpcCompressionHV c 112 | ] 113 | where 114 | safeHead [] = Nothing 115 | safeHead (x:_) = Just x 116 | 117 | -- | Looks-up header for decoding incoming messages. 118 | requestDecodingName :: Request -> Maybe ByteString 119 | requestDecodingName req = lookup grpcEncodingH (requestHeaders req) 120 | 121 | -- | Looks-up the compression to use for decoding messages. 122 | lookupDecoding :: Request -> [Compression] -> Maybe Decoding 123 | lookupDecoding req compressions = fmap Decoding $ do 124 | d <- requestDecodingName req 125 | lookup d [(grpcCompressionHV c, c) | c <- compressions] 126 | -------------------------------------------------------------------------------- /src/Network/GRPC/Server/Handlers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module Network.GRPC.Server.Handlers where 7 | 8 | import Control.Concurrent.Async (concurrently) 9 | import Control.Monad (void) 10 | import Data.Binary.Get (pushChunk, Decoder(..)) 11 | import qualified Data.ByteString.Char8 as ByteString 12 | import Data.ByteString.Char8 (ByteString) 13 | import Data.ByteString.Lazy (toStrict) 14 | import Data.ProtoLens.Message (Message) 15 | import Data.ProtoLens.Service.Types (Service(..), HasMethod, HasMethodImpl(..), StreamingType(..)) 16 | import Network.GRPC.HTTP2.Encoding (decodeInput, encodeOutput, Encoding(..), Decoding(..)) 17 | import Network.GRPC.HTTP2.Types (RPC(..), GRPCStatus(..), GRPCStatusCode(..), path) 18 | import Network.Wai (Request, getRequestBodyChunk, strictRequestBody) 19 | 20 | import Network.GRPC.Server.Wai (WaiHandler, ServiceHandler(..), closeEarly) 21 | 22 | -- | Handy type to refer to Handler for 'unary' RPCs handler. 23 | type UnaryHandler s m = Request -> MethodInput s m -> IO (MethodOutput s m) 24 | 25 | -- | Handy type for 'server-streaming' RPCs. 26 | -- 27 | -- We expect an implementation to: 28 | -- - read the input request 29 | -- - return an initial state and an state-passing action that the server code will call to fetch the output to send to the client (or close an a Nothing) 30 | -- See 'ServerStream' for the type which embodies these requirements. 31 | type ServerStreamHandler s m a = Request -> MethodInput s m -> IO (a, ServerStream s m a) 32 | 33 | newtype ServerStream s m a = ServerStream { 34 | serverStreamNext :: a -> IO (Maybe (a, MethodOutput s m)) 35 | } 36 | 37 | -- | Handy type for 'client-streaming' RPCs. 38 | -- 39 | -- We expect an implementation to: 40 | -- - acknowledge a the new client stream by returning an initial state and two functions: 41 | -- - a state-passing handler for new client message 42 | -- - a state-aware handler for answering the client when it is ending its stream 43 | -- See 'ClientStream' for the type which embodies these requirements. 44 | type ClientStreamHandler s m a = Request -> IO (a, ClientStream s m a) 45 | 46 | data ClientStream s m a = ClientStream { 47 | clientStreamHandler :: a -> MethodInput s m -> IO a 48 | , clientStreamFinalizer :: a -> IO (MethodOutput s m) 49 | } 50 | 51 | -- | Handy type for 'bidirectional-streaming' RPCs. 52 | -- 53 | -- We expect an implementation to: 54 | -- - acknowlege a new bidirection stream by returning an initial state and one functions: 55 | -- - a state-passing function that returns a single action step 56 | -- The action may be to 57 | -- - stop immediately 58 | -- - wait and handle some input with a callback and a finalizer (if the client closes the stream on its side) that may change the state 59 | -- - return a value and a new state 60 | -- 61 | -- There is no way to stop locally (that would mean sending HTTP2 trailers) and 62 | -- keep receiving messages from the client. 63 | type BiDiStreamHandler s m a = Request -> IO (a, BiDiStream s m a) 64 | 65 | data BiDiStep s m a 66 | = Abort 67 | | WaitInput !(a -> MethodInput s m -> IO a) !(a -> IO a) 68 | | WriteOutput !a (MethodOutput s m) 69 | 70 | data BiDiStream s m a = BiDiStream { 71 | bidirNextStep :: a -> IO (BiDiStep s m a) 72 | } 73 | 74 | -- | Construct a handler for handling a unary RPC. 75 | unary 76 | :: (Service s, HasMethod s m) 77 | => RPC s m 78 | -> UnaryHandler s m 79 | -> ServiceHandler 80 | unary rpc handler = 81 | ServiceHandler (path rpc) (handleUnary rpc handler) 82 | 83 | -- | Construct a handler for handling a server-streaming RPC. 84 | serverStream 85 | :: (Service s, HasMethod s m, MethodStreamingType s m ~ 'ServerStreaming) 86 | => RPC s m 87 | -> ServerStreamHandler s m a 88 | -> ServiceHandler 89 | serverStream rpc handler = 90 | ServiceHandler (path rpc) (handleServerStream rpc handler) 91 | 92 | -- | Construct a handler for handling a client-streaming RPC. 93 | clientStream 94 | :: (Service s, HasMethod s m, MethodStreamingType s m ~ 'ClientStreaming) 95 | => RPC s m 96 | -> ClientStreamHandler s m a 97 | -> ServiceHandler 98 | clientStream rpc handler = 99 | ServiceHandler (path rpc) (handleClientStream rpc handler) 100 | 101 | -- | Construct a handler for handling a bidirectional-streaming RPC. 102 | bidiStream 103 | :: (Service s, HasMethod s m, MethodStreamingType s m ~ 'BiDiStreaming) 104 | => RPC s m 105 | -> BiDiStreamHandler s m a 106 | -> ServiceHandler 107 | bidiStream rpc handler = 108 | ServiceHandler (path rpc) (handleBiDiStream rpc handler) 109 | 110 | -- | Construct a handler for handling a bidirectional-streaming RPC. 111 | generalStream 112 | :: (Service s, HasMethod s m) 113 | => RPC s m 114 | -> GeneralStreamHandler s m a b 115 | -> ServiceHandler 116 | generalStream rpc handler = 117 | ServiceHandler (path rpc) (handleGeneralStream rpc handler) 118 | 119 | -- | Handle unary RPCs. 120 | handleUnary :: 121 | (Service s, HasMethod s m) 122 | => RPC s m 123 | -> UnaryHandler s m 124 | -> WaiHandler 125 | handleUnary rpc handler decoding encoding req write flush = do 126 | handleRequestChunksLoop (decodeInput rpc $ _getDecodingCompression decoding) handleMsg handleEof nextChunk 127 | where 128 | nextChunk = toStrict <$> strictRequestBody req 129 | handleMsg = errorOnLeftOver (\i -> handler req i >>= reply) 130 | handleEof = closeEarly (GRPCStatus INVALID_ARGUMENT "early end of request body") 131 | reply msg = write (encodeOutput rpc (_getEncodingCompression encoding) msg) >> flush 132 | 133 | -- | Handle Server-Streaming RPCs. 134 | handleServerStream :: 135 | (Service s, HasMethod s m) 136 | => RPC s m 137 | -> ServerStreamHandler s m a 138 | -> WaiHandler 139 | handleServerStream rpc handler decoding encoding req write flush = do 140 | handleRequestChunksLoop (decodeInput rpc $ _getDecodingCompression decoding) handleMsg handleEof nextChunk 141 | where 142 | nextChunk = toStrict <$> strictRequestBody req 143 | handleMsg = errorOnLeftOver (\i -> handler req i >>= replyN) 144 | handleEof = closeEarly (GRPCStatus INVALID_ARGUMENT "early end of request body") 145 | replyN (v, sStream) = do 146 | let go v1 = serverStreamNext sStream v1 >>= \case 147 | Just (v2, msg) -> do 148 | write (encodeOutput rpc (_getEncodingCompression encoding) msg) >> flush 149 | go v2 150 | Nothing -> pure () 151 | go v 152 | 153 | -- | Handle Client-Streaming RPCs. 154 | handleClientStream :: 155 | (Service s, HasMethod s m) 156 | => RPC s m 157 | -> ClientStreamHandler s m a 158 | -> WaiHandler 159 | handleClientStream rpc handler0 decoding encoding req write flush = do 160 | handler0 req >>= go 161 | where 162 | go (v, cStream) = handleRequestChunksLoop (decodeInput rpc $ _getDecodingCompression decoding) (handleMsg v) (handleEof v) nextChunk 163 | where 164 | nextChunk = getRequestBodyChunk req 165 | handleMsg v0 dat msg = clientStreamHandler cStream v0 msg >>= \v1 -> loop dat v1 166 | handleEof v0 = clientStreamFinalizer cStream v0 >>= reply 167 | reply msg = write (encodeOutput rpc (_getEncodingCompression encoding) msg) >> flush 168 | loop chunk v1 = handleRequestChunksLoop (flip pushChunk chunk $ decodeInput rpc (_getDecodingCompression decoding)) (handleMsg v1) (handleEof v1) nextChunk 169 | 170 | -- | Handle Bidirectional-Streaming RPCs. 171 | handleBiDiStream :: 172 | (Service s, HasMethod s m) 173 | => RPC s m 174 | -> BiDiStreamHandler s m a 175 | -> WaiHandler 176 | handleBiDiStream rpc handler0 decoding encoding req write flush = do 177 | handler0 req >>= go "" 178 | where 179 | nextChunk = getRequestBodyChunk req 180 | reply msg = write (encodeOutput rpc (_getEncodingCompression encoding) msg) >> flush 181 | go chunk (v0, bStream) = do 182 | let cont dat v1 = go dat (v1, bStream) 183 | step <- (bidirNextStep bStream) v0 184 | case step of 185 | WaitInput handleMsg handleEof -> do 186 | handleRequestChunksLoop (flip pushChunk chunk $ decodeInput rpc $ _getDecodingCompression decoding) 187 | (\dat msg -> handleMsg v0 msg >>= cont dat) 188 | (handleEof v0 >>= cont "") 189 | nextChunk 190 | WriteOutput v1 msg -> do 191 | reply msg 192 | cont "" v1 193 | Abort -> return () 194 | 195 | -- | A GeneralStreamHandler combining server and client asynchronous streams. 196 | type GeneralStreamHandler s m a b = 197 | Request -> IO (a, IncomingStream s m a, b, OutgoingStream s m b) 198 | 199 | -- | Pair of handlers for reacting to incoming messages. 200 | data IncomingStream s m a = IncomingStream { 201 | incomingStreamHandler :: a -> MethodInput s m -> IO a 202 | , incomingStreamFinalizer :: a -> IO () 203 | } 204 | 205 | -- | Handler to decide on the next message (if any) to return. 206 | data OutgoingStream s m a = OutgoingStream { 207 | outgoingStreamNext :: a -> IO (Maybe (a, MethodOutput s m)) 208 | } 209 | 210 | -- | Handler for the somewhat general case where two threads behave concurrently: 211 | -- - one reads messages from the client 212 | -- - one returns messages to the client 213 | handleGeneralStream :: 214 | (Service s, HasMethod s m) 215 | => RPC s m 216 | -> GeneralStreamHandler s m a b 217 | -> WaiHandler 218 | handleGeneralStream rpc handler0 decoding encoding req write flush = void $ do 219 | handler0 req >>= go 220 | where 221 | newDecoder = decodeInput rpc $ _getDecodingCompression decoding 222 | nextChunk = getRequestBodyChunk req 223 | reply msg = write (encodeOutput rpc (_getEncodingCompression encoding) msg) >> flush 224 | 225 | go (in0, instream, out0, outstream) = concurrently 226 | (incomingLoop newDecoder in0 instream) 227 | (replyLoop out0 outstream) 228 | 229 | replyLoop v0 sstream@(OutgoingStream next) = do 230 | next v0 >>= \case 231 | Nothing -> return v0 232 | (Just (v1, msg)) -> reply msg >> replyLoop v1 sstream 233 | 234 | incomingLoop decode v0 cstream = do 235 | let handleMsg dat msg = do 236 | v1 <- incomingStreamHandler cstream v0 msg 237 | incomingLoop (pushChunk newDecoder dat) v1 cstream 238 | let handleEof = incomingStreamFinalizer cstream v0 >> pure v0 239 | handleRequestChunksLoop decode handleMsg handleEof nextChunk 240 | 241 | 242 | -- | Helpers to consume input in chunks. 243 | handleRequestChunksLoop 244 | :: (Message a) 245 | => Decoder (Either String a) 246 | -- ^ Message decoder. 247 | -> (ByteString -> a -> IO b) 248 | -- ^ Handler for a single message. 249 | -- The ByteString corresponds to leftover data. 250 | -> IO b 251 | -- ^ Handler for handling end-of-streams. 252 | -> IO ByteString 253 | -- ^ Action to retrieve the next chunk. 254 | -> IO b 255 | {-# INLINEABLE handleRequestChunksLoop #-} 256 | handleRequestChunksLoop decoder handleMsg handleEof nextChunk = 257 | case decoder of 258 | (Done unusedDat _ (Right val)) -> do 259 | handleMsg unusedDat val 260 | (Done _ _ (Left err)) -> do 261 | closeEarly (GRPCStatus INVALID_ARGUMENT (ByteString.pack $ "done-error: " ++ err)) 262 | (Fail _ _ err) -> 263 | closeEarly (GRPCStatus INVALID_ARGUMENT (ByteString.pack $ "fail-error: " ++ err)) 264 | partial@(Partial _) -> do 265 | chunk <- nextChunk 266 | if ByteString.null chunk 267 | then 268 | handleEof 269 | else 270 | handleRequestChunksLoop (pushChunk partial chunk) handleMsg handleEof nextChunk 271 | 272 | -- | Combinator around message handler to error on left overs. 273 | -- 274 | -- This combinator ensures that, unless for client stream, an unparsed piece of 275 | -- data with a correctly-read message is treated as an error. 276 | errorOnLeftOver :: (a -> IO b) -> ByteString -> a -> IO b 277 | errorOnLeftOver f rest 278 | | ByteString.null rest = f 279 | | otherwise = const $ closeEarly $ GRPCStatus INVALID_ARGUMENT ("left-overs: " <> rest) 280 | -------------------------------------------------------------------------------- /src/Network/GRPC/Server/Handlers/NoLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module Network.GRPC.Server.Handlers.NoLens where 7 | 8 | import Control.Concurrent.Async (concurrently) 9 | import Control.Monad (void) 10 | import Data.Binary.Builder (Builder, singleton, putWord32be, fromByteString) 11 | import Data.Binary.Get (pushChunk, Decoder(..), runGetIncremental, getInt8, getWord32be, getByteString) 12 | import qualified Data.ByteString.Char8 as ByteString 13 | import Data.ByteString.Char8 (ByteString) 14 | import Data.ByteString.Lazy (toStrict) 15 | import Network.GRPC.HTTP2.Encoding (Encoding(..), Decoding(..), Compression(..)) 16 | import Network.GRPC.HTTP2.Types (GRPCStatus(..), GRPCStatusCode(..), HeaderValue) 17 | import Network.Wai (Request, getRequestBodyChunk, strictRequestBody) 18 | import qualified Proto3.Wire.Encode as PBEnc 19 | import qualified Proto3.Wire.Decode as PBDec 20 | 21 | import Network.GRPC.Server.Wai (WaiHandler, ServiceHandler(..), closeEarly) 22 | 23 | -- From 'Network.GRPC.HTTP2.Types', copied to remove dependency on proto-lens 24 | data RPC = RPC { pkg :: ByteString, srv :: ByteString, meth :: ByteString } 25 | 26 | path :: RPC -> HeaderValue 27 | {-# INLINE path #-} 28 | path rpc = "/" <> pkg rpc <> "." <> srv rpc <> "/" <> meth rpc 29 | 30 | type ProtoBufEncoder a = a -> PBEnc.MessageBuilder 31 | type ProtoBufDecoder a = PBDec.Parser PBDec.RawMessage a 32 | type ProtoBufBothSides i o = (ProtoBufDecoder i, ProtoBufEncoder o) 33 | 34 | encode :: ProtoBufEncoder m -> Compression -> m -> Builder 35 | encode toProtoBuf compression plain = 36 | mconcat [ singleton (if _compressionByteSet compression then 1 else 0) 37 | , putWord32be (fromIntegral $ ByteString.length bin) 38 | , fromByteString bin 39 | ] 40 | where 41 | bin = _compressionFunction compression $ toStrict $ PBEnc.toLazyByteString (toProtoBuf plain) 42 | 43 | decoder :: ProtoBufDecoder a -> Compression -> Decoder (Either PBDec.ParseError a) 44 | decoder fromProtoBuf compression = runGetIncremental $ do 45 | isCompressed <- getInt8 -- 1byte 46 | let decompress = if isCompressed == 0 then pure else (_decompressionFunction compression) 47 | n <- getWord32be -- 4bytes 48 | PBDec.parse fromProtoBuf <$> (decompress =<< getByteString (fromIntegral n)) 49 | 50 | -- | Handy type to refer to Handler for 'unary' RPCs handler. 51 | type UnaryHandler i o = Request -> i -> IO o 52 | 53 | -- | Handy type for 'server-streaming' RPCs. 54 | -- 55 | -- We expect an implementation to: 56 | -- - read the input request 57 | -- - return an initial state and an state-passing action that the server code will call to fetch the output to send to the client (or close an a Nothing) 58 | -- See 'ServerStream' for the type which embodies these requirements. 59 | type ServerStreamHandler i o a = Request -> i -> IO (a, ServerStream o a) 60 | 61 | newtype ServerStream o a = ServerStream { 62 | serverStreamNext :: a -> IO (Maybe (a, o)) 63 | } 64 | 65 | -- | Handy type for 'client-streaming' RPCs. 66 | -- 67 | -- We expect an implementation to: 68 | -- - acknowledge a the new client stream by returning an initial state and two functions: 69 | -- - a state-passing handler for new client message 70 | -- - a state-aware handler for answering the client when it is ending its stream 71 | -- See 'ClientStream' for the type which embodies these requirements. 72 | type ClientStreamHandler i o a = Request -> IO (a, ClientStream i o a) 73 | 74 | data ClientStream i o a = ClientStream { 75 | clientStreamHandler :: a -> i -> IO a 76 | , clientStreamFinalizer :: a -> IO o 77 | } 78 | 79 | -- | Handy type for 'bidirectional-streaming' RPCs. 80 | -- 81 | -- We expect an implementation to: 82 | -- - acknowlege a new bidirection stream by returning an initial state and one functions: 83 | -- - a state-passing function that returns a single action step 84 | -- The action may be to 85 | -- - stop immediately 86 | -- - wait and handle some input with a callback and a finalizer (if the client closes the stream on its side) that may change the state 87 | -- - return a value and a new state 88 | -- 89 | -- There is no way to stop locally (that would mean sending HTTP2 trailers) and 90 | -- keep receiving messages from the client. 91 | type BiDiStreamHandler i o a = Request -> IO (a, BiDiStream i o a) 92 | 93 | data BiDiStep i o a 94 | = Abort 95 | | WaitInput !(a -> i -> IO a) !(a -> IO a) 96 | | WriteOutput !a o 97 | 98 | data BiDiStream i o a = BiDiStream { 99 | bidirNextStep :: a -> IO (BiDiStep i o a) 100 | } 101 | 102 | -- | Construct a handler for handling a unary RPC. 103 | unary 104 | :: ProtoBufBothSides i o 105 | -> RPC 106 | -> UnaryHandler i o 107 | -> ServiceHandler 108 | unary pb rpc handler = 109 | ServiceHandler (path rpc) (handleUnary pb rpc handler) 110 | 111 | -- | Construct a handler for handling a server-streaming RPC. 112 | serverStream 113 | :: ProtoBufBothSides i o 114 | -> RPC 115 | -> ServerStreamHandler i o a 116 | -> ServiceHandler 117 | serverStream pb rpc handler = 118 | ServiceHandler (path rpc) (handleServerStream pb rpc handler) 119 | 120 | -- | Construct a handler for handling a client-streaming RPC. 121 | clientStream 122 | :: ProtoBufBothSides i o 123 | -> RPC 124 | -> ClientStreamHandler i o a 125 | -> ServiceHandler 126 | clientStream pb rpc handler = 127 | ServiceHandler (path rpc) (handleClientStream pb rpc handler) 128 | 129 | -- | Construct a handler for handling a bidirectional-streaming RPC. 130 | bidiStream 131 | :: ProtoBufBothSides i o 132 | -> RPC 133 | -> BiDiStreamHandler i o a 134 | -> ServiceHandler 135 | bidiStream pb rpc handler = 136 | ServiceHandler (path rpc) (handleBiDiStream pb rpc handler) 137 | 138 | -- | Construct a handler for handling a bidirectional-streaming RPC. 139 | generalStream 140 | :: ProtoBufBothSides i o 141 | -> RPC 142 | -> GeneralStreamHandler i o a b 143 | -> ServiceHandler 144 | generalStream pb rpc handler = 145 | ServiceHandler (path rpc) (handleGeneralStream pb rpc handler) 146 | 147 | -- | Handle unary RPCs. 148 | handleUnary :: 149 | ProtoBufBothSides i o 150 | -> RPC 151 | -> UnaryHandler i o 152 | -> WaiHandler 153 | handleUnary (iDec, oEnc) rpc handler decoding encoding req write flush = do 154 | handleRequestChunksLoop (decoder iDec $ _getDecodingCompression decoding) handleMsg handleEof nextChunk 155 | where 156 | nextChunk = toStrict <$> strictRequestBody req 157 | handleMsg = errorOnLeftOver (\i -> handler req i >>= reply) 158 | handleEof = closeEarly (GRPCStatus INVALID_ARGUMENT "early end of request body") 159 | reply msg = write (encode oEnc (_getEncodingCompression encoding) msg) >> flush 160 | 161 | -- | Handle Server-Streaming RPCs. 162 | handleServerStream :: 163 | ProtoBufBothSides i o 164 | -> RPC 165 | -> ServerStreamHandler i o a 166 | -> WaiHandler 167 | handleServerStream (iDec, oEnc) rpc handler decoding encoding req write flush = do 168 | handleRequestChunksLoop (decoder iDec $ _getDecodingCompression decoding) handleMsg handleEof nextChunk 169 | where 170 | nextChunk = toStrict <$> strictRequestBody req 171 | handleMsg = errorOnLeftOver (\i -> handler req i >>= replyN) 172 | handleEof = closeEarly (GRPCStatus INVALID_ARGUMENT "early end of request body") 173 | replyN (v, sStream) = do 174 | let go v1 = serverStreamNext sStream v1 >>= \case 175 | Just (v2, msg) -> do 176 | write (encode oEnc (_getEncodingCompression encoding) msg) >> flush 177 | go v2 178 | Nothing -> pure () 179 | go v 180 | 181 | -- | Handle Client-Streaming RPCs. 182 | handleClientStream :: 183 | ProtoBufBothSides i o 184 | -> RPC 185 | -> ClientStreamHandler i o a 186 | -> WaiHandler 187 | handleClientStream (iDec, oEnc) rpc handler0 decoding encoding req write flush = do 188 | handler0 req >>= go 189 | where 190 | go (v, cStream) = handleRequestChunksLoop (decoder iDec $ _getDecodingCompression decoding) (handleMsg v) (handleEof v) nextChunk 191 | where 192 | nextChunk = getRequestBodyChunk req 193 | handleMsg v0 dat msg = clientStreamHandler cStream v0 msg >>= \v1 -> loop dat v1 194 | handleEof v0 = clientStreamFinalizer cStream v0 >>= reply 195 | reply msg = write (encode oEnc (_getEncodingCompression encoding) msg) >> flush 196 | loop chunk v1 = handleRequestChunksLoop 197 | (flip pushChunk chunk $ decoder iDec (_getDecodingCompression decoding)) 198 | (handleMsg v1) (handleEof v1) nextChunk 199 | 200 | -- | Handle Bidirectional-Streaming RPCs. 201 | handleBiDiStream :: 202 | ProtoBufBothSides i o 203 | -> RPC 204 | -> BiDiStreamHandler i o a 205 | -> WaiHandler 206 | handleBiDiStream (iDec, oEnc) rpc handler0 decoding encoding req write flush = do 207 | handler0 req >>= go "" 208 | where 209 | nextChunk = getRequestBodyChunk req 210 | reply msg = write (encode oEnc (_getEncodingCompression encoding) msg) >> flush 211 | go chunk (v0, bStream) = do 212 | let cont dat v1 = go dat (v1, bStream) 213 | step <- (bidirNextStep bStream) v0 214 | case step of 215 | WaitInput handleMsg handleEof -> do 216 | handleRequestChunksLoop (flip pushChunk chunk 217 | $ decoder iDec 218 | $ _getDecodingCompression decoding) 219 | (\dat msg -> handleMsg v0 msg >>= cont dat) 220 | (handleEof v0 >>= cont "") 221 | nextChunk 222 | WriteOutput v1 msg -> do 223 | reply msg 224 | cont "" v1 225 | Abort -> return () 226 | 227 | -- | A GeneralStreamHandler combining server and client asynchronous streams. 228 | type GeneralStreamHandler i o a b = 229 | Request -> IO (a, IncomingStream i a, b, OutgoingStream o b) 230 | 231 | -- | Pair of handlers for reacting to incoming messages. 232 | data IncomingStream i a = IncomingStream { 233 | incomingStreamHandler :: a -> i -> IO a 234 | , incomingStreamFinalizer :: a -> IO () 235 | } 236 | 237 | -- | Handler to decide on the next message (if any) to return. 238 | data OutgoingStream o a = OutgoingStream { 239 | outgoingStreamNext :: a -> IO (Maybe (a, o)) 240 | } 241 | 242 | -- | Handler for the somewhat general case where two threads behave concurrently: 243 | -- - one reads messages from the client 244 | -- - one returns messages to the client 245 | handleGeneralStream :: 246 | ProtoBufBothSides i o 247 | -> RPC 248 | -> GeneralStreamHandler i o a b 249 | -> WaiHandler 250 | handleGeneralStream (iDec, oEnc) rpc handler0 decoding encoding req write flush = void $ do 251 | handler0 req >>= go 252 | where 253 | newDecoder = decoder iDec $ _getDecodingCompression decoding 254 | nextChunk = getRequestBodyChunk req 255 | reply msg = write (encode oEnc (_getEncodingCompression encoding) msg) >> flush 256 | 257 | go (in0, instream, out0, outstream) = concurrently 258 | (incomingLoop newDecoder in0 instream) 259 | (replyLoop out0 outstream) 260 | 261 | replyLoop v0 sstream@(OutgoingStream next) = do 262 | next v0 >>= \case 263 | Nothing -> return v0 264 | (Just (v1, msg)) -> reply msg >> replyLoop v1 sstream 265 | 266 | incomingLoop decode v0 cstream = do 267 | let handleMsg dat msg = do 268 | v1 <- incomingStreamHandler cstream v0 msg 269 | incomingLoop (pushChunk newDecoder dat) v1 cstream 270 | let handleEof = incomingStreamFinalizer cstream v0 >> pure v0 271 | handleRequestChunksLoop decode handleMsg handleEof nextChunk 272 | 273 | 274 | -- | Helpers to consume input in chunks. 275 | handleRequestChunksLoop 276 | :: Decoder (Either PBDec.ParseError a) 277 | -- ^ Message decoder. 278 | -> (ByteString -> a -> IO b) 279 | -- ^ Handler for a single message. 280 | -- The ByteString corresponds to leftover data. 281 | -> IO b 282 | -- ^ Handler for handling end-of-streams. 283 | -> IO ByteString 284 | -- ^ Action to retrieve the next chunk. 285 | -> IO b 286 | {-# INLINEABLE handleRequestChunksLoop #-} 287 | handleRequestChunksLoop decoder handleMsg handleEof nextChunk = 288 | case decoder of 289 | (Done unusedDat _ (Right val)) -> do 290 | handleMsg unusedDat val 291 | (Done _ _ (Left err)) -> do 292 | closeEarly (GRPCStatus INVALID_ARGUMENT (ByteString.pack $ "done-error: " ++ show err)) 293 | (Fail _ _ err) -> 294 | closeEarly (GRPCStatus INVALID_ARGUMENT (ByteString.pack $ "fail-error: " ++ err)) 295 | partial@(Partial _) -> do 296 | chunk <- nextChunk 297 | if ByteString.null chunk 298 | then 299 | handleEof 300 | else 301 | handleRequestChunksLoop (pushChunk partial chunk) handleMsg handleEof nextChunk 302 | 303 | -- | Combinator around message handler to error on left overs. 304 | -- 305 | -- This combinator ensures that, unless for client stream, an unparsed piece of 306 | -- data with a correctly-read message is treated as an error. 307 | errorOnLeftOver :: (a -> IO b) -> ByteString -> a -> IO b 308 | errorOnLeftOver f rest 309 | | ByteString.null rest = f 310 | | otherwise = const $ closeEarly $ GRPCStatus INVALID_ARGUMENT ("left-overs: " <> rest) 311 | --------------------------------------------------------------------------------