grpc-haskell (empty) → 0.0.0.0
raw patch · 19 files changed
+2203/−0 lines, 19 filesdep +QuickCheckdep +asyncdep +basesetup-changed
Dependencies added: QuickCheck, async, base, bytestring, clock, containers, criterion, grpc-haskell, grpc-haskell-core, managed, optparse-generic, pipes, proto3-suite, proto3-wire, random, safe, tasty, tasty-hunit, tasty-quickcheck, text, time, transformers, turtle, unix, vector
Files
- LICENSE +203/−0
- Setup.hs +2/−0
- bench/Bench.hs +166/−0
- examples/echo/echo-hs/Echo.hs +177/−0
- examples/echo/echo-hs/EchoClient.hs +48/−0
- examples/echo/echo-hs/EchoServer.hs +42/−0
- examples/hellos/hellos-client/Main.hs +123/−0
- examples/hellos/hellos-server/Main.hs +83/−0
- examples/tutorial/Arithmetic.hs +208/−0
- examples/tutorial/ArithmeticClient.hs +41/−0
- examples/tutorial/ArithmeticServer.hs +50/−0
- grpc-haskell.cabal +233/−0
- src/Network/GRPC/HighLevel.hs +54/−0
- src/Network/GRPC/HighLevel/Client.hs +179/−0
- src/Network/GRPC/HighLevel/Generated.hs +97/−0
- src/Network/GRPC/HighLevel/Server.hs +289/−0
- src/Network/GRPC/HighLevel/Server/Unregistered.hs +126/−0
- tests/GeneratedTests.hs +77/−0
- tests/Properties.hs +5/−0
+ LICENSE view
@@ -0,0 +1,203 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright 2016 Awake Networks+ Copyright 2015 Alois Cochard https://github.com/aloiscochard/grpc-haskell++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception (bracket)+import Control.Monad+import Criterion.Main+import Criterion.Types (Config (..))+import qualified Data.ByteString.Lazy as BL+import Data.Word+import GHC.Generics (Generic)+import Network.GRPC.HighLevel.Server hiding (serverLoop)+import Network.GRPC.HighLevel.Server.Unregistered (serverLoop)+import Network.GRPC.LowLevel+import Network.GRPC.LowLevel.GRPC (threadDelaySecs)+import Proto3.Suite.Class+import Proto3.Suite.Types+import System.Random (randomRIO)++data AddRequest = AddRequest {addX :: Fixed Word32+ , addY :: Fixed Word32}+ deriving (Show, Eq, Ord, Generic)+instance Message AddRequest++data AddResponse = AddResponse (Fixed Word32)+ deriving (Show, Eq, Ord, Generic)+instance Message AddResponse++addMethod :: MethodName+addMethod = MethodName "/unary"++addClientStreamMethod :: MethodName+addClientStreamMethod = MethodName "/clientstream"++addServerStreamMethod :: MethodName+addServerStreamMethod = MethodName "/serverstream"++addBiDiMethod :: MethodName+addBiDiMethod = MethodName "/bidistream"++addHandler :: Handler 'Normal+addHandler =+ UnaryHandler addMethod $+ \c -> do+ let b = payload c+ return ( AddResponse $ addX b + addY b+ , metadata c+ , StatusOk+ , StatusDetails ""+ )++addClientStreamHandler :: Handler 'ClientStreaming+addClientStreamHandler =+ ClientStreamHandler addClientStreamMethod $+ \_ recv -> do+ answer <- go recv 0+ return (Just answer, mempty, StatusOk, "")+ where go recv !i = do+ req <- recv+ case req of+ Left _ -> return $ AddResponse i+ Right Nothing -> return $ AddResponse i+ Right (Just (AddRequest x y)) -> go recv (i+x+y)++addServerStreamHandler :: Handler 'ServerStreaming+addServerStreamHandler =+ ServerStreamHandler addServerStreamMethod $+ \c send -> do+ let AddRequest (Fixed x) y = payload c+ replicateM_ (fromIntegral x) $ send $ AddResponse y+ return (mempty, StatusOk, "")++addBiDiHandler :: Handler 'BiDiStreaming+addBiDiHandler = BiDiStreamHandler addBiDiMethod (go 0)+ where go :: Fixed Word32 -> ServerRWHandler AddRequest AddResponse+ go !i c recv send = do+ req <- recv+ case req of+ Left _ -> return (mempty, StatusOk, "")+ Right Nothing -> return (mempty, StatusOk, "")+ Right (Just (AddRequest x y)) -> do+ let curr = i + x + y+ void $ send $ AddResponse curr+ go curr c recv send+++serverOpts :: ServerOptions+serverOpts =+ defaultOptions{optNormalHandlers = [addHandler]+ , optClientStreamHandlers = [addClientStreamHandler]+ , optServerStreamHandlers = [addServerStreamHandler]+ , optBiDiStreamHandlers = [addBiDiHandler]}++main :: IO ()+main = bracket startServer stopServer $ const $ withGRPC $ \grpc ->+ withClient grpc (ClientConfig "localhost" 50051 [] Nothing Nothing) $ \c -> do+ rmAdd <- clientRegisterMethodNormal c addMethod+ rmClientStream <- clientRegisterMethodClientStreaming c addClientStreamMethod+ rmServerStream <- clientRegisterMethodServerStreaming c addServerStreamMethod+ rmBiDiStream <- clientRegisterMethodBiDiStreaming c addBiDiMethod+ defaultMainWith+ defaultConfig{reportFile = Just "benchmarks.html"}+ [ bench "unary request" $ nfIO (addRequest c rmAdd)+ , bench "client stream: 100 messages" $ nfIO (addClientStream c rmClientStream 100)+ , bench "client stream: 1k messages" $ nfIO (addClientStream c rmClientStream 1000)+ , bench "client stream: 10k messages" $ nfIO (addClientStream c rmClientStream 10000)+ , bench "server stream: 100 messages" $ nfIO (addServerStream c rmServerStream 100)+ , bench "server stream: 1k messages" $ nfIO (addServerStream c rmServerStream 1000)+ , bench "server stream: 10k messages" $ nfIO (addServerStream c rmServerStream 10000)+ , bench "bidi stream: 50 messages up, 50 down" $ nfIO (bidiStream c rmBiDiStream 50)+ , bench "bidi stream: 500 message up, 500 down" $ nfIO (bidiStream c rmBiDiStream 500)+ , bench "bidi stream: 5000 messages up, 5000 down" $ nfIO (bidiStream c rmBiDiStream 5000)]++ where startServer = do+ sThrd <- async $ serverLoop serverOpts+ threadDelaySecs 1+ return sThrd++ stopServer sThrd = cancel sThrd >> void (waitCatch sThrd)++ encode = BL.toStrict . toLazyByteString++ addRequest c rmAdd = do+ x <- liftM Fixed $ randomRIO (0,1000)+ y <- liftM Fixed $ randomRIO (0,1000)+ let addEnc = BL.toStrict . toLazyByteString $ AddRequest x y+ clientRequest c rmAdd 5 addEnc mempty >>= \case+ Left e -> fail $ "Got client error on add request: " ++ show e+ Right r -> case fromByteString (rspBody r) of+ Left e -> fail $ "failed to decode add response: " ++ show e+ Right dec+ | dec == AddResponse (x + y) -> return ()+ | otherwise -> fail $ "Got wrong add answer: " ++ show dec ++ "; expected: " ++ show x ++ " + " ++ show y ++ " = " ++ show (x+y)++ addClientStream c rm i = do+ let msg = encode $ AddRequest 1 0+ Right (Just r,_,_,_,_) <- clientWriter c rm 5 mempty $ \send -> do+ replicateM_ i $ send msg+ let decoded = fromByteString r+ when (decoded /= Right (AddResponse (fromIntegral i))) $+ fail $ "clientStream: bad answer: " ++ show decoded ++ "; expected: " ++ show i++ addServerStream c rm i = do+ let msg = encode $ AddRequest (fromIntegral i) 2+ Right (_, _, sd) <- clientReader c rm 5 msg mempty $ \_ recv ->+ replicateM_ i $ do+ Right (Just bs) <- recv+ let Right decoded = fromByteString bs+ when (decoded /= AddResponse 2) $+ fail $ "serverStream: bad response of " ++ show decoded ++ "; expected 2."+ when (sd /= mempty) $ fail $ "bad status details: " ++ show sd++ bidiStream c rm i = do+ Right (_, _, sd) <- clientRW c rm 5 mempty $ \_ recv send done -> do+ forM_ (take i [2,4..]) $ \n -> do+ void $ send $ encode $ AddRequest 1 1+ Right (Just bs) <- recv+ let Right decoded = fromByteString bs+ when (decoded /= AddResponse n) $+ fail $ "bidiStream: got: " ++ show decoded ++ "expected: " ++ show n+ void done+ when (sd /= mempty) $ fail $ "bad StatusDetails: " ++ show sd
+ examples/echo/echo-hs/Echo.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++-- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!+module Echo where+import qualified Prelude as Hs+import qualified Proto3.Suite.DotProto as HsProtobuf+import qualified Proto3.Suite.Types as HsProtobuf+import qualified Proto3.Suite.Class as HsProtobuf+import qualified Proto3.Suite.JSONPB as HsJSONPB+import Proto3.Suite.JSONPB ((.=), (.:))+import qualified Proto3.Wire as HsProtobuf+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.Applicative as Hs+import qualified Control.Monad as Hs+import qualified Data.Text.Lazy as Hs (Text)+import qualified Data.ByteString as Hs+import qualified Data.String as Hs (fromString)+import qualified Data.Vector as Hs (Vector)+import qualified Data.Int as Hs (Int16, Int32, Int64)+import qualified Data.Word as Hs (Word16, Word32, Word64)+import qualified Data.Proxy as Proxy+import qualified GHC.Generics as Hs+import qualified GHC.Enum as Hs+import Network.GRPC.HighLevel.Generated as HsGRPC+import Network.GRPC.HighLevel.Client as HsGRPC+import Network.GRPC.HighLevel.Server as HsGRPC hiding (serverLoop)+import Network.GRPC.HighLevel.Server.Unregistered as HsGRPC+ (serverLoop)+ +data Echo request response = Echo{echoDoEcho ::+ request 'HsGRPC.Normal Echo.EchoRequest Echo.EchoResponse ->+ Hs.IO (response 'HsGRPC.Normal Echo.EchoResponse)}+ deriving Hs.Generic+ +echoServer ::+ Echo HsGRPC.ServerRequest HsGRPC.ServerResponse ->+ HsGRPC.ServiceOptions -> Hs.IO ()+echoServer Echo{echoDoEcho = echoDoEcho}+ (ServiceOptions serverHost serverPort useCompression+ userAgentPrefix userAgentSuffix initialMetadata sslConfig logger)+ = (HsGRPC.serverLoop+ HsGRPC.defaultOptions{HsGRPC.optNormalHandlers =+ [(HsGRPC.UnaryHandler (HsGRPC.MethodName "/echo.Echo/DoEcho")+ (HsGRPC.convertGeneratedServerHandler echoDoEcho))],+ HsGRPC.optClientStreamHandlers = [],+ HsGRPC.optServerStreamHandlers = [],+ HsGRPC.optBiDiStreamHandlers = [], optServerHost = serverHost,+ optServerPort = serverPort, optUseCompression = useCompression,+ optUserAgentPrefix = userAgentPrefix,+ optUserAgentSuffix = userAgentSuffix,+ optInitialMetadata = initialMetadata, optSSLConfig = sslConfig,+ optLogger = logger})+ +echoClient ::+ HsGRPC.Client ->+ Hs.IO (Echo HsGRPC.ClientRequest HsGRPC.ClientResult)+echoClient client+ = (Hs.pure Echo) <*>+ ((Hs.pure (HsGRPC.clientRequest client)) <*>+ (HsGRPC.clientRegisterMethod client+ (HsGRPC.MethodName "/echo.Echo/DoEcho")))+ +data EchoRequest = EchoRequest{echoRequestMessage :: Hs.Text}+ deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+ +instance HsProtobuf.Named EchoRequest where+ nameOf _ = (Hs.fromString "EchoRequest")+ +instance HsProtobuf.Message EchoRequest where+ encodeMessage _+ EchoRequest{echoRequestMessage = echoRequestMessage}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ echoRequestMessage)])+ decodeMessage _+ = (Hs.pure EchoRequest) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim HsProtobuf.String)+ (HsProtobuf.Single "message")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB EchoRequest where+ toJSONPB (EchoRequest f1) = (HsJSONPB.object ["message" .= f1])+ toEncodingPB (EchoRequest f1) = (HsJSONPB.pairs ["message" .= f1])+ +instance HsJSONPB.FromJSONPB EchoRequest where+ parseJSONPB+ = (HsJSONPB.withObject "EchoRequest"+ (\ obj -> (Hs.pure EchoRequest) <*> obj .: "message"))+ +instance HsJSONPB.ToJSON EchoRequest where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON EchoRequest where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema EchoRequest where+ declareNamedSchema _+ = do let declare_message = HsJSONPB.declareSchemaRef+ echoRequestMessage <- declare_message Proxy.Proxy+ let _ = Hs.pure EchoRequest <*> HsJSONPB.asProxy declare_message+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "EchoRequest",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("message", echoRequestMessage)]}})+ +data EchoResponse = EchoResponse{echoResponseMessage :: Hs.Text}+ deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+ +instance HsProtobuf.Named EchoResponse where+ nameOf _ = (Hs.fromString "EchoResponse")+ +instance HsProtobuf.Message EchoResponse where+ encodeMessage _+ EchoResponse{echoResponseMessage = echoResponseMessage}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ echoResponseMessage)])+ decodeMessage _+ = (Hs.pure EchoResponse) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim HsProtobuf.String)+ (HsProtobuf.Single "message")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB EchoResponse where+ toJSONPB (EchoResponse f1) = (HsJSONPB.object ["message" .= f1])+ toEncodingPB (EchoResponse f1) = (HsJSONPB.pairs ["message" .= f1])+ +instance HsJSONPB.FromJSONPB EchoResponse where+ parseJSONPB+ = (HsJSONPB.withObject "EchoResponse"+ (\ obj -> (Hs.pure EchoResponse) <*> obj .: "message"))+ +instance HsJSONPB.ToJSON EchoResponse where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON EchoResponse where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema EchoResponse where+ declareNamedSchema _+ = do let declare_message = HsJSONPB.declareSchemaRef+ echoResponseMessage <- declare_message Proxy.Proxy+ let _ = Hs.pure EchoResponse <*> HsJSONPB.asProxy declare_message+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "EchoResponse",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("message", echoResponseMessage)]}})
+ examples/echo/echo-hs/EchoClient.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}++import Control.Monad+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import qualified Data.Text.Lazy as TL+import Echo+import GHC.Generics (Generic)+import Network.GRPC.HighLevel.Client+import Network.GRPC.HighLevel.Generated+import Network.GRPC.LowLevel+import Options.Generic+import Prelude hiding (FilePath)++data Args = Args+ { bind :: Maybe ByteString <?> "grpc endpoint hostname (default \"localhost\")"+ , port :: Maybe Int <?> "grpc endpoint port (default 50051)"+ , payload :: Maybe TL.Text <?> "string to echo (default \"hullo!\")"+ } deriving (Generic, Show)+instance ParseRecord Args++main :: IO ()+main = do+ Args{..} <- getRecord "Runs the echo client"+ let+ pay = fromMaybe "hullo!" . unHelpful $ payload+ rqt = EchoRequest pay+ expected = EchoResponse pay+ cfg = ClientConfig+ (Host . fromMaybe "localhost" . unHelpful $ bind)+ (Port . fromMaybe 50051 . unHelpful $ port)+ [] Nothing Nothing+ withGRPC $ \g -> withClient g cfg $ \c -> do+ Echo{..} <- echoClient c+ echoDoEcho (ClientNormalRequest rqt 5 mempty) >>= \case+ ClientNormalResponse rsp _ _ StatusOk _+ | rsp == expected -> return ()+ | otherwise -> fail $ "Got unexpected response: '" ++ show rsp ++ "', expected: '" ++ show expected ++ "'"+ ClientNormalResponse _ _ _ st _ -> fail $ "Got unexpected status " ++ show st ++ " from call, expecting StatusOk"+ ClientErrorResponse e -> fail $ "Got client error: " ++ show e+ putStrLn $ "echo-client success: sent " ++ show pay ++ ", got " ++ show pay
+ examples/echo/echo-hs/EchoServer.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}++import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import GHC.Generics (Generic)+import Network.GRPC.HighLevel.Generated (GRPCMethodType (..),+ Host (..), Port (..),+ ServerRequest (..),+ ServerResponse (..),+ StatusCode (..),+ defaultServiceOptions,+ serverHost, serverPort)+import Options.Generic++import Echo++data Args = Args+ { bind :: Maybe ByteString <?> "grpc endpoint hostname (default \"localhost\")"+ , port :: Maybe Int <?> "grpc endpoint port (default 50051)"+ } deriving (Generic, Show)+instance ParseRecord Args++doEcho :: ServerRequest 'Normal EchoRequest EchoResponse+ -> IO (ServerResponse 'Normal EchoResponse)+doEcho (ServerNormalRequest _meta (EchoRequest pay)) = do+ return (ServerNormalResponse (EchoResponse pay) mempty StatusOk "")++main :: IO ()+main = do+ Args{..} <- getRecord "Runs the echo service"+ let opts = defaultServiceOptions+ { serverHost = Host . fromMaybe "localhost" . unHelpful $ bind+ , serverPort = Port . fromMaybe 50051 . unHelpful $ port+ }+ echoServer Echo{ echoDoEcho = doEcho } opts
+ examples/hellos/hellos-client/Main.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++import Control.Concurrent.Async+import Control.Monad+import qualified Data.ByteString.Lazy as BL+import Data.Function+import qualified Data.Text as T+import Data.Word+import GHC.Generics (Generic)+import Network.GRPC.LowLevel+import Proto3.Suite.Class++helloSS, helloCS, helloBi :: MethodName+helloSS = MethodName "/hellos.Hellos/HelloSS"+helloCS = MethodName "/hellos.Hellos/HelloCS"+helloBi = MethodName "/hellos.Hellos/HelloBi"++data SSRqt = SSRqt { ssName :: T.Text, ssNumReplies :: Word32 } deriving (Show, Eq, Ord, Generic)+instance Message SSRqt+data SSRpy = SSRpy { ssGreeting :: T.Text } deriving (Show, Eq, Ord, Generic)+instance Message SSRpy+data CSRqt = CSRqt { csMessage :: T.Text } deriving (Show, Eq, Ord, Generic)+instance Message CSRqt+data CSRpy = CSRpy { csNumRequests :: Word32 } deriving (Show, Eq, Ord, Generic)+instance Message CSRpy+data BiRqtRpy = BiRqtRpy { biMessage :: T.Text } deriving (Show, Eq, Ord, Generic)+instance Message BiRqtRpy++expect :: (Eq a, Monad m, Show a) => String -> a -> a -> m ()+expect ctx ex got+ | ex /= got = fail $ ctx ++ " error: expected " ++ show ex ++ ", got " ++ show got+ | otherwise = return ()++doHelloSS :: Client -> Int -> IO ()+doHelloSS c n = do+ rm <- clientRegisterMethodServerStreaming c helloSS+ let pay = SSRqt "server streaming mode" (fromIntegral n)+ enc = BL.toStrict . toLazyByteString $ pay+ err desc e = fail $ "doHelloSS: " ++ desc ++ " error: " ++ show e+ eea <- clientReader c rm n enc mempty $ \_md recv -> do+ n' <- flip fix (0::Int) $ \go i -> recv >>= \case+ Left e -> err "recv" e+ Right Nothing -> return i+ Right (Just bs) -> case fromByteString bs of+ Left e -> err "decoding" e+ Right r -> expect "doHelloSS/rpy" expay (ssGreeting r) >> go (i+1)+ expect "doHelloSS/cnt" n n'+ case eea of+ Left e -> err "clientReader" e+ Right (_, st, _)+ | st /= StatusOk -> fail "clientReader: non-OK status"+ | otherwise -> putStrLn "doHelloSS: RPC successful"+ where+ expay = "Hello there, server streaming mode!"++doHelloCS :: Client -> Int -> IO ()+doHelloCS c n = do+ rm <- clientRegisterMethodClientStreaming c helloCS+ let pay = CSRqt "client streaming payload"+ enc = BL.toStrict . toLazyByteString $ pay+ eea <- clientWriter c rm n mempty $ \send ->+ replicateM_ n $ send enc >>= \case+ Left e -> fail $ "doHelloCS: send error: " ++ show e+ Right{} -> return ()+ case eea of+ Left e -> fail $ "clientWriter error: " ++ show e+ Right (Nothing, _, _, _, _) -> fail "clientWriter error: no reply payload"+ Right (Just bs, _init, _trail, st, _dtls)+ | st /= StatusOk -> fail "clientWriter: non-OK status"+ | otherwise -> case fromByteString bs of+ Left e -> fail $ "Decoding error: " ++ show e+ Right dec -> do+ expect "doHelloCS/cnt" (fromIntegral n) (csNumRequests dec)+ putStrLn "doHelloCS: RPC successful"++doHelloBi :: Client -> Int -> IO ()+doHelloBi c n = do+ rm <- clientRegisterMethodBiDiStreaming c helloBi+ let pay = BiRqtRpy "bidi payload"+ enc = BL.toStrict . toLazyByteString $ pay+ err desc e = fail $ "doHelloBi: " ++ desc ++ " error: " ++ show e+ eea <- clientRW c rm n mempty $ \_getMD recv send writesDone -> do+ -- perform n writes on a worker thread+ thd <- async $ do+ replicateM_ n $ send enc >>= \case+ Left e -> err "send" e+ _ -> return ()+ writesDone >>= \case+ Left e -> err "writesDone" e+ _ -> return ()+ -- perform reads on this thread until the stream is terminated+ -- emd <- getMD; putStrLn ("getMD result: " ++ show emd)+ fix $ \go -> recv >>= \case+ Left e -> err "recv" e+ Right Nothing -> return ()+ Right (Just bs) -> case fromByteString bs of+ Left e -> err "decoding" e+ Right r -> when (r /= pay) (fail "Reply payload mismatch") >> go+ wait thd+ case eea of+ Left e -> err "clientRW'" e+ Right (_, st, _) -> do+ when (st /= StatusOk) $ fail $ "clientRW: non-OK status: " ++ show st+ putStrLn "doHelloBi: RPC successful"++highlevelMain :: IO ()+highlevelMain = withGRPC $ \g ->+ withClient g (ClientConfig "localhost" 50051 [] Nothing Nothing) $ \c -> do+ let n = 100000+ putStrLn "-------------- HelloSS --------------"+ doHelloSS c n+ putStrLn "-------------- HelloCS --------------"+ doHelloCS c n+ putStrLn "-------------- HelloBi --------------"+ doHelloBi c n++main :: IO ()+main = highlevelMain
+ examples/hellos/hellos-server/Main.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++import Control.Monad+import Data.Function (fix)+import Data.Monoid+import qualified Data.Text as T+import Data.Word+import GHC.Generics (Generic)+import Network.GRPC.HighLevel.Server+import qualified Network.GRPC.HighLevel.Server.Unregistered as U+import Network.GRPC.LowLevel+import Proto3.Suite.Class++serverMeta :: MetadataMap+serverMeta = [("test_meta", "test_meta_value")]++data SSRqt = SSRqt { ssName :: T.Text, ssNumReplies :: Word32 } deriving (Show, Eq, Ord, Generic)+instance Message SSRqt+data SSRpy = SSRpy { ssGreeting :: T.Text } deriving (Show, Eq, Ord, Generic)+instance Message SSRpy+data CSRqt = CSRqt { csMessage :: T.Text } deriving (Show, Eq, Ord, Generic)+instance Message CSRqt+data CSRpy = CSRpy { csNumRequests :: Word32 } deriving (Show, Eq, Ord, Generic)+instance Message CSRpy+data BiRqtRpy = BiRqtRpy { biMessage :: T.Text } deriving (Show, Eq, Ord, Generic)+instance Message BiRqtRpy++expect :: (Eq a, Monad m, Show a) => String -> a -> a -> m ()+expect ctx ex got+ | ex /= got = fail $ ctx ++ " error: expected " ++ show ex ++ ", got " ++ show got+ | otherwise = return ()++helloSS :: Handler 'ServerStreaming+helloSS = ServerStreamHandler "/hellos.Hellos/HelloSS" $ \sc send -> do+ let SSRqt{..} = payload sc+ replicateM_ (fromIntegral ssNumReplies) $ do+ eea <- send $ SSRpy $ "Hello there, " <> ssName <> "!"+ case eea of+ Left e -> fail $ "helloSS error: " ++ show e+ Right{} -> return ()+ return (serverMeta, StatusOk, StatusDetails "helloSS response details")++helloCS :: Handler 'ClientStreaming+helloCS = ClientStreamHandler "/hellos.Hellos/HelloCS" $ \_ recv -> flip fix 0 $ \go n ->+ recv >>= \case+ Left e -> fail $ "helloCS error: " ++ show e+ Right Nothing -> return (Just (CSRpy n), mempty, StatusOk, StatusDetails "helloCS details")+ Right (Just rqt) -> do+ expect "helloCS" "client streaming payload" (csMessage rqt)+ go (n+1)++helloBi :: Handler 'BiDiStreaming+helloBi = BiDiStreamHandler "/hellos.Hellos/HelloBi" $ \_ recv send -> fix $ \go ->+ recv >>= \case+ Left e -> fail $ "helloBi recv error: " ++ show e+ Right Nothing -> return (mempty, StatusOk, StatusDetails "helloBi details")+ Right (Just rqt) -> do+ expect "helloBi" "bidi payload" (biMessage rqt)+ send rqt >>= \case+ Left e -> fail $ "helloBi send error: " ++ show e+ _ -> go++highlevelMainUnregistered :: IO ()+highlevelMainUnregistered =+ U.serverLoop defaultOptions{+ optServerStreamHandlers = [helloSS]+ , optClientStreamHandlers = [helloCS]+ , optBiDiStreamHandlers = [helloBi]+ }++main :: IO ()+main = highlevelMainUnregistered++defConfig :: ServerConfig+defConfig = ServerConfig "localhost" 50051 [] [] [] [] [] Nothing
+ examples/tutorial/Arithmetic.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++-- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!+module Arithmetic where+import qualified Prelude as Hs+import qualified Proto3.Suite.DotProto as HsProtobuf+import qualified Proto3.Suite.Types as HsProtobuf+import qualified Proto3.Suite.Class as HsProtobuf+import qualified Proto3.Suite.JSONPB as HsJSONPB+import Proto3.Suite.JSONPB ((.=), (.:))+import qualified Proto3.Wire as HsProtobuf+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.Applicative as Hs+import qualified Control.Monad as Hs+import qualified Data.Text.Lazy as Hs (Text)+import qualified Data.ByteString as Hs+import qualified Data.String as Hs (fromString)+import qualified Data.Vector as Hs (Vector)+import qualified Data.Int as Hs (Int16, Int32, Int64)+import qualified Data.Word as Hs (Word16, Word32, Word64)+import qualified Data.Proxy as Proxy+import qualified GHC.Generics as Hs+import qualified GHC.Enum as Hs+import Network.GRPC.HighLevel.Generated as HsGRPC+import Network.GRPC.HighLevel.Client as HsGRPC+import Network.GRPC.HighLevel.Server as HsGRPC hiding (serverLoop)+import Network.GRPC.HighLevel.Server.Unregistered as HsGRPC+ (serverLoop)+ +data Arithmetic request response = Arithmetic{arithmeticAdd ::+ request 'HsGRPC.Normal Arithmetic.TwoInts+ Arithmetic.OneInt+ ->+ Hs.IO (response 'HsGRPC.Normal Arithmetic.OneInt),+ arithmeticRunningSum ::+ request 'HsGRPC.ClientStreaming Arithmetic.OneInt+ Arithmetic.OneInt+ ->+ Hs.IO+ (response 'HsGRPC.ClientStreaming+ Arithmetic.OneInt)}+ deriving Hs.Generic+ +arithmeticServer ::+ Arithmetic HsGRPC.ServerRequest HsGRPC.ServerResponse ->+ HsGRPC.ServiceOptions -> Hs.IO ()+arithmeticServer+ Arithmetic{arithmeticAdd = arithmeticAdd,+ arithmeticRunningSum = arithmeticRunningSum}+ (ServiceOptions serverHost serverPort useCompression+ userAgentPrefix userAgentSuffix initialMetadata sslConfig logger)+ = (HsGRPC.serverLoop+ HsGRPC.defaultOptions{HsGRPC.optNormalHandlers =+ [(HsGRPC.UnaryHandler+ (HsGRPC.MethodName "/arithmetic.Arithmetic/Add")+ (HsGRPC.convertGeneratedServerHandler arithmeticAdd))],+ HsGRPC.optClientStreamHandlers =+ [(HsGRPC.ClientStreamHandler+ (HsGRPC.MethodName "/arithmetic.Arithmetic/RunningSum")+ (HsGRPC.convertGeneratedServerReaderHandler+ arithmeticRunningSum))],+ HsGRPC.optServerStreamHandlers = [],+ HsGRPC.optBiDiStreamHandlers = [], optServerHost = serverHost,+ optServerPort = serverPort, optUseCompression = useCompression,+ optUserAgentPrefix = userAgentPrefix,+ optUserAgentSuffix = userAgentSuffix,+ optInitialMetadata = initialMetadata, optSSLConfig = sslConfig,+ optLogger = logger})+ +arithmeticClient ::+ HsGRPC.Client ->+ Hs.IO (Arithmetic HsGRPC.ClientRequest HsGRPC.ClientResult)+arithmeticClient client+ = (Hs.pure Arithmetic) <*>+ ((Hs.pure (HsGRPC.clientRequest client)) <*>+ (HsGRPC.clientRegisterMethod client+ (HsGRPC.MethodName "/arithmetic.Arithmetic/Add")))+ <*>+ ((Hs.pure (HsGRPC.clientRequest client)) <*>+ (HsGRPC.clientRegisterMethod client+ (HsGRPC.MethodName "/arithmetic.Arithmetic/RunningSum")))+ +data TwoInts = TwoInts{twoIntsX :: Hs.Int32, twoIntsY :: Hs.Int32}+ deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+ +instance HsProtobuf.Named TwoInts where+ nameOf _ = (Hs.fromString "TwoInts")+ +instance HsProtobuf.Message TwoInts where+ encodeMessage _ TwoInts{twoIntsX = twoIntsX, twoIntsY = twoIntsY}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ twoIntsX),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ twoIntsY)])+ decodeMessage _+ = (Hs.pure TwoInts) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim HsProtobuf.Int32)+ (HsProtobuf.Single "x")+ []+ Hs.Nothing),+ (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.Prim HsProtobuf.Int32)+ (HsProtobuf.Single "y")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB TwoInts where+ toJSONPB (TwoInts f1 f2) = (HsJSONPB.object ["x" .= f1, "y" .= f2])+ toEncodingPB (TwoInts f1 f2)+ = (HsJSONPB.pairs ["x" .= f1, "y" .= f2])+ +instance HsJSONPB.FromJSONPB TwoInts where+ parseJSONPB+ = (HsJSONPB.withObject "TwoInts"+ (\ obj -> (Hs.pure TwoInts) <*> obj .: "x" <*> obj .: "y"))+ +instance HsJSONPB.ToJSON TwoInts where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON TwoInts where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema TwoInts where+ declareNamedSchema _+ = do let declare_x = HsJSONPB.declareSchemaRef+ twoIntsX <- declare_x Proxy.Proxy+ let declare_y = HsJSONPB.declareSchemaRef+ twoIntsY <- declare_y Proxy.Proxy+ let _ = Hs.pure TwoInts <*> HsJSONPB.asProxy declare_x <*>+ HsJSONPB.asProxy declare_y+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "TwoInts",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("x", twoIntsX), ("y", twoIntsY)]}})+ +data OneInt = OneInt{oneIntResult :: Hs.Int32}+ deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+ +instance HsProtobuf.Named OneInt where+ nameOf _ = (Hs.fromString "OneInt")+ +instance HsProtobuf.Message OneInt where+ encodeMessage _ OneInt{oneIntResult = oneIntResult}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ oneIntResult)])+ decodeMessage _+ = (Hs.pure OneInt) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim HsProtobuf.Int32)+ (HsProtobuf.Single "result")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB OneInt where+ toJSONPB (OneInt f1) = (HsJSONPB.object ["result" .= f1])+ toEncodingPB (OneInt f1) = (HsJSONPB.pairs ["result" .= f1])+ +instance HsJSONPB.FromJSONPB OneInt where+ parseJSONPB+ = (HsJSONPB.withObject "OneInt"+ (\ obj -> (Hs.pure OneInt) <*> obj .: "result"))+ +instance HsJSONPB.ToJSON OneInt where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON OneInt where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema OneInt where+ declareNamedSchema _+ = do let declare_result = HsJSONPB.declareSchemaRef+ oneIntResult <- declare_result Proxy.Proxy+ let _ = Hs.pure OneInt <*> HsJSONPB.asProxy declare_result+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = Hs.Just "OneInt",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("result", oneIntResult)]}})
+ examples/tutorial/ArithmeticClient.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++import Arithmetic+import Network.GRPC.HighLevel.Generated++clientConfig :: ClientConfig+clientConfig = ClientConfig { clientServerHost = "localhost"+ , clientServerPort = 50051+ , clientArgs = []+ , clientSSLConfig = Nothing+ , clientAuthority = Nothing+ }++main :: IO ()+main = withGRPCClient clientConfig $ \client -> do+ Arithmetic{..} <- arithmeticClient client++ -- Request for the Add RPC+ ClientNormalResponse (OneInt x) _meta1 _meta2 _status _details+ <- arithmeticAdd (ClientNormalRequest (TwoInts 2 2) 1 [])+ putStrLn ("2 + 2 = " ++ show x)++ -- Request for the RunningSum RPC+ ClientWriterResponse reply _streamMeta1 _streamMeta2 streamStatus streamDtls+ <- arithmeticRunningSum $ ClientWriterRequest 1 [] $ \send -> do+ eithers <- mapM send [OneInt 1, OneInt 2, OneInt 3]+ :: IO [Either GRPCIOError ()]+ case sequence eithers of+ Left err -> error ("Error while streaming: " ++ show err)+ Right _ -> return ()++ case reply of+ Just (OneInt y) -> print ("1 + 2 + 3 = " ++ show y)+ Nothing -> putStrLn ("Client stream failed with status "+ ++ show streamStatus+ ++ " and details "+ ++ show streamDtls)+ return ()
+ examples/tutorial/ArithmeticServer.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++import Arithmetic+import Network.GRPC.HighLevel.Generated++import Data.String (fromString)++handlers :: Arithmetic ServerRequest ServerResponse+handlers = Arithmetic { arithmeticAdd = addHandler+ , arithmeticRunningSum = runningSumHandler+ }++addHandler :: ServerRequest 'Normal TwoInts OneInt+ -> IO (ServerResponse 'Normal OneInt)+addHandler (ServerNormalRequest _metadata (TwoInts x y)) = do+ let answer = OneInt (x + y)+ return (ServerNormalResponse answer+ [("metadata_key_one", "metadata_value")]+ StatusOk+ "addition is easy!")+++runningSumHandler :: ServerRequest 'ClientStreaming OneInt OneInt+ -> IO (ServerResponse 'ClientStreaming OneInt)+runningSumHandler (ServerReaderRequest _metadata recv) =+ loop 0+ where loop !i =+ do msg <- recv+ case msg of+ Left err -> return (ServerReaderResponse+ Nothing+ []+ StatusUnknown+ (fromString (show err)))+ Right (Just (OneInt x)) -> loop (i + x)+ Right Nothing -> return (ServerReaderResponse+ (Just (OneInt i))+ []+ StatusOk+ "")++options :: ServiceOptions+options = defaultServiceOptions++main :: IO ()+main = arithmeticServer handlers options
+ grpc-haskell.cabal view
@@ -0,0 +1,233 @@+name: grpc-haskell+version: 0.0.0.0+synopsis: Haskell implementation of gRPC layered on shared C library.+homepage: https://github.com/awakenetworks/gRPC-haskell+license: Apache-2.0+license-file: LICENSE+author: Awake Networks+maintainer: opensource@awakenetworks.com+copyright: Copyright 2016 Awake Networks+category: Network+build-type: Simple+cabal-version: >=1.10++Flag Debug+ Description: Adds debug logging.+ Manual: True+ Default: False++flag with-examples+ description: Also build example executables.+ manual: True+ default: False++library+ build-depends:+ base >=4.8 && <5.0+ , bytestring ==0.10.*+ , proto3-suite+ , proto3-wire+ , grpc-haskell-core++ , async >=2.1 && <2.3+ , managed >= 1.0.5++ exposed-modules:+ Network.GRPC.HighLevel+ Network.GRPC.HighLevel.Generated+ Network.GRPC.HighLevel.Server+ Network.GRPC.HighLevel.Server.Unregistered+ Network.GRPC.HighLevel.Client+ default-language: Haskell2010+ ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-unused-do-bind+ hs-source-dirs: src+ default-extensions: CPP+ CC-Options: -std=c99+ if flag(debug)+ CPP-Options: -DDEBUG+ CC-Options: -DGRPC_HASKELL_DEBUG -std=c99++executable hellos-server+ if flag(with-examples)+ build-depends:+ base >=4.8 && <5.0+ , async+ , bytestring == 0.10.*+ , containers >=0.5 && <0.7+ , grpc-haskell+ , grpc-haskell-core+ , proto3-suite+ , proto3-wire+ , text+ , transformers+ else+ buildable: False+ default-language: Haskell2010+ ghc-options: -Wall -g -threaded -rtsopts -with-rtsopts=-N -O2+ hs-source-dirs: examples/hellos/hellos-server+ main-is: Main.hs++executable hellos-client+ if flag(with-examples)+ build-depends:+ base >=4.8 && <5.0+ , async+ , bytestring == 0.10.*+ , containers >=0.5 && <0.7+ , grpc-haskell+ , grpc-haskell-core+ , proto3-suite+ , proto3-wire+ , text+ , transformers+ else+ buildable: False+ default-language: Haskell2010+ ghc-options: -Wall -g -threaded -rtsopts -with-rtsopts=-N -O2+ hs-source-dirs: examples/hellos/hellos-client+ main-is: Main.hs++executable echo-server+ if flag(with-examples)+ build-depends:+ base >=4.8 && <5.0+ , async+ , bytestring == 0.10.*+ , containers >=0.5 && <0.7+ , grpc-haskell+ , grpc-haskell-core+ , optparse-generic+ , proto3-suite+ , proto3-wire+ , text+ , vector+ other-modules:+ Echo+ else+ buildable: False+ default-language: Haskell2010+ ghc-options: -Wall -g -threaded -rtsopts -with-rtsopts=-N -O2+ hs-source-dirs: examples/echo/echo-hs+ main-is: EchoServer.hs+++executable arithmetic-server+ if flag(with-examples)+ build-depends:+ base >=4.8 && <5.0+ , async+ , bytestring == 0.10.*+ , containers >=0.5 && <0.7+ , grpc-haskell+ , grpc-haskell-core+ , optparse-generic+ , proto3-suite+ , proto3-wire+ , text+ , vector+ other-modules:+ Arithmetic+ else+ buildable: False+ default-language: Haskell2010+ ghc-options: -Wall -g -threaded -rtsopts -with-rtsopts=-N -O2+ hs-source-dirs: examples/tutorial/+ main-is: ArithmeticServer.hs++executable arithmetic-client+ if flag(with-examples)+ build-depends:+ base >=4.8 && <5.0+ , async+ , bytestring == 0.10.*+ , containers >=0.5 && <0.7+ , grpc-haskell+ , grpc-haskell-core+ , optparse-generic+ , proto3-suite+ , proto3-wire+ , text+ , vector+ other-modules:+ Arithmetic+ else+ buildable: False+ default-language: Haskell2010+ ghc-options: -Wall -g -threaded -rtsopts -with-rtsopts=-N -O2+ hs-source-dirs: examples/tutorial/+ main-is: ArithmeticClient.hs++executable echo-client+ if flag(with-examples)+ build-depends:+ base >=4.8 && <5.0+ , async+ , bytestring == 0.10.*+ , containers >=0.5 && <0.7+ , grpc-haskell+ , grpc-haskell-core+ , optparse-generic+ , proto3-suite+ , proto3-wire+ , text+ , random+ , vector+ other-modules:+ Echo+ else+ buildable: False+ default-language: Haskell2010+ ghc-options: -Wall -g -threaded -rtsopts -with-rtsopts=-N -O2+ hs-source-dirs: examples/echo/echo-hs+ main-is: EchoClient.hs++test-suite tests+ build-depends:+ base >=4.8 && <5.0+ , grpc-haskell+ , bytestring ==0.10.*+ , unix+ , time+ , async+ , tasty >= 0.11+ , tasty-hunit >= 0.9+ , tasty-quickcheck >= 0.8.4+ , containers >=0.5 && <0.7+ , managed >= 1.0.0 && < 1.1+ , pipes >=4.1 && <=4.4+ , proto3-suite+ , transformers+ , safe+ , clock >=0.6.0 && <0.8.0+ , turtle >= 1.2.0+ , text+ , QuickCheck >=2.8 && <3.0+ other-modules:+ GeneratedTests+ default-language: Haskell2010+ ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-unused-do-bind -g -threaded -rtsopts+ hs-source-dirs: tests+ main-is: Properties.hs+ type: exitcode-stdio-1.0+ default-extensions: CPP+ if flag(debug)+ CPP-Options: -DDEBUG+ CC-Options: -DGRPC_HASKELL_DEBUG++benchmark bench+ type: exitcode-stdio-1.0+ build-depends:+ base >=4.8 && <5.0+ , grpc-haskell+ , async ==2.1.*+ , criterion ==1.1.*+ , proto3-suite+ , bytestring ==0.10.*+ , random >=1.0.0+ hs-source-dirs: bench+ main-is: Bench.hs+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+ if flag(debug)+ CPP-Options: -DDEBUG+ CC-Options: -DGRPC_HASKELL_DEBUG+ default-language: Haskell2010
+ src/Network/GRPC/HighLevel.hs view
@@ -0,0 +1,54 @@+module Network.GRPC.HighLevel (++-- * Types+ MetadataMap(..)+, MethodName(..)+, StatusDetails(..)+, StatusCode(..)+, GRPCIOError(..)+, GRPCImpl(..)+, MkHandler+, ServiceOptions(..)++-- * Server+, Handler(..)+, ServerOptions(..)+, defaultOptions+, serverLoop+, ServerCall(..)+, serverCallCancel+, serverCallIsExpired++-- * Client+, NormalRequestResult(..)+, ClientCall+, clientCallCancel++-- * Client and Server Auth+, AuthContext+, AuthProperty(..)+, getAuthProperties+, addAuthProperty++-- * Server Auth+, ServerSSLConfig(..)+, ProcessMeta+, AuthProcessorResult(..)+, SslClientCertificateRequestType(..)++-- * Client Auth+, ClientSSLConfig(..)+, ClientSSLKeyCertPair(..)+, ClientMetadataCreate+, ClientMetadataCreateResult(..)+, AuthMetadataContext(..)++-- * Streaming utilities+, StreamSend+, StreamRecv+)+ where++import Network.GRPC.HighLevel.Server+import Network.GRPC.HighLevel.Generated+import Network.GRPC.LowLevel
+ src/Network/GRPC/HighLevel/Client.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.GRPC.HighLevel.Client+ ( ClientError(..)+ , ClientRegisterable(..)+ , ClientRequest(..)+ , ClientResult(..)+ , GRPCMethodType(..)+ , MetadataMap(..)+ , RegisteredMethod+ , ServiceClient+ , StatusCode(..)+ , StatusDetails(..)+ , StreamRecv+ , StreamSend+ , TimeoutSeconds+ , WritesDone++ , LL.Client+ , LL.ClientConfig(..)+ , LL.ClientSSLConfig(..)+ , LL.ClientSSLKeyCertPair(..)+ , LL.Host(..)+ , LL.Port(..)++ , clientRequest++ -- * Client utility functions+ , acquireClient+ , simplifyUnary+ )++where++import Control.Monad.Managed (Managed, liftIO,+ managed)+import qualified Data.ByteString.Lazy as BL+import Network.GRPC.HighLevel.Server (convertRecv,+ convertSend)+import Network.GRPC.LowLevel (GRPCIOError (..),+ GRPCMethodType (..),+ MetadataMap (..),+ StatusCode (..),+ StatusDetails (..),+ StreamRecv, StreamSend)+import qualified Network.GRPC.LowLevel as LL+import Network.GRPC.LowLevel.CompletionQueue (TimeoutSeconds)+import Network.GRPC.LowLevel.Op (WritesDone)+import Proto3.Suite (Message, fromByteString,+ toLazyByteString)+import Proto3.Wire.Decode (ParseError)++newtype RegisteredMethod (mt :: GRPCMethodType) request response+ = RegisteredMethod (LL.RegisteredMethod mt)+ deriving Show++type ServiceClient service = service ClientRequest ClientResult++data ClientError+ = ClientErrorNoParse ParseError+ | ClientIOError GRPCIOError+ deriving (Show, Eq)++data ClientRequest (streamType :: GRPCMethodType) request response where+ ClientNormalRequest :: request -> TimeoutSeconds -> MetadataMap -> ClientRequest 'Normal request response+ ClientWriterRequest :: TimeoutSeconds -> MetadataMap -> (StreamSend request -> IO ()) -> ClientRequest 'ClientStreaming request response+ -- | The final field will be invoked once, and it should repeatedly+ -- invoke its final argument (of type @(StreamRecv response)@)+ -- in order to obtain the streaming response incrementally.+ ClientReaderRequest :: request -> TimeoutSeconds -> MetadataMap -> (MetadataMap -> StreamRecv response -> IO ()) -> ClientRequest 'ServerStreaming request response+ ClientBiDiRequest :: TimeoutSeconds -> MetadataMap -> (MetadataMap -> StreamRecv response -> StreamSend request -> WritesDone -> IO ()) -> ClientRequest 'BiDiStreaming request response++data ClientResult (streamType :: GRPCMethodType) response where+ ClientNormalResponse :: response -> MetadataMap -> MetadataMap -> StatusCode -> StatusDetails -> ClientResult 'Normal response+ ClientWriterResponse :: Maybe response -> MetadataMap -> MetadataMap -> StatusCode -> StatusDetails -> ClientResult 'ClientStreaming response+ ClientReaderResponse :: MetadataMap -> StatusCode -> StatusDetails -> ClientResult 'ServerStreaming response+ ClientBiDiResponse :: MetadataMap -> StatusCode -> StatusDetails -> ClientResult 'BiDiStreaming response+ ClientErrorResponse :: ClientError -> ClientResult streamType response++class ClientRegisterable (methodType :: GRPCMethodType) where+ clientRegisterMethod :: LL.Client+ -> LL.MethodName+ -> IO (RegisteredMethod methodType request response)++instance ClientRegisterable 'Normal where+ clientRegisterMethod client methodName =+ RegisteredMethod <$> LL.clientRegisterMethodNormal client methodName++instance ClientRegisterable 'ClientStreaming where+ clientRegisterMethod client methodName =+ RegisteredMethod <$> LL.clientRegisterMethodClientStreaming client methodName++instance ClientRegisterable 'ServerStreaming where+ clientRegisterMethod client methodName =+ RegisteredMethod <$> LL.clientRegisterMethodServerStreaming client methodName++instance ClientRegisterable 'BiDiStreaming where+ clientRegisterMethod client methodName =+ RegisteredMethod <$> LL.clientRegisterMethodBiDiStreaming client methodName++clientRequest :: (Message request, Message response) =>+ LL.Client -> RegisteredMethod streamType request response+ -> ClientRequest streamType request response -> IO (ClientResult streamType response)+clientRequest client (RegisteredMethod method) (ClientNormalRequest req timeout meta) =+ mkResponse <$> LL.clientRequest client method timeout (BL.toStrict (toLazyByteString req)) meta+ where+ mkResponse (Left ioError_) = ClientErrorResponse (ClientIOError ioError_)+ mkResponse (Right rsp) =+ case fromByteString (LL.rspBody rsp) of+ Left err -> ClientErrorResponse (ClientErrorNoParse err)+ Right parsedRsp ->+ ClientNormalResponse parsedRsp (LL.initMD rsp) (LL.trailMD rsp) (LL.rspCode rsp) (LL.details rsp)+clientRequest client (RegisteredMethod method) (ClientWriterRequest timeout meta handler) =+ mkResponse <$> LL.clientWriter client method timeout meta (handler . convertSend)+ where+ mkResponse (Left ioError_) = ClientErrorResponse (ClientIOError ioError_)+ mkResponse (Right (rsp_, initMD_, trailMD_, rspCode_, details_)) =+ case maybe (Right Nothing) (fmap Just . fromByteString) rsp_ of+ Left err -> ClientErrorResponse (ClientErrorNoParse err)+ Right parsedRsp ->+ ClientWriterResponse parsedRsp initMD_ trailMD_ rspCode_ details_+clientRequest client (RegisteredMethod method) (ClientReaderRequest req timeout meta handler) =+ mkResponse <$> LL.clientReader client method timeout (BL.toStrict (toLazyByteString req)) meta (\m recv -> handler m (convertRecv recv))+ where+ mkResponse (Left ioError_) = ClientErrorResponse (ClientIOError ioError_)+ mkResponse (Right (meta_, rspCode_, details_)) =+ ClientReaderResponse meta_ rspCode_ details_+clientRequest client (RegisteredMethod method) (ClientBiDiRequest timeout meta handler) =+ mkResponse <$> LL.clientRW client method timeout meta (\_m recv send writesDone -> handler meta (convertRecv recv) (convertSend send) writesDone)+ where+ mkResponse (Left ioError_) = ClientErrorResponse (ClientIOError ioError_)+ mkResponse (Right (meta_, rspCode_, details_)) =+ ClientBiDiResponse meta_ rspCode_ details_++acquireClient+ :: LL.ClientConfig+ -- ^ The client configuration (host, port, SSL settings, etc)+ -> (LL.Client -> IO (ServiceClient service))+ -- ^ The client implementation (typically generated)+ -> Managed (ServiceClient service)+acquireClient cfg impl = do+ g <- managed LL.withGRPC+ c <- managed (LL.withClient g cfg)+ liftIO (impl c)++-- | A utility for simplifying gRPC client requests in common cases; you can use+-- this to avoid 'ClientRequest' and 'ClientResponse' pattern-matching+-- boilerplate at call sites.+simplifyUnary :: TimeoutSeconds+ -- ^ RPC call timeout, in seconds+ -> MetadataMap+ -- ^ RPC call metadata+ -> (ClientError -> IO (b, StatusDetails))+ -- ^ Handler for client errors+ -> (b -> StatusCode -> StatusDetails -> IO (b, StatusDetails))+ -- ^ Handler for non-StatusOK responses+ -> (ClientRequest 'Normal a b -> IO (ClientResult 'Normal b))+ -- ^ gRPC function implementation (typically generated by gRPC-haskell)+ -> (a -> IO (b, StatusDetails))+ -- ^ The simplified happy-path (StatusOk) unary call action+simplifyUnary timeout meta clientError nonStatusOkError f x = do++ let request = ClientNormalRequest x timeout meta++ response <- f request++ case response of+ ClientNormalResponse y _ _ StatusOk details+ -> pure (y, details)++ ClientNormalResponse y _ _ code details+ -> nonStatusOkError y code details++ ClientErrorResponse err+ -> clientError err
+ src/Network/GRPC/HighLevel/Generated.hs view
@@ -0,0 +1,97 @@++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.GRPC.HighLevel.Generated (+ -- * Types+ MetadataMap(..)+, MethodName(..)+, GRPCMethodType(..)+, GRPCImpl(..)+, MkHandler+, Host(..)+, Port(..)+, StatusDetails(..)+, StatusCode(..)+, GRPCIOError(..)++ -- * Server+, ServiceOptions(..)+, defaultServiceOptions+, ServerCall(..)+, serverCallCancel+, serverCallIsExpired+, ServerRequest(..)+, ServerResponse(..)++ -- * Server Auth+, ServerSSLConfig(..)++ -- * Client+, withGRPCClient+, ClientConfig(..)+, ClientError(..)+, ClientRequest(..)+, ClientResult(..)+)+where++import Network.GRPC.HighLevel.Server+import Network.GRPC.HighLevel.Client+import Network.GRPC.LowLevel+import Network.GRPC.LowLevel.Call+import System.IO (hPutStrLn, stderr)++-- | Used at the kind level as a parameter to service definitions+-- generated by the grpc compiler, with the effect of having the+-- field types reduce to the appropriate types for the method types.+data GRPCImpl = ServerImpl | ClientImpl++-- | GHC does not let us partially apply a type family. However, we+-- can define a type to use as an 'interpreter', and then use this+-- 'interpreter' type fully applied to get the same effect.+type family MkHandler (impl :: GRPCImpl) (methodType :: GRPCMethodType) i o++type instance MkHandler 'ServerImpl 'Normal i o = ServerHandler i o+type instance MkHandler 'ServerImpl 'ClientStreaming i o = ServerReaderHandler i o+type instance MkHandler 'ServerImpl 'ServerStreaming i o = ServerWriterHandler i o+type instance MkHandler 'ServerImpl 'BiDiStreaming i o = ServerRWHandler i o++-- | Options for a service that was generated from a .proto file. This is+-- essentially 'ServerOptions' with the handler fields removed.+data ServiceOptions = ServiceOptions+ { serverHost :: Host+ -- ^ Name of the host the server is running on.+ , serverPort :: Port+ -- ^ Port on which to listen for requests.+ , useCompression :: Bool+ -- ^ Whether to use compression when communicating with the client.+ , userAgentPrefix :: String+ -- ^ Optional custom prefix to add to the user agent string.+ , userAgentSuffix :: String+ -- ^ Optional custom suffix to add to the user agent string.+ , initialMetadata :: MetadataMap+ -- ^ Metadata to send at the beginning of each call.+ , sslConfig :: Maybe ServerSSLConfig+ -- ^ Security configuration.+ , logger :: String -> IO ()+ -- ^ Logging function to use to log errors in handling calls.+ }++defaultServiceOptions :: ServiceOptions+defaultServiceOptions = ServiceOptions+ -- names are fully qualified because we use the same fields in LowLevel.+ { Network.GRPC.HighLevel.Generated.serverHost = "localhost"+ , Network.GRPC.HighLevel.Generated.serverPort = 50051+ , Network.GRPC.HighLevel.Generated.useCompression = False+ , Network.GRPC.HighLevel.Generated.userAgentPrefix = "grpc-haskell/0.0.0"+ , Network.GRPC.HighLevel.Generated.userAgentSuffix = ""+ , Network.GRPC.HighLevel.Generated.initialMetadata = mempty+ , Network.GRPC.HighLevel.Generated.sslConfig = Nothing+ , Network.GRPC.HighLevel.Generated.logger = hPutStrLn stderr+ }++withGRPCClient :: ClientConfig -> (Client -> IO a) -> IO a+withGRPCClient c f = withGRPC $ \grpc -> withClient grpc c $ \client -> f client
+ src/Network/GRPC/HighLevel/Server.hs view
@@ -0,0 +1,289 @@+{-# 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 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 handler call =+ do let call' = call { payload = () }+ ServerNormalResponse rsp meta stsCode stsDetails <-+ handler (ServerNormalRequest call' (payload call))+ return (rsp, meta, stsCode, stsDetails)++convertServerHandler :: (Message a, Message b)+ => ServerHandler a b+ -> ServerHandlerLL+convertServerHandler f c = case fromByteString (payload c) of+ Left x -> CE.throw (GRPCIODecodeError $ show x)+ Right x -> do (y, tm, sc, sd) <- f (fmap (const x) c)+ return (toBS y, tm, sc, 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 handler call recv =+ do ServerReaderResponse rsp meta stsCode stsDetails <-+ handler (ServerReaderRequest call recv)+ return (rsp, meta, stsCode, stsDetails)++convertServerReaderHandler :: (Message a, Message b)+ => ServerReaderHandler a b+ -> ServerReaderHandlerLL+convertServerReaderHandler f c recv =+ serialize <$> f c (convertRecv recv)+ where+ serialize (mmsg, m, sc, sd) = (toBS <$> mmsg, m, sc, 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 handler call send =+ do let call' = call { payload = () }+ ServerWriterResponse meta stsCode stsDetails <-+ handler (ServerWriterRequest call' (payload call) send)+ return (meta, stsCode, stsDetails)++convertServerWriterHandler :: (Message a, Message b) =>+ ServerWriterHandler a b+ -> ServerWriterHandlerLL+convertServerWriterHandler f c send =+ f (convert <$> c) (convertSend send)+ where+ convert bs = case fromByteString bs of+ Left x -> CE.throw (GRPCIODecodeError $ show x)+ Right x -> 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 handler call recv send =+ do ServerBiDiResponse meta stsCode stsDetails <-+ handler (ServerBiDiRequest call recv send)+ return (meta, stsCode, stsDetails)++convertServerRWHandler :: (Message a, Message b)+ => ServerRWHandler a b+ -> ServerRWHandlerLL+convertServerRWHandler f c recv send =+ f c (convertRecv recv) (convertSend send)++convertRecv :: Message a => StreamRecv ByteString -> StreamRecv a+convertRecv =+ fmap $ \e -> do+ msg <- e+ case msg of+ Nothing -> return Nothing+ Just bs -> case fromByteString bs of+ Left x -> Left (GRPCIODecodeError $ show x)+ Right x -> return (Just x)++convertSend :: Message a => StreamSend ByteString -> StreamSend a+convertSend s = s . toBS++toBS :: Message a => a -> ByteString+toBS = BL.toStrict . 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 m) = handlerMethodName m++handlerMethodName :: Handler a -> MethodName+handlerMethodName (UnaryHandler m _) = m+handlerMethodName (ClientStreamHandler m _) = m+handlerMethodName (ServerStreamHandler m _) = m+handlerMethodName (BiDiStreamHandler m _) = 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 _ (Right _) = return ()+handleCallError _ (Left GRPCIOTimeout) =+ -- Probably a benign timeout (such as a client disappearing), noop for now.+ return ()+handleCallError _ (Left GRPCIOShutdown) =+ -- Server shutting down. Benign.+ return ()+handleCallError logMsg (Left (GRPCIODecodeError e)) =+ logMsg $ "Decoding error: " ++ show e+handleCallError logMsg (Left (GRPCIOHandlerException e)) =+ logMsg $ "Handler exception caught: " ++ show e+handleCallError logMsg (Left x) =+ logMsg $ show x ++ ": This probably indicates a bug in gRPC-haskell. Please report this error."++loopWError :: Int+ -> ServerOptions+ -> IO (Either GRPCIOError a)+ -> IO ()+loopWError i o@ServerOptions{..} f = do+ when (i `mod` 100 == 0) $ putStrLn $ "i = " ++ show i+ f >>= handleCallError optLogger+ loopWError (i + 1) o f++-- TODO: options for setting initial/trailing metadata+handleLoop :: Server+ -> ServerOptions+ -> (Handler a, RegisteredMethod a)+ -> IO ()+handleLoop s o (UnaryHandler _ f, rm) =+ loopWError 0 o $ serverHandleNormalCall s rm mempty $ convertServerHandler f+handleLoop s o (ClientStreamHandler _ f, rm) =+ loopWError 0 o $ serverReader s rm mempty $ convertServerReaderHandler f+handleLoop s o (ServerStreamHandler _ f, rm) =+ loopWError 0 o $ serverWriter s rm mempty $ convertServerWriterHandler f+handleLoop s o (BiDiStreamHandler _ f, rm) =+ loopWError 0 o $ serverRW s rm mempty $ convertServerRWHandler f++data ServerOptions = ServerOptions+ { optNormalHandlers :: [Handler 'Normal]+ -- ^ Handlers for unary (non-streaming) calls.+ , optClientStreamHandlers :: [Handler 'ClientStreaming]+ -- ^ Handlers for client streaming calls.+ , optServerStreamHandlers :: [Handler 'ServerStreaming]+ -- ^ Handlers for server streaming calls.+ , optBiDiStreamHandlers :: [Handler 'BiDiStreaming]+ -- ^ Handlers for bidirectional streaming calls.+ , optServerHost :: Host+ -- ^ Name of the host the server is running on.+ , optServerPort :: Port+ -- ^ Port on which to listen for requests.+ , optUseCompression :: Bool+ -- ^ Whether to use compression when communicating with the client.+ , optUserAgentPrefix :: String+ -- ^ Optional custom prefix to add to the user agent string.+ , optUserAgentSuffix :: String+ -- ^ Optional custom suffix to add to the user agent string.+ , optInitialMetadata :: MetadataMap+ -- ^ Metadata to send at the beginning of each call.+ , optSSLConfig :: Maybe ServerSSLConfig+ -- ^ Security configuration.+ , optLogger :: String -> IO ()+ -- ^ Logging function to use to log errors in handling calls.+ }++defaultOptions :: ServerOptions+defaultOptions = ServerOptions+ { optNormalHandlers = []+ , optClientStreamHandlers = []+ , optServerStreamHandlers = []+ , optBiDiStreamHandlers = []+ , optServerHost = "localhost"+ , optServerPort = 50051+ , optUseCompression = False+ , optUserAgentPrefix = "grpc-haskell/0.0.0"+ , optUserAgentSuffix = ""+ , optInitialMetadata = mempty+ , optSSLConfig = Nothing+ , optLogger = hPutStrLn stderr+ }++serverLoop :: ServerOptions -> IO ()+serverLoop _opts = fail "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")+-}
+ src/Network/GRPC/HighLevel/Server/Unregistered.hs view
@@ -0,0 +1,126 @@+{-# 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 s logger md hN hC hS hB =+ 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++ unknownHandler :: U.ServerCall -> IO ()+ unknownHandler sc = void $ U.serverHandleNormalCall' s sc md $ \_ _ ->+ return (mempty, mempty, StatusNotFound, StatusDetails "unknown method")++ handleError :: IO a -> IO ()+ handleError = (handleCallError logger . left herr =<<) . CE.try+ where herr (e :: CE.SomeException) = GRPCIOHandlerException (show e)++serverLoop :: ServerOptions -> IO ()+serverLoop ServerOptions{..} =+ -- In the GRPC library, "doc/core/epoll-polling-engine.md" seems+ -- to indicate that the thread which actually awakens from sleep+ -- on file descriptor events may differ from the one which seeks+ -- to "pluck" the resulting event.+ --+ -- Thus it seems possible that "dispatchLoop" may be waiting on+ -- a condition variable when the "serverLoop" thread is killed.+ --+ -- Note that "pthread_cond_timedwait" never returns EINTR; see:+ -- <https://pubs.opengroup.org/onlinepubs/7908799/xsh/pthread_cond_wait.html>+ --+ -- Therefore to awaken "dispatchLoop" we must initiate a GRPC+ -- shutdown; it would not suffice to kill its Haskell thread.+ -- (Presumably a GRPC shutdown broadcasts on relvant condition+ -- variables; regardless, we do see it awaken "dispatchLoop".)+ --+ -- The "withServer" cleanup code will initiate a GRPC shutdown.+ -- We arrange to trigger it by leaving the "serverLoop" thread+ -- in an interruptible sleep ("takeMVar") while "dispatchLoop"+ -- runs in its own thread.+ withGRPC $ \grpc ->+ withServer grpc config $ \server -> do+ -- Killing the "serverLoop" thread triggers the "withServer"+ -- cleanup code, which initiates a shutdown, which in turn+ -- kills the "dispatchLoop" thread and any other thread we+ -- may have started with "forkServer".+ done <- newEmptyMVar+ launched <- forkServer server $+ dispatchLoop server+ optLogger+ optInitialMetadata+ optNormalHandlers+ optClientStreamHandlers+ optServerStreamHandlers+ optBiDiStreamHandlers+ `CE.finally` putMVar done ()+ when launched $+ takeMVar done+ where+ config = ServerConfig+ { host = optServerHost+ , port = optServerPort+ , methodsToRegisterNormal = []+ , methodsToRegisterClientStreaming = []+ , methodsToRegisterServerStreaming = []+ , methodsToRegisterBiDiStreaming = []+ , serverArgs =+ [CompressionAlgArg GrpcCompressDeflate | optUseCompression]+ +++ [ UserAgentPrefix optUserAgentPrefix+ , UserAgentSuffix optUserAgentSuffix+ ]+ , sslConfig = optSSLConfig+ }
+ tests/GeneratedTests.hs view
@@ -0,0 +1,77 @@++{-# LANGUAGE OverloadedStrings #-}++module GeneratedTests where++import Test.Tasty+import Test.Tasty.HUnit (testCase, (@?=))++import Data.String+import Proto3.Suite.DotProto.Generate++import Turtle hiding (err)++generatedTests :: TestTree+generatedTests = testGroup "Code generator tests"+ [ testServerGeneration+ , testClientGeneration ]++testServerGeneration :: TestTree+testServerGeneration = testCase "server generation" $ do+ mktree hsTmpDir+ mktree pyTmpDir++ compileDotProtoFileOrDie [] hsTmpDir ["tests"] "simple.proto"++ do exitCode <- proc "tests/simple-server.sh" [hsTmpDir] empty+ exitCode @?= ExitSuccess++ do exitCode <- proc "tests/protoc.sh" [pyTmpDir] empty+ exitCode @?= ExitSuccess++ runManaged $ do+ serverExitCodeA <- fork (shell (hsTmpDir <> "/simple-server") empty)+ clientExitCodeA <- fork+ (export "PYTHONPATH" pyTmpDir >> shell "tests/test-client.sh" empty)++ liftIO $ do+ serverExitCode <- liftIO (wait serverExitCodeA)+ clientExitCode <- liftIO (wait clientExitCodeA)++ serverExitCode @?= ExitSuccess+ clientExitCode @?= ExitSuccess++ rmtree hsTmpDir+ rmtree pyTmpDir++testClientGeneration :: TestTree+testClientGeneration = testCase "client generation" $ do+ mktree hsTmpDir+ mktree pyTmpDir++ compileDotProtoFileOrDie [] hsTmpDir ["tests"] "simple.proto"++ do exitCode <- proc "tests/simple-client.sh" [hsTmpDir] empty+ exitCode @?= ExitSuccess++ do exitCode <- proc "tests/protoc.sh" [pyTmpDir] empty+ exitCode @?= ExitSuccess++ runManaged $ do+ serverExitCodeA <- fork+ (export "PYTHONPATH" pyTmpDir >> shell "tests/test-server.sh" empty)+ clientExitCodeA <- fork (shell (hsTmpDir <> "/simple-client") empty)++ liftIO $ do+ serverExitCode <- liftIO (wait serverExitCodeA)+ clientExitCode <- liftIO (wait clientExitCodeA)++ serverExitCode @?= ExitSuccess+ clientExitCode @?= ExitSuccess++ rmtree hsTmpDir+ rmtree pyTmpDir++hsTmpDir, pyTmpDir :: IsString a => a+hsTmpDir = "tests/tmp"+pyTmpDir = "tests/py-tmp"
+ tests/Properties.hs view
@@ -0,0 +1,5 @@+import Test.Tasty+import GeneratedTests++main :: IO ()+main = defaultMain $ testGroup "GRPC Unit Tests" [ generatedTests ]