diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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 diff --git a/examples/echo/echo-hs/Echo.hs b/examples/echo/echo-hs/Echo.hs new file mode 100644 --- /dev/null +++ b/examples/echo/echo-hs/Echo.hs @@ -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)]}}) diff --git a/examples/echo/echo-hs/EchoClient.hs b/examples/echo/echo-hs/EchoClient.hs new file mode 100644 --- /dev/null +++ b/examples/echo/echo-hs/EchoClient.hs @@ -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 diff --git a/examples/echo/echo-hs/EchoServer.hs b/examples/echo/echo-hs/EchoServer.hs new file mode 100644 --- /dev/null +++ b/examples/echo/echo-hs/EchoServer.hs @@ -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 diff --git a/examples/hellos/hellos-client/Main.hs b/examples/hellos/hellos-client/Main.hs new file mode 100644 --- /dev/null +++ b/examples/hellos/hellos-client/Main.hs @@ -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 diff --git a/examples/hellos/hellos-server/Main.hs b/examples/hellos/hellos-server/Main.hs new file mode 100644 --- /dev/null +++ b/examples/hellos/hellos-server/Main.hs @@ -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 diff --git a/examples/tutorial/Arithmetic.hs b/examples/tutorial/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Arithmetic.hs @@ -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)]}}) diff --git a/examples/tutorial/ArithmeticClient.hs b/examples/tutorial/ArithmeticClient.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/ArithmeticClient.hs @@ -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 () diff --git a/examples/tutorial/ArithmeticServer.hs b/examples/tutorial/ArithmeticServer.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/ArithmeticServer.hs @@ -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 diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal new file mode 100644 --- /dev/null +++ b/grpc-haskell.cabal @@ -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 diff --git a/src/Network/GRPC/HighLevel.hs b/src/Network/GRPC/HighLevel.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/HighLevel.hs @@ -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 diff --git a/src/Network/GRPC/HighLevel/Client.hs b/src/Network/GRPC/HighLevel/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/HighLevel/Client.hs @@ -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 diff --git a/src/Network/GRPC/HighLevel/Generated.hs b/src/Network/GRPC/HighLevel/Generated.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/HighLevel/Generated.hs @@ -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 diff --git a/src/Network/GRPC/HighLevel/Server.hs b/src/Network/GRPC/HighLevel/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/HighLevel/Server.hs @@ -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") +-} diff --git a/src/Network/GRPC/HighLevel/Server/Unregistered.hs b/src/Network/GRPC/HighLevel/Server/Unregistered.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/HighLevel/Server/Unregistered.hs @@ -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: + -- + -- + -- 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 + } diff --git a/tests/GeneratedTests.hs b/tests/GeneratedTests.hs new file mode 100644 --- /dev/null +++ b/tests/GeneratedTests.hs @@ -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" diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,5 @@ +import Test.Tasty +import GeneratedTests + +main :: IO () +main = defaultMain $ testGroup "GRPC Unit Tests" [ generatedTests ]