diff --git a/examples/echo/echo-hs/Echo.hs b/examples/echo/echo-hs/Echo.hs --- a/examples/echo/echo-hs/Echo.hs +++ b/examples/echo/echo-hs/Echo.hs @@ -1,49 +1,58 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} {-# 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.DotProto as HsProtobuf import qualified Proto3.Suite.JSONPB as HsJSONPB import Proto3.Suite.JSONPB ((.=), (.:)) +import qualified Proto3.Suite.Types as HsProtobuf import qualified Proto3.Wire as HsProtobuf -import Control.Applicative ((<*>), (<|>), (<$>)) import qualified Control.Applicative as Hs +import Control.Applicative ((<*>), (<|>), (<$>)) +import qualified Control.DeepSeq 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.Coerce as Hs +import qualified Data.Int as Hs (Int16, Int32, Int64) +import qualified Data.List.NonEmpty as Hs (NonEmpty(..)) +import qualified Data.Map as Hs (Map, mapKeysMonotonic) +import qualified Data.Proxy as Proxy import qualified Data.String as Hs (fromString) +import qualified Data.Text.Lazy as Hs (Text) 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 qualified GHC.Generics as Hs +import qualified Unsafe.Coerce 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) + userAgentPrefix userAgentSuffix initialMetadata sslConfig logger + serverMaxReceiveMessageLength) = (HsGRPC.serverLoop HsGRPC.defaultOptions{HsGRPC.optNormalHandlers = [(HsGRPC.UnaryHandler (HsGRPC.MethodName "/echo.Echo/DoEcho") @@ -55,8 +64,9 @@ optUserAgentPrefix = userAgentPrefix, optUserAgentSuffix = userAgentSuffix, optInitialMetadata = initialMetadata, optSSLConfig = sslConfig, - optLogger = logger}) - + optLogger = logger, + optMaxReceiveMessageLength = serverMaxReceiveMessageLength}) + echoClient :: HsGRPC.Client -> Hs.IO (Echo HsGRPC.ClientRequest HsGRPC.ClientResult) @@ -65,13 +75,15 @@ ((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) - + +newtype EchoRequest = EchoRequest{echoRequestMessage :: Hs.Text} + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) + instance HsProtobuf.Named EchoRequest where nameOf _ = (Hs.fromString "EchoRequest") - + +instance HsProtobuf.HasDefault EchoRequest + instance HsProtobuf.Message EchoRequest where encodeMessage _ EchoRequest{echoRequestMessage = echoRequestMessage} @@ -88,23 +100,23 @@ (HsProtobuf.Single "message") [] "")] - + 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 @@ -120,13 +132,15 @@ HsJSONPB._schemaProperties = HsJSONPB.insOrdFromList [("message", echoRequestMessage)]}}) - -data EchoResponse = EchoResponse{echoResponseMessage :: Hs.Text} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) - + +newtype EchoResponse = EchoResponse{echoResponseMessage :: Hs.Text} + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) + instance HsProtobuf.Named EchoResponse where nameOf _ = (Hs.fromString "EchoResponse") - + +instance HsProtobuf.HasDefault EchoResponse + instance HsProtobuf.Message EchoResponse where encodeMessage _ EchoResponse{echoResponseMessage = echoResponseMessage} @@ -143,23 +157,23 @@ (HsProtobuf.Single "message") [] "")] - + 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 diff --git a/examples/hellos/hellos-client/Main.hs b/examples/hellos/hellos-client/Main.hs --- a/examples/hellos/hellos-client/Main.hs +++ b/examples/hellos/hellos-client/Main.hs @@ -31,7 +31,7 @@ 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 :: (Eq a, MonadFail m, Show a) => String -> a -> a -> m () expect ctx ex got | ex /= got = fail $ ctx ++ " error: expected " ++ show ex ++ ", got " ++ show got | otherwise = return () diff --git a/examples/hellos/hellos-server/Main.hs b/examples/hellos/hellos-server/Main.hs --- a/examples/hellos/hellos-server/Main.hs +++ b/examples/hellos/hellos-server/Main.hs @@ -10,7 +10,6 @@ import Control.Monad import Data.Function (fix) -import Data.Monoid import qualified Data.Text as T import Data.Word import GHC.Generics (Generic) @@ -33,7 +32,7 @@ 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 :: (Eq a, MonadFail m, Show a) => String -> a -> a -> m () expect ctx ex got | ex /= got = fail $ ctx ++ " error: expected " ++ show ex ++ ", got " ++ show got | otherwise = return () diff --git a/examples/tutorial/Arithmetic.hs b/examples/tutorial/Arithmetic.hs --- a/examples/tutorial/Arithmetic.hs +++ b/examples/tutorial/Arithmetic.hs @@ -1,38 +1,46 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} {-# 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.DotProto as HsProtobuf import qualified Proto3.Suite.JSONPB as HsJSONPB import Proto3.Suite.JSONPB ((.=), (.:)) +import qualified Proto3.Suite.Types as HsProtobuf import qualified Proto3.Wire as HsProtobuf -import Control.Applicative ((<*>), (<|>), (<$>)) import qualified Control.Applicative as Hs +import Control.Applicative ((<*>), (<|>), (<$>)) +import qualified Control.DeepSeq 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.Coerce as Hs +import qualified Data.Int as Hs (Int16, Int32, Int64) +import qualified Data.List.NonEmpty as Hs (NonEmpty(..)) +import qualified Data.Map as Hs (Map, mapKeysMonotonic) +import qualified Data.Proxy as Proxy import qualified Data.String as Hs (fromString) +import qualified Data.Text.Lazy as Hs (Text) 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 qualified GHC.Generics as Hs +import qualified Unsafe.Coerce 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 @@ -46,7 +54,7 @@ (response 'HsGRPC.ClientStreaming Arithmetic.OneInt)} deriving Hs.Generic - + arithmeticServer :: Arithmetic HsGRPC.ServerRequest HsGRPC.ServerResponse -> HsGRPC.ServiceOptions -> Hs.IO () @@ -54,7 +62,8 @@ Arithmetic{arithmeticAdd = arithmeticAdd, arithmeticRunningSum = arithmeticRunningSum} (ServiceOptions serverHost serverPort useCompression - userAgentPrefix userAgentSuffix initialMetadata sslConfig logger) + userAgentPrefix userAgentSuffix initialMetadata sslConfig logger + serverMaxReceiveMessageLength) = (HsGRPC.serverLoop HsGRPC.defaultOptions{HsGRPC.optNormalHandlers = [(HsGRPC.UnaryHandler @@ -71,8 +80,9 @@ optUserAgentPrefix = userAgentPrefix, optUserAgentSuffix = userAgentSuffix, optInitialMetadata = initialMetadata, optSSLConfig = sslConfig, - optLogger = logger}) - + optLogger = logger, + optMaxReceiveMessageLength = serverMaxReceiveMessageLength}) + arithmeticClient :: HsGRPC.Client -> Hs.IO (Arithmetic HsGRPC.ClientRequest HsGRPC.ClientResult) @@ -85,13 +95,15 @@ ((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) - + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) + instance HsProtobuf.Named TwoInts where nameOf _ = (Hs.fromString "TwoInts") - + +instance HsProtobuf.HasDefault TwoInts + instance HsProtobuf.Message TwoInts where encodeMessage _ TwoInts{twoIntsX = twoIntsX, twoIntsY = twoIntsY} = (Hs.mconcat @@ -117,24 +129,24 @@ (HsProtobuf.Single "y") [] "")] - + 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 @@ -153,13 +165,15 @@ HsJSONPB._schemaProperties = HsJSONPB.insOrdFromList [("x", twoIntsX), ("y", twoIntsY)]}}) - -data OneInt = OneInt{oneIntResult :: Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) - + +newtype OneInt = OneInt{oneIntResult :: Hs.Int32} + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) + instance HsProtobuf.Named OneInt where nameOf _ = (Hs.fromString "OneInt") - + +instance HsProtobuf.HasDefault OneInt + instance HsProtobuf.Message OneInt where encodeMessage _ OneInt{oneIntResult = oneIntResult} = (Hs.mconcat @@ -175,23 +189,23 @@ (HsProtobuf.Single "result") [] "")] - + 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 diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal --- a/grpc-haskell.cabal +++ b/grpc-haskell.cabal @@ -1,5 +1,5 @@ name: grpc-haskell -version: 0.0.1.0 +version: 0.1.0 synopsis: Haskell implementation of gRPC layered on shared C library. homepage: https://github.com/awakenetworks/gRPC-haskell license: Apache-2.0 @@ -29,10 +29,9 @@ build-depends: base >=4.8 && <5.0 , bytestring ==0.10.* - , proto3-suite >=0.4.0.0 - , proto3-wire + , proto3-suite >=0.4.2.0 + , proto3-wire >=1.2.0 , grpc-haskell-core - , async >=2.1 && <2.3 , managed >= 1.0.5 @@ -98,6 +97,7 @@ , async , bytestring == 0.10.* , containers >=0.5 && <0.7 + , deepseq , grpc-haskell , grpc-haskell-core , optparse-generic @@ -122,6 +122,7 @@ , async , bytestring == 0.10.* , containers >=0.5 && <0.7 + , deepseq , grpc-haskell , grpc-haskell-core , optparse-generic @@ -145,6 +146,7 @@ , async , bytestring == 0.10.* , containers >=0.5 && <0.7 + , deepseq , grpc-haskell , grpc-haskell-core , optparse-generic @@ -168,6 +170,7 @@ , async , bytestring == 0.10.* , containers >=0.5 && <0.7 + , deepseq , grpc-haskell , grpc-haskell-core , optparse-generic diff --git a/src/Network/GRPC/HighLevel/Generated.hs b/src/Network/GRPC/HighLevel/Generated.hs --- a/src/Network/GRPC/HighLevel/Generated.hs +++ b/src/Network/GRPC/HighLevel/Generated.hs @@ -42,6 +42,7 @@ import Network.GRPC.HighLevel.Client import Network.GRPC.LowLevel import Network.GRPC.LowLevel.Call +import Numeric.Natural import System.IO (hPutStrLn, stderr) -- | Used at the kind level as a parameter to service definitions @@ -78,6 +79,8 @@ -- ^ Security configuration. , logger :: String -> IO () -- ^ Logging function to use to log errors in handling calls. + , serverMaxReceiveMessageLength :: Maybe Natural + -- ^ Maximum length (in bytes) that the service may receive in a single message } defaultServiceOptions :: ServiceOptions @@ -91,6 +94,7 @@ , Network.GRPC.HighLevel.Generated.initialMetadata = mempty , Network.GRPC.HighLevel.Generated.sslConfig = Nothing , Network.GRPC.HighLevel.Generated.logger = hPutStrLn stderr + , Network.GRPC.HighLevel.Generated.serverMaxReceiveMessageLength = Nothing } withGRPCClient :: ClientConfig -> (Client -> IO a) -> IO a diff --git a/src/Network/GRPC/HighLevel/Server.hs b/src/Network/GRPC/HighLevel/Server.hs --- a/src/Network/GRPC/HighLevel/Server.hs +++ b/src/Network/GRPC/HighLevel/Server.hs @@ -13,6 +13,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL import Network.GRPC.LowLevel +import Numeric.Natural import Proto3.Suite.Class import System.IO @@ -225,6 +226,7 @@ -- ^ Security configuration. , optLogger :: String -> IO () -- ^ Logging function to use to log errors in handling calls. + , optMaxReceiveMessageLength :: Maybe Natural } defaultOptions :: ServerOptions @@ -241,6 +243,7 @@ , optInitialMetadata = mempty , optSSLConfig = Nothing , optLogger = hPutStrLn stderr + , optMaxReceiveMessageLength = Nothing } serverLoop :: ServerOptions -> IO () diff --git a/src/Network/GRPC/HighLevel/Server/Unregistered.hs b/src/Network/GRPC/HighLevel/Server/Unregistered.hs --- a/src/Network/GRPC/HighLevel/Server/Unregistered.hs +++ b/src/Network/GRPC/HighLevel/Server/Unregistered.hs @@ -122,5 +122,7 @@ [ UserAgentPrefix optUserAgentPrefix , UserAgentSuffix optUserAgentSuffix ] + ++ + foldMap (pure . MaxReceiveMessageLength) optMaxReceiveMessageLength , sslConfig = optSSLConfig }