From 90534f5556379523bd4c580a7a4f32def0c3ddb6 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Fri, 25 Oct 2024 16:14:11 +0200 Subject: [PATCH] Drop the demo It served two purposes: it was used during development for basic testing (now superseded by `test-grapesy` and `test-interop`) and as a demonstration of how to use the various `grapesy` features, now superseded by the tutorials. --- {grapesy/docs => dev}/stress-tests.md | 0 .../Demo/Client/API/Core/Greeter.hs | 53 --- .../Demo/Client/API/Core/NoFinal/Greeter.hs | 22 - .../Demo/Client/API/Core/RouteGuide.hs | 36 -- .../API/StreamType/Conduit/RouteGuide.hs | 43 -- .../Demo/Client/API/StreamType/IO/Greeter.hs | 27 -- .../Demo/Client/API/StreamType/IO/Ping.hs | 12 - .../Client/API/StreamType/IO/RouteGuide.hs | 48 -- .../API/StreamType/MonadStack/Greeter.hs | 66 --- grapesy/demo-client/Demo/Client/Cmdline.hs | 340 -------------- .../demo-client/Demo/Client/Util/DelayOr.hs | 38 -- .../demo-client/Demo/Client/Util/Logging.hs | 20 - grapesy/demo-client/Main.hs | 135 ------ .../demo-server/Demo/Server/Aux/RouteGuide.hs | 120 ----- grapesy/demo-server/Demo/Server/Cmdline.hs | 131 ------ .../Demo/Server/Service/Greeter.hs | 77 ---- .../demo-server/Demo/Server/Service/Ping.hs | 17 - .../Demo/Server/Service/RouteGuide.hs | 136 ------ grapesy/demo-server/Main.hs | 82 ---- grapesy/docs/demo-client.md | 433 ------------------ grapesy/docs/demo-server.md | 108 ----- grapesy/grapesy.cabal | 97 ---- .../GRPC/Spec/Serialization/Headers/Common.hs | 2 +- 23 files changed, 1 insertion(+), 2042 deletions(-) rename {grapesy/docs => dev}/stress-tests.md (100%) delete mode 100644 grapesy/demo-client/Demo/Client/API/Core/Greeter.hs delete mode 100644 grapesy/demo-client/Demo/Client/API/Core/NoFinal/Greeter.hs delete mode 100644 grapesy/demo-client/Demo/Client/API/Core/RouteGuide.hs delete mode 100644 grapesy/demo-client/Demo/Client/API/StreamType/Conduit/RouteGuide.hs delete mode 100644 grapesy/demo-client/Demo/Client/API/StreamType/IO/Greeter.hs delete mode 100644 grapesy/demo-client/Demo/Client/API/StreamType/IO/Ping.hs delete mode 100644 grapesy/demo-client/Demo/Client/API/StreamType/IO/RouteGuide.hs delete mode 100644 grapesy/demo-client/Demo/Client/API/StreamType/MonadStack/Greeter.hs delete mode 100644 grapesy/demo-client/Demo/Client/Cmdline.hs delete mode 100644 grapesy/demo-client/Demo/Client/Util/DelayOr.hs delete mode 100644 grapesy/demo-client/Demo/Client/Util/Logging.hs delete mode 100644 grapesy/demo-client/Main.hs delete mode 100644 grapesy/demo-server/Demo/Server/Aux/RouteGuide.hs delete mode 100644 grapesy/demo-server/Demo/Server/Cmdline.hs delete mode 100644 grapesy/demo-server/Demo/Server/Service/Greeter.hs delete mode 100644 grapesy/demo-server/Demo/Server/Service/Ping.hs delete mode 100644 grapesy/demo-server/Demo/Server/Service/RouteGuide.hs delete mode 100644 grapesy/demo-server/Main.hs delete mode 100644 grapesy/docs/demo-client.md delete mode 100644 grapesy/docs/demo-server.md diff --git a/grapesy/docs/stress-tests.md b/dev/stress-tests.md similarity index 100% rename from grapesy/docs/stress-tests.md rename to dev/stress-tests.md diff --git a/grapesy/demo-client/Demo/Client/API/Core/Greeter.hs b/grapesy/demo-client/Demo/Client/API/Core/Greeter.hs deleted file mode 100644 index b828cd64..00000000 --- a/grapesy/demo-client/Demo/Client/API/Core/Greeter.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Demo.Client.API.Core.Greeter ( - sayHelloStreamReply - , sayHelloBidiStream - ) where - -import Control.Exception - -import Network.GRPC.Client -import Network.GRPC.Common -import Network.GRPC.Common.Protobuf -import Network.GRPC.Common.StreamElem qualified as StreamElem - -import Demo.Client.Util.DelayOr (DelayOr) -import Demo.Client.Util.DelayOr qualified as DelayOr -import Demo.Client.Util.Logging - -import Proto.API.Helloworld - -{------------------------------------------------------------------------------- - helloworld.Greeter --------------------------------------------------------------------------------} - -sayHelloStreamReply :: Connection -> Proto HelloRequest -> IO () -sayHelloStreamReply conn name = - withRPC conn def (Proxy @SayHelloStreamReply) $ \call -> do - -- The server only sends a response once we send an input - sendFinalInput call name - - -- We should see the response metadata immediately, and the first output - -- after a delay. - initMetadata <- recvResponseInitialMetadata call - logMsg initMetadata - - -- For completeness, we also show the final metadata, although the - -- example does not include any. - finalMetadata <- StreamElem.whileNext_ (recvOutput call) logMsg - logMsg finalMetadata - -sayHelloBidiStream :: Connection -> [DelayOr (Proto HelloRequest)] -> IO () -sayHelloBidiStream conn names = handle cancelled $ - withRPC conn def (Proxy @SayHelloBidiStream) $ \call -> do - DelayOr.forM_ names $ \name -> do - sendNextInput call name - print =<< recvNextOutput call - where - cancelled :: GrpcException -> IO () - cancelled err - | grpcError err == GrpcCancelled - = putStrLn "sayHelloBidiStream client: cancelled." - - | otherwise - = throwIO err - diff --git a/grapesy/demo-client/Demo/Client/API/Core/NoFinal/Greeter.hs b/grapesy/demo-client/Demo/Client/API/Core/NoFinal/Greeter.hs deleted file mode 100644 index 9351f02e..00000000 --- a/grapesy/demo-client/Demo/Client/API/Core/NoFinal/Greeter.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Demo.Client.API.Core.NoFinal.Greeter ( - sayHello - ) where - -import Network.GRPC.Client -import Network.GRPC.Common -import Network.GRPC.Common.Protobuf - -import Proto.API.Helloworld - -{------------------------------------------------------------------------------- - helloworld.Greeter --------------------------------------------------------------------------------} - -sayHello :: Connection -> Proto HelloRequest -> IO () -sayHello conn n = - withRPC conn def (Proxy @SayHello) $ \call -> do - sendInput call $ StreamElem n - out <- recvOutput call - trailers <- recvOutput call - print (out, trailers) - diff --git a/grapesy/demo-client/Demo/Client/API/Core/RouteGuide.hs b/grapesy/demo-client/Demo/Client/API/Core/RouteGuide.hs deleted file mode 100644 index 4debb465..00000000 --- a/grapesy/demo-client/Demo/Client/API/Core/RouteGuide.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Demo.Client.API.Core.RouteGuide ( - listFeatures - ) where - -import Network.GRPC.Client -import Network.GRPC.Common -import Network.GRPC.Common.Protobuf -import Network.GRPC.Common.StreamElem qualified as StreamElem - -import Demo.Client.Util.Logging - -import Proto.API.RouteGuide - -{------------------------------------------------------------------------------- - RouteGuide --------------------------------------------------------------------------------} - -listFeatures :: Connection -> Proto Rectangle -> IO () -listFeatures conn r = do - withRPC conn def (Proxy @ListFeatures) $ \call -> do - sendFinalInput call r - - -- Show response custom metadata - -- - -- In the gRPC @Trailers-Only@ case (which will be triggered if there - -- are zero features in the provided rectangle), this will also be the - -- trailing custom metadata. - initMetadata <- recvResponseInitialMetadata call - logMsg initMetadata - - finalMetadata <- StreamElem.whileNext_ (recvOutput call) logMsg - logMsg finalMetadata - - - - diff --git a/grapesy/demo-client/Demo/Client/API/StreamType/Conduit/RouteGuide.hs b/grapesy/demo-client/Demo/Client/API/StreamType/Conduit/RouteGuide.hs deleted file mode 100644 index 51479639..00000000 --- a/grapesy/demo-client/Demo/Client/API/StreamType/Conduit/RouteGuide.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Demo.Client.API.StreamType.Conduit.RouteGuide ( - listFeatures - , recordRoute - , routeChat - ) where - -import Control.Concurrent.Async (concurrently_) -import Data.Conduit -import Data.Conduit.Combinators qualified as Conduit (mapM_) - -import Network.GRPC.Client -import Network.GRPC.Client.StreamType.Conduit -import Network.GRPC.Common.Protobuf - -import Demo.Client.Util.DelayOr (DelayOr) -import Demo.Client.Util.DelayOr qualified as DelayOr -import Demo.Client.Util.Logging - -import Proto.API.RouteGuide - -{------------------------------------------------------------------------------- - routeguide.RouteGuide - - We do not include the 'getFeature' method, as it does not do any streaming. --------------------------------------------------------------------------------} - -listFeatures :: Connection -> Proto Rectangle -> IO () -listFeatures conn r = - serverStreaming conn (rpc @ListFeatures) r $ \source -> - runConduit $ source .| Conduit.mapM_ logMsg - -recordRoute :: Connection -> [DelayOr (Proto Point)] -> IO () -recordRoute conn ps = do - summary <- clientStreaming_ conn (rpc @RecordRoute) $ \sink -> - runConduit $ DelayOr.source ps .| sink - logMsg summary - -routeChat :: Connection -> [DelayOr (Proto RouteNote)] -> IO () -routeChat conn ns = do - biDiStreaming conn (rpc @RouteChat) $ \sink source -> - concurrently_ - (runConduit $ DelayOr.source ns .| sink) - (runConduit $ source .| Conduit.mapM_ logMsg) diff --git a/grapesy/demo-client/Demo/Client/API/StreamType/IO/Greeter.hs b/grapesy/demo-client/Demo/Client/API/StreamType/IO/Greeter.hs deleted file mode 100644 index ceb07513..00000000 --- a/grapesy/demo-client/Demo/Client/API/StreamType/IO/Greeter.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Demo.Client.API.StreamType.IO.Greeter ( - sayHello - , sayHelloStreamReply - ) where - -import Network.GRPC.Client -import Network.GRPC.Client.StreamType.IO -import Network.GRPC.Common.NextElem qualified as NextElem -import Network.GRPC.Common.Protobuf - -import Demo.Client.Util.Logging - -import Proto.API.Helloworld - -{------------------------------------------------------------------------------- - helloworld.Greeter --------------------------------------------------------------------------------} - -sayHello :: Connection -> Proto HelloRequest -> IO () -sayHello conn name = do - reply <- nonStreaming conn (rpc @SayHello) name - logMsg reply - -sayHelloStreamReply :: Connection -> Proto HelloRequest -> IO () -sayHelloStreamReply conn name = - serverStreaming conn (rpc @SayHelloStreamReply) name $ \recv -> - NextElem.whileNext_ recv logMsg diff --git a/grapesy/demo-client/Demo/Client/API/StreamType/IO/Ping.hs b/grapesy/demo-client/Demo/Client/API/StreamType/IO/Ping.hs deleted file mode 100644 index b1ffe930..00000000 --- a/grapesy/demo-client/Demo/Client/API/StreamType/IO/Ping.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Demo.Client.API.StreamType.IO.Ping (ping) where - -import Network.GRPC.Client -import Network.GRPC.Client.StreamType.IO -import Network.GRPC.Common.Protobuf - -import Proto.API.Ping - -ping :: Connection -> Proto PingMessage -> IO () -ping conn msg = do - pong <- nonStreaming conn (rpc @Ping) msg - print pong diff --git a/grapesy/demo-client/Demo/Client/API/StreamType/IO/RouteGuide.hs b/grapesy/demo-client/Demo/Client/API/StreamType/IO/RouteGuide.hs deleted file mode 100644 index 1974db34..00000000 --- a/grapesy/demo-client/Demo/Client/API/StreamType/IO/RouteGuide.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Demo.Client.API.StreamType.IO.RouteGuide ( - getFeature - , listFeatures - , recordRoute - , routeChat - ) where - -import Control.Concurrent.Async (concurrently_) - -import Network.GRPC.Client -import Network.GRPC.Client.StreamType.IO -import Network.GRPC.Common -import Network.GRPC.Common.NextElem qualified as NextElem -import Network.GRPC.Common.Protobuf - -import Demo.Client.Util.DelayOr (DelayOr) -import Demo.Client.Util.DelayOr qualified as DelayOr -import Demo.Client.Util.Logging - -import Proto.API.RouteGuide - -{------------------------------------------------------------------------------- - routeguide.RouteGuide --------------------------------------------------------------------------------} - -getFeature :: Connection -> Proto Point -> IO () -getFeature conn point = do - features <- nonStreaming conn (rpc @GetFeature) point - logMsg features - -listFeatures :: Connection -> Proto Rectangle -> IO () -listFeatures conn rect = - serverStreaming conn (rpc @ListFeatures) rect $ \recv -> - NextElem.whileNext_ recv logMsg - -recordRoute :: Connection -> [DelayOr (Proto Point)] -> IO () -recordRoute conn points = do - summary <- clientStreaming_ conn (rpc @RecordRoute) $ \send -> do - DelayOr.forM_ points (send . NextElem) - send NoNextElem - logMsg summary - -routeChat :: Connection -> [DelayOr (Proto RouteNote)] -> IO () -routeChat conn notes = - biDiStreaming conn (rpc @RouteChat) $ \send recv -> - concurrently_ - (DelayOr.mapM_ (send . NextElem) notes >> send NoNextElem) - (NextElem.whileNext_ recv print) diff --git a/grapesy/demo-client/Demo/Client/API/StreamType/MonadStack/Greeter.hs b/grapesy/demo-client/Demo/Client/API/StreamType/MonadStack/Greeter.hs deleted file mode 100644 index 1955d0f1..00000000 --- a/grapesy/demo-client/Demo/Client/API/StreamType/MonadStack/Greeter.hs +++ /dev/null @@ -1,66 +0,0 @@ --- | Demonstration of using a custom monad stack -module Demo.Client.API.StreamType.MonadStack.Greeter ( - sayHello - , sayHelloStreamReply - ) where - -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader - -import Network.GRPC.Client -import Network.GRPC.Client.StreamType.CanCallRPC -import Network.GRPC.Common.NextElem qualified as NextElem -import Network.GRPC.Common.Protobuf - -import Demo.Client.Util.Logging qualified as Logging - -import Proto.API.Helloworld - -{------------------------------------------------------------------------------- - Example custom monad --------------------------------------------------------------------------------} - -data ClientState = ClientState { - connection :: Connection - , logger :: forall a. Show a => a -> IO () - } - -newtype MyClient a = WrapMyClient { - unwrapMyClient :: ReaderT ClientState IO a - } - deriving newtype ( - Functor - , Applicative - , Monad - , MonadIO - , MonadThrow - , MonadCatch - , MonadMask - ) - -instance CanCallRPC MyClient where - getConnection = WrapMyClient $ connection <$> ask - -clientLogMsg :: Show a => a -> MyClient () -clientLogMsg x = WrapMyClient $ ReaderT $ \state -> logger state x - -runMyClient :: Connection -> MyClient a -> IO a -runMyClient conn client = - runReaderT - (unwrapMyClient client) - (ClientState conn Logging.logMsg) - -{------------------------------------------------------------------------------- - Implement the Greeter API using 'MyClient' --------------------------------------------------------------------------------} - -sayHello :: Connection -> Proto HelloRequest -> IO () -sayHello conn name = runMyClient conn $ do - reply <- nonStreaming (rpc @SayHello) name - clientLogMsg reply - -sayHelloStreamReply :: Connection -> Proto HelloRequest -> IO () -sayHelloStreamReply conn name = runMyClient conn $ do - serverStreaming (rpc @SayHelloStreamReply) name $ \recv -> - NextElem.whileNext_ (liftIO recv) clientLogMsg diff --git a/grapesy/demo-client/Demo/Client/Cmdline.hs b/grapesy/demo-client/Demo/Client/Cmdline.hs deleted file mode 100644 index b9cba27b..00000000 --- a/grapesy/demo-client/Demo/Client/Cmdline.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedLabels #-} - --- | Command line options --- --- Intended for unqualified import. -module Demo.Client.Cmdline ( - -- * Definition - Cmdline(..) - , API(..) - , SomeMethod(..) - , SMethod(..) - -- * Parser - , getCmdline - ) where - -import Prelude - -import Data.Foldable (asum, toList) -import Data.Int -import Data.Kind -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Network.Socket (HostName, PortNumber) -import Options.Applicative ((<**>)) -import Options.Applicative qualified as Opt - -import Network.GRPC.Client qualified as Client -import Network.GRPC.Common -import Network.GRPC.Common.Compression (Compression) -import Network.GRPC.Common.Compression qualified as Compr -import Network.GRPC.Common.Protobuf - -import Paths_grapesy - -import Demo.Client.Util.DelayOr (DelayOr(..)) - -import Proto.API.Helloworld -import Proto.API.Ping -import Proto.API.RouteGuide -import Text.Read (readMaybe) - -{------------------------------------------------------------------------------- - Definition --------------------------------------------------------------------------------} - -data Cmdline = Cmdline { - cmdServer :: Client.Server - , cmdTimeout :: Maybe Word - , cmdAPI :: API - , cmdCompression :: Maybe Compression - , cmdMethods :: [DelayOr SomeMethod] - } - deriving (Show) - --- | Which API to use? -data API = - StreamTypeIO - | StreamTypeConduit - | StreamTypeMonadStack - | Core - | CoreNoFinal - deriving (Show) - -data SomeMethod where - SomeMethod :: SMethod rpc -> SomeMethod - -deriving stock instance Show SomeMethod - --- | Select method -data SMethod :: Type -> Type where - SSayHello :: Proto HelloRequest -> SMethod SayHello - SSayHelloStreamReply :: Proto HelloRequest -> SMethod SayHelloStreamReply - SSayHelloBidiStream :: [DelayOr (Proto HelloRequest)] -> SMethod SayHelloBidiStream - - SGetFeature :: Proto Point -> SMethod GetFeature - SListFeatures :: Proto Rectangle -> SMethod ListFeatures - SRecordRoute :: [DelayOr (Proto Point)] -> SMethod RecordRoute - SRouteChat :: [DelayOr (Proto RouteNote)] -> SMethod RouteChat - - SPing :: Proto PingMessage -> SMethod Ping - -deriving stock instance Show (SMethod rpc) - -{------------------------------------------------------------------------------- - Top-level --------------------------------------------------------------------------------} - -getCmdline :: IO Cmdline -getCmdline = do - defaultPub <- getDataFileName "grpc-demo.pem" - - let info :: Opt.ParserInfo Cmdline - info = Opt.info (parseCmdline defaultPub <**> Opt.helper) Opt.fullDesc - - Opt.execParser info - -parseCmdline :: FilePath -> Opt.Parser Cmdline -parseCmdline defaultPub = - Cmdline - <$> parseServer defaultPub - <*> (Opt.optional $ Opt.option Opt.auto $ mconcat [ - Opt.long "timeout" - , Opt.metavar "SECONDS" - ]) - <*> parseAPI - <*> Opt.optional parseCompression - <*> Opt.many (parseDelayOr parseSomeMethod) - -{------------------------------------------------------------------------------- - Options --------------------------------------------------------------------------------} - -parseServer :: FilePath -> Opt.Parser Client.Server -parseServer defaultPub = - mkServer - <$> (Opt.option Opt.str $ mconcat [ - Opt.long "host" - , Opt.showDefault - , Opt.value "127.0.0.1" - ]) - <*> (Opt.optional $ Opt.option Opt.auto $ mconcat [ - Opt.long "port" - ]) - <*> (Opt.optional $ - Opt.flag' () (mconcat [ - Opt.long "secure" - , Opt.help "Connect over TLS" - ]) - *> parseServerValidation defaultPub) - <*> (Opt.optional $ Opt.option Opt.str $ mconcat [ - Opt.long "authority" - , Opt.help "Override the HTTP2 :authority pseudo-header" - ]) - where - mkServer :: - HostName -- Host - -> Maybe PortNumber -- Port - -> Maybe Client.ServerValidation -- Secure? - -> Maybe String - -> Client.Server - mkServer host mPort Nothing mAuth = - Client.ServerInsecure $ - Client.Address host (fromMaybe defaultInsecurePort mPort) mAuth - mkServer host mPort (Just validation) mAuth = - Client.ServerSecure validation def $ - Client.Address host (fromMaybe defaultSecurePort mPort) mAuth - -parseServerValidation :: FilePath -> Opt.Parser Client.ServerValidation -parseServerValidation defaultPub = - aux - <$> (Opt.switch $ mconcat [ - Opt.long "no-server-validation" - , Opt.help "Skip server (certificate) validation" - ]) - <*> (Opt.switch $ mconcat [ - Opt.long "cert-store-from-system" - , Opt.help "Enable the system certificate store" - ]) - <*> (Opt.option Opt.str $ mconcat [ - Opt.long "cert-store-from-path" - , Opt.help "Load certificate store from file or directory (set to empty to disable)" - , Opt.metavar "PATH" - , Opt.value defaultPub - , Opt.showDefault - ]) - where - aux :: Bool -> Bool -> FilePath -> Client.ServerValidation - aux noServerValidation certStoreFromSystem certStoreFromPath = - if noServerValidation then - Client.NoServerValidation - else - Client.ValidateServer $ mconcat . concat $ [ - [ Client.certStoreFromSystem - | certStoreFromSystem - ] - - , [ Client.certStoreFromPath certStoreFromPath - | not (null certStoreFromPath) - ] - ] - -parseCompression :: Opt.Parser Compression -parseCompression = asum $ map go (toList Compr.allSupportedCompression) - where - go :: Compression -> Opt.Parser Compression - go compr = Opt.flag' compr $ mconcat [ - Opt.long comprId - , Opt.help $ "Use " ++ comprId ++ " compression for all messages" - ] - where - comprId :: String - comprId = show (Compr.compressionId compr) - -parseAPI :: Opt.Parser API -parseAPI = asum [ - Opt.flag' StreamTypeIO $ mconcat [ - Opt.long "streamtype-io" - , Opt.help "Use the StreamType.IO API (if applicable)" - ] - , Opt.flag' StreamTypeConduit $ mconcat [ - Opt.long "streamtype-conduit" - , Opt.help "Use the StreamType.Conduit API (if applicable)" - ] - , Opt.flag' StreamTypeMonadStack $ mconcat [ - Opt.long "streamtype-monadstack" - , Opt.help "Use the StreamType API with a bespoke monad stack (if applicable)" - ] - , Opt.flag' Core $ mconcat [ - Opt.long "core" - , Opt.help "Use the core API" - ] - , Opt.flag' CoreNoFinal $ mconcat [ - Opt.long "core-dont-mark-final" - , Opt.help "Use the core API; don't mark the last message as final" - ] - , pure StreamTypeIO - ] - -{------------------------------------------------------------------------------- - Select method --------------------------------------------------------------------------------} - -parseSomeMethod :: Opt.Parser SomeMethod -parseSomeMethod = Opt.subparser $ mconcat [ - sub "sayHello" "helloworld.Greeter.SayHello" $ - SomeMethod . SSayHello <$> - parseHelloRequest - , sub "sayHelloStreamReply" "helloworld.Greeter.SayHelloStreamReply" $ - SomeMethod . SSayHelloStreamReply <$> - parseHelloRequest - , sub "sayHelloBidiStream" "helloworld.Greeter.SayHelloBidiStream" $ - SomeMethod . SSayHelloBidiStream <$> - Opt.many (parseDelayOr parseHelloRequest) - , sub "getFeature" "routeguide.RouteGuide.GetFeature" $ - SomeMethod . SGetFeature <$> - parsePoint "" - , sub "listFeatures" "routeguide.RouteGuide.ListFeatures" $ - SomeMethod . SListFeatures <$> - parseRectangle - , sub "recordRoute" "routeguide.RouteGuide.RecordRoute" $ - SomeMethod . SRecordRoute <$> - Opt.many (parseDelayOr $ parsePoint "") - , sub "routeChat" "routeguide.RouteGuide.RouteChat" $ - SomeMethod . SRouteChat <$> - Opt.many (parseDelayOr $ parseRouteNote) - , sub "ping" "Ping.ping" $ - SomeMethod . SPing <$> - Opt.argument parsePingMessage (Opt.metavar "NUM") - ] - -{------------------------------------------------------------------------------- - Method arguments --------------------------------------------------------------------------------} - -parseDelayOr :: Opt.Parser a -> Opt.Parser (DelayOr a) -parseDelayOr p = asum [ - Exec <$> p - , Delay <$> (Opt.option Opt.auto $ mconcat [ - Opt.long "delay" - , Opt.help "Delay by specified length in seconds" - , Opt.metavar "DOUBLE" - ]) - ] - -parseHelloRequest :: Opt.Parser (Proto HelloRequest) -parseHelloRequest = - mkHelloRequest <$> Opt.option Opt.str (mconcat [ - Opt.long "name" - , Opt.metavar "NAME" - ]) - where - mkHelloRequest :: Text -> Proto HelloRequest - mkHelloRequest name = (defMessage & #name .~ name) - -parseLatitude :: String -> Opt.Parser Int32 -parseLatitude prefix = - Opt.option Opt.auto $ mconcat [ - Opt.long $ prefix ++ "latitude" - ] - -parseLongitude :: String -> Opt.Parser Int32 -parseLongitude prefix = - Opt.option Opt.auto $ mconcat [ - Opt.long $ prefix ++ "longitude" - ] - -parsePoint :: String -> Opt.Parser (Proto Point) -parsePoint prefix = - mkPoint - <$> parseLatitude prefix - <*> parseLongitude prefix - where - mkPoint :: Int32 -> Int32 -> Proto Point - mkPoint latitude longitude = - defMessage - & #latitude .~ latitude - & #longitude .~ longitude - -parseRectangle :: Opt.Parser (Proto Rectangle) -parseRectangle = - mkRectangle - <$> parsePoint "lo-" - <*> parsePoint "hi-" - where - mkRectangle :: Proto Point -> Proto Point -> Proto Rectangle - mkRectangle lo hi = - defMessage - & #lo .~ lo - & #hi .~ hi - -parseRouteNote :: Opt.Parser (Proto RouteNote) -parseRouteNote = - mkRouteNote - <$> parsePoint "" - <*> Opt.argument Opt.str (Opt.metavar "MSG") - where - mkRouteNote :: Proto Point -> Text -> Proto RouteNote - mkRouteNote location message = - defMessage - & #location .~ location - & #message .~ message - -parsePingMessage :: Opt.ReadM (Proto PingMessage) -parsePingMessage = Opt.str >>= aux - where - aux :: String -> Opt.ReadM (Proto PingMessage) - aux str = - case readMaybe str of - Nothing -> fail $ "Could not parse ping ID " ++ show str - Just pid -> return $ defMessage & #id .~ pid - -{------------------------------------------------------------------------------- - Internal auxiliary --------------------------------------------------------------------------------} - -sub :: String -> String -> Opt.Parser a -> Opt.Mod Opt.CommandFields a -sub cmd desc parser = - Opt.command cmd $ - Opt.info (parser Opt.<**> Opt.helper) (Opt.progDesc desc) diff --git a/grapesy/demo-client/Demo/Client/Util/DelayOr.hs b/grapesy/demo-client/Demo/Client/Util/DelayOr.hs deleted file mode 100644 index c1f4e14e..00000000 --- a/grapesy/demo-client/Demo/Client/Util/DelayOr.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | Interleave values with delay requests --- --- Intended for qualified import. --- --- > import Demo.Client.Util.DelayOr (DelayOr(..)) --- > import Demo.Client.Util.DelayOr qualified as DelayOr -module Demo.Client.Util.DelayOr ( - DelayOr(..) - , mapM_ - , forM_ - , source - ) where - -import Prelude hiding (mapM_) -import Prelude qualified - -import Control.Concurrent hiding (yield) -import Control.Monad.IO.Class -import Data.Conduit - -data DelayOr a = - Delay Double -- ^ Delay in seconds - | Exec a -- ^ Execute the specified RPC - deriving (Show) - -delayOr :: MonadIO m => (a -> m ()) -> DelayOr a -> m () -delayOr _ (Delay d) = liftIO $ threadDelay (round (d * 1_000_000)) -delayOr f (Exec a) = f a - -mapM_ :: MonadIO m => (a -> m ()) -> [DelayOr a] -> m () -mapM_ = Prelude.mapM_ . delayOr - -forM_ :: MonadIO m => [DelayOr a] -> (a -> m ()) -> m () -forM_ = flip mapM_ - -source :: [DelayOr a] -> ConduitT () a IO () -source = Prelude.mapM_ (delayOr yield) - diff --git a/grapesy/demo-client/Demo/Client/Util/Logging.hs b/grapesy/demo-client/Demo/Client/Util/Logging.hs deleted file mode 100644 index 8b1939b8..00000000 --- a/grapesy/demo-client/Demo/Client/Util/Logging.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Demo.Client.Util.Logging ( - threadSafeTracer - , logMsg - ) where - -import Control.Concurrent -import Control.Monad.IO.Class -import Control.Tracer -import GHC.IO (unsafePerformIO) - -tracingLock :: MVar () -{-# NOINLINE tracingLock #-} -tracingLock = unsafePerformIO $ newMVar () - -threadSafeTracer :: Tracer IO String -threadSafeTracer = arrow $ emit $ \msg -> - withMVar tracingLock $ \() -> putStrLn msg - -logMsg :: (MonadIO m, Show a) => a -> m () -logMsg = liftIO . traceWith threadSafeTracer . show \ No newline at end of file diff --git a/grapesy/demo-client/Main.hs b/grapesy/demo-client/Main.hs deleted file mode 100644 index 613bd8dd..00000000 --- a/grapesy/demo-client/Main.hs +++ /dev/null @@ -1,135 +0,0 @@ --- | Demo client --- --- See @docs/demo.md@ for documentation. -module Main (main) where - -import Control.Concurrent -import Control.Exception -import System.IO - -import Network.GRPC.Client -import Network.GRPC.Common -import Network.GRPC.Common.Compression qualified as Compr - -import Demo.Client.Cmdline -import Demo.Client.Util.DelayOr qualified as DelayOr - -import Demo.Client.API.Core.Greeter qualified as Core.Greeter -import Demo.Client.API.Core.NoFinal.Greeter qualified as NoFinal.Greeter -import Demo.Client.API.Core.RouteGuide qualified as Core.RouteGuide -import Demo.Client.API.StreamType.Conduit.RouteGuide qualified as Conduit.RouteGuide -import Demo.Client.API.StreamType.IO.Greeter qualified as IO.Greeter -import Demo.Client.API.StreamType.IO.Ping qualified as IO.Ping -import Demo.Client.API.StreamType.IO.RouteGuide qualified as IO.RouteGuide -import Demo.Client.API.StreamType.MonadStack.Greeter qualified as CanCallRPC.Greeter - -{------------------------------------------------------------------------------- - Application entry point --------------------------------------------------------------------------------} - -main :: IO () -main = do - hSetBuffering stdout NoBuffering -- For easier debugging - cmd <- getCmdline - withConnection (connParams cmd) (cmdServer cmd) $ - DelayOr.forM_ (cmdMethods cmd) . dispatch cmd - -dispatch :: Cmdline -> Connection -> SomeMethod -> IO () -dispatch cmd conn method = - case method of - SomeMethod (SSayHello name) -> - case cmdAPI cmd of - StreamTypeIO -> - IO.Greeter.sayHello conn name - StreamTypeMonadStack -> - CanCallRPC.Greeter.sayHello conn name - CoreNoFinal -> - NoFinal.Greeter.sayHello conn name - _otherwise -> - unsupportedMode - SomeMethod (SSayHelloStreamReply name) -> - case cmdAPI cmd of - Core -> - Core.Greeter.sayHelloStreamReply conn name - StreamTypeIO -> - IO.Greeter.sayHelloStreamReply conn name - StreamTypeMonadStack -> - CanCallRPC.Greeter.sayHelloStreamReply conn name - _otherwise -> - unsupportedMode - SomeMethod (SSayHelloBidiStream names) -> - case cmdAPI cmd of - Core -> - Core.Greeter.sayHelloBidiStream conn names - _otherwise -> - unsupportedMode - SomeMethod (SGetFeature p) -> - case cmdAPI cmd of - StreamTypeIO -> - IO.RouteGuide.getFeature conn p - _otherwise -> - unsupportedMode - SomeMethod (SListFeatures r) -> - case cmdAPI cmd of - StreamTypeConduit -> - Conduit.RouteGuide.listFeatures conn r - StreamTypeIO -> - IO.RouteGuide.listFeatures conn r - Core -> - Core.RouteGuide.listFeatures conn r - _otherwise -> - unsupportedMode - SomeMethod (SRecordRoute ps) -> - case cmdAPI cmd of - StreamTypeConduit -> - Conduit.RouteGuide.recordRoute conn ps - StreamTypeIO -> - IO.RouteGuide.recordRoute conn ps - _otherwise -> - unsupportedMode - SomeMethod (SRouteChat notes) -> - case cmdAPI cmd of - StreamTypeConduit -> - Conduit.RouteGuide.routeChat conn notes - StreamTypeIO -> - IO.RouteGuide.routeChat conn notes - _otherwise -> - unsupportedMode - SomeMethod (SPing msg) -> - case cmdAPI cmd of - StreamTypeIO -> - IO.Ping.ping conn msg - _otherwise -> - unsupportedMode - where - unsupportedMode :: IO a - unsupportedMode = throwIO $ userError $ concat [ - "Mode " - , show (cmdAPI cmd) - , " not supported for " - , show method - ] - -{------------------------------------------------------------------------------- - Interpret command line --------------------------------------------------------------------------------} - -connParams :: Cmdline -> ConnParams -connParams cmd = def { - connCompression = - case cmdCompression cmd of - Just alg -> Compr.only alg - Nothing -> connCompression def - , connDefaultTimeout = - Timeout Second . TimeoutValue <$> cmdTimeout cmd - , connReconnectPolicy = - exponentialBackoff waitFor 1.5 (1, 2) 10 - } - where - waitFor :: Int -> IO () - waitFor delay = do - putStrLn $ "Disconnected. Reconnecting after " ++ show delay ++ "μs" - threadDelay delay - putStrLn "Reconnecting now." - - diff --git a/grapesy/demo-server/Demo/Server/Aux/RouteGuide.hs b/grapesy/demo-server/Demo/Server/Aux/RouteGuide.hs deleted file mode 100644 index a7659a63..00000000 --- a/grapesy/demo-server/Demo/Server/Aux/RouteGuide.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLabels #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Demo.Server.Aux.RouteGuide ( - featureAt - , inRectangle - , summary - , distance - ) where - -import Data.Aeson -import Data.Int -import Data.Maybe (listToMaybe) -import Data.Time - -import Proto.RouteGuide - -import Network.GRPC.Common.Protobuf - -{------------------------------------------------------------------------------- - Pure functions that implement that basic Route Guide functionality --------------------------------------------------------------------------------} - -featureAt :: Proto Point -> [Proto Feature] -> Maybe (Proto Feature) -featureAt p db = listToMaybe $ filter (\f -> f ^. #location == p) db - -inRectangle :: Proto Rectangle -> Proto Point -> Bool -inRectangle r p = and [ - p ^. #longitude >= left - , p ^. #longitude <= right - , p ^. #latitude >= bottom - , p ^. #latitude <= top - ] - where - left, right, top, bottom :: Int32 - left = min (r ^. #lo ^. #longitude) (r ^. #hi ^. #longitude) - right = max (r ^. #lo ^. #longitude) (r ^. #hi ^. #longitude) - top = max (r ^. #lo ^. #latitude) (r ^. #hi ^. #latitude) - bottom = min (r ^. #lo ^. #latitude) (r ^. #hi ^. #latitude) - -summary :: [Proto Feature] -> NominalDiffTime -> [Proto Point] -> Proto RouteSummary -summary db duration ps = - defMessage - & #pointCount .~ fromIntegral (length ps) - & #featureCount .~ fromIntegral (length visited) - & #distance .~ floor (distance ps) - & #elapsedTime .~ round duration - where - visited :: [Proto Feature] - visited = filter (\f -> any (== f ^. #location) ps) db - --- | Total distance between the points -distance :: [Proto Point] -> Double -distance = \case - [] -> 0 - p:ps -> go 0 p ps - where - go :: Double -> Proto Point -> [Proto Point] -> Double - go !acc _ [] = acc - go !acc prev (p:ps) = go (acc + distanceBetween prev p) p ps - --- | Distance between two points (in meters) --- --- For consistency, this is a direct translation of the Python example code in --- the gRPC repo. -distanceBetween :: Proto Point -> Proto Point -> Double -distanceBetween fr to = - let a, c :: Double - a = sin (deltaLat / 2) ** 2 - + (cos frLat * cos toLat * sin (deltaLon / 2) ** 2) - c = 2 * atan2 (sqrt a) (sqrt (1 - a)) - in r * c - where - coordFactor :: Double - coordFactor = 10_000_000 - - frLat, frLon, toLat, toLon :: Double - frLat = degToRad $ fromIntegral (fr ^. #latitude) / coordFactor - frLon = degToRad $ fromIntegral (fr ^. #longitude) / coordFactor - toLat = degToRad $ fromIntegral (to ^. #latitude) / coordFactor - toLon = degToRad $ fromIntegral (to ^. #longitude) / coordFactor - - deltaLat, deltaLon :: Double - deltaLat = toLat - frLat - deltaLon = toLon - frLon - - -- Earth's radius - r :: Double - r = 6371000 - -{------------------------------------------------------------------------------- - JSON --------------------------------------------------------------------------------} - -instance FromJSON (Proto Feature) where - parseJSON = withObject "Feature" $ \obj -> do - location <- obj .: "location" - name <- obj .: "name" - return $ - defMessage - & #location .~ location - & #name .~ name - -instance FromJSON (Proto Point) where - parseJSON = withObject "Point" $ \obj -> do - latitude <- obj .: "latitude" - longitude <- obj .: "longitude" - return $ - defMessage - & #latitude .~ latitude - & #longitude .~ longitude - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - -degToRad :: Double -> Double -degToRad d = d * (pi / 180) diff --git a/grapesy/demo-server/Demo/Server/Cmdline.hs b/grapesy/demo-server/Demo/Server/Cmdline.hs deleted file mode 100644 index be8560c4..00000000 --- a/grapesy/demo-server/Demo/Server/Cmdline.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} -module Demo.Server.Cmdline ( - Cmdline(..) - , getCmdline - ) where - -import Data.Foldable (asum) -import Network.Socket (PortNumber, HostName) -import Options.Applicative ((<**>)) -import Options.Applicative qualified as Opt - -import Network.GRPC.Common -import Network.GRPC.Server.Run - -import Paths_grapesy - -{------------------------------------------------------------------------------- - Definition --------------------------------------------------------------------------------} - -data Cmdline = Cmdline { - cmdInsecure :: Maybe InsecureConfig - , cmdSecure :: Maybe SecureConfig - , cmdTrailersOnlyShortcut :: Bool - , cmdDisableCompression :: Bool - } - deriving (Show) - -{------------------------------------------------------------------------------- - Top-level --------------------------------------------------------------------------------} - -getCmdline :: IO Cmdline -getCmdline = do - defaultPub <- getDataFileName "grpc-demo.pem" - defaultPriv <- getDataFileName "grpc-demo.key" - - let info :: Opt.ParserInfo Cmdline - info = Opt.info - ( parseCmdline defaultPub defaultPriv - <**> Opt.helper - ) - Opt.fullDesc - - Opt.execParser info - -parseCmdline :: FilePath -> FilePath -> Opt.Parser Cmdline -parseCmdline defaultPub defaultPriv = - Cmdline - <$> parseInsecure - <*> parseSecure defaultPub defaultPriv - <*> (Opt.switch $ mconcat [ - Opt.long "trailers-only-shortcut" - , Opt.help "Use Trailers-Only even in non-error cases" - ]) - <*> (Opt.switch $ mconcat [ - Opt.long "disable-compression" - , Opt.help "Disable support for compression" - ]) - -parseInsecure :: Opt.Parser (Maybe InsecureConfig) -parseInsecure = asum [ - Opt.flag' Nothing $ mconcat [ - Opt.long "disable-insecure" - , Opt.help "Disable insecure server (without TLS)" - ] - , cfg - <$> Opt.option Opt.auto (mconcat [ - Opt.long "port-insecure" - , Opt.help "Port number for the insecure server (without TLS)" - ]) - <*> Opt.optional (Opt.option Opt.str (mconcat [ - Opt.long "host-insecure" - , Opt.help "Host name to bind the insecure server to" - ])) - ] - where - cfg :: PortNumber -> Maybe HostName -> Maybe InsecureConfig - cfg port host = Just InsecureConfig { - insecureHost = host - , insecurePort = port - } - -parseSecure :: FilePath -> FilePath -> Opt.Parser (Maybe SecureConfig) -parseSecure defaultPub defaultPriv = asum [ - Opt.flag' Nothing $ mconcat [ - Opt.long "disable-secure" - , Opt.help "Disable secure server (over TLS)" - ] - , cfg - <$> Opt.option Opt.auto (mconcat [ - Opt.long "port-secure" - , Opt.help "Port number for the insecure server (over TLS)" - ]) - <*> (Opt.option Opt.str $ mconcat [ - Opt.long "host-secure" - , Opt.help "Host name to bind the secure server to" - ]) - <*> (Opt.option Opt.str $ mconcat [ - Opt.long "tls-pub" - , Opt.help "TLS public certificate (X.509 format)" - , Opt.value defaultPub - , Opt.showDefault - ]) - <*> Opt.many (Opt.option Opt.str $ mconcat [ - Opt.long "tls-cert" - , Opt.help "TLS chain certificate (X.509 format)" - ]) - <*> (Opt.option Opt.str $ mconcat [ - Opt.long "tls-priv" - , Opt.help "TLS private key" - , Opt.value defaultPriv - , Opt.showDefault - ]) - ] - where - cfg :: - PortNumber - -> HostName - -> FilePath - -> [FilePath] - -> FilePath - -> Maybe SecureConfig - cfg port host pub chain priv = Just SecureConfig { - secureHost = host - , securePort = port - , securePubCert = pub - , secureChainCerts = chain - , securePrivKey = priv - , secureSslKeyLog = SslKeyLogNone - } diff --git a/grapesy/demo-server/Demo/Server/Service/Greeter.hs b/grapesy/demo-server/Demo/Server/Service/Greeter.hs deleted file mode 100644 index 7dd86457..00000000 --- a/grapesy/demo-server/Demo/Server/Service/Greeter.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} - -module Demo.Server.Service.Greeter (handlers) where - -import Control.Exception -import Control.Monad -import Data.Text (Text) - -import Network.GRPC.Common -import Network.GRPC.Common.Protobuf -import Network.GRPC.Server -import Network.GRPC.Server.Protobuf -import Network.GRPC.Server.StreamType - -import Proto.API.Helloworld - -{------------------------------------------------------------------------------- - Top-level --------------------------------------------------------------------------------} - -handlers :: Methods IO (ProtobufMethodsOf Greeter) -handlers = - Method (mkNonStreaming sayHello) - $ RawMethod sayHelloBidiStream - $ RawMethod sayHelloStreamReply - $ NoMoreMethods - -{------------------------------------------------------------------------------- - Individual handlers --------------------------------------------------------------------------------} - -sayHello :: Proto HelloRequest -> IO (Proto HelloReply) -sayHello req = return $ defMessage & #message .~ msg - where - msg :: Text - msg = "Hello, " <> req ^. #name <> "!" - -sayHelloStreamReply :: RpcHandler IO SayHelloStreamReply -sayHelloStreamReply = mkRpcHandlerNoDefMetadata $ \call -> do - setResponseInitialMetadata call $ SayHelloMetadata (Just "initial-md-value") - - -- The client expects the metadata well before the first output - initiateResponse call - - req <- recvFinalInput call - - let msg :: Text -> Text - msg i = "Hello " <> req ^. #name <> " times " <> i - - forM_ ["0", "1", "2"] $ \i -> - sendNextOutput call $ defMessage & #message .~ msg i - - sendTrailers call def - -sayHelloBidiStream :: RpcHandler IO (Protobuf Greeter "sayHelloBidiStream") -sayHelloBidiStream = mkRpcHandler $ \call -> do - let loop :: IO () - loop = do - mReq <- recvInput call - case mReq of - StreamElem req -> handleRequest call req >> loop - FinalElem req _ -> handleRequest call req - NoMoreElems _ -> return () - - handle cancellation $ loop - where - handleRequest :: Call SayHelloBidiStream -> Proto HelloRequest -> IO () - handleRequest call req = - sendNextOutput call $ defMessage & #message .~ msg - where - msg :: Text - msg = req ^. #name <> " Ack" - - cancellation :: ClientDisconnected -> IO () - cancellation _ = putStrLn "sayHelloBidiStream server: cancelled." - diff --git a/grapesy/demo-server/Demo/Server/Service/Ping.hs b/grapesy/demo-server/Demo/Server/Service/Ping.hs deleted file mode 100644 index 212c99e2..00000000 --- a/grapesy/demo-server/Demo/Server/Service/Ping.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} - -module Demo.Server.Service.Ping (handlers) where - -import Network.GRPC.Common.Protobuf -import Network.GRPC.Server.StreamType - -import Proto.API.Ping - -handlers :: Methods IO '[Ping] -handlers = - Method (mkNonStreaming handlePing) - $ NoMoreMethods - -handlePing :: Proto PingMessage -> IO (Proto PongMessage) -handlePing ping = return $ defMessage & #id .~ (ping ^. #id) - diff --git a/grapesy/demo-server/Demo/Server/Service/RouteGuide.hs b/grapesy/demo-server/Demo/Server/Service/RouteGuide.hs deleted file mode 100644 index 03cc6866..00000000 --- a/grapesy/demo-server/Demo/Server/Service/RouteGuide.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedLabels #-} - -module Demo.Server.Service.RouteGuide ( - Handler -- opaque - , runHandler - , handlers - ) where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State (StateT, evalStateT) -import Control.Monad.Trans.State qualified as State -import Data.Map qualified as Map -import Data.Maybe (fromMaybe) -import Data.Time - -import Network.GRPC.Common -import Network.GRPC.Common.NextElem qualified as NextElem -import Network.GRPC.Common.Protobuf -import Network.GRPC.Server -import Network.GRPC.Server.Protobuf -import Network.GRPC.Server.StreamType - -import Demo.Server.Aux.RouteGuide -import Demo.Server.Cmdline - -import Proto.API.RouteGuide - -{------------------------------------------------------------------------------- - Custom handler monad - - This isn't really necessary, but demonstrates that we can. --------------------------------------------------------------------------------} - -newtype Handler a = Wrap { - unwrap :: ReaderT [Proto Feature] IO a - } - deriving newtype ( - Functor - , Applicative - , Monad - , MonadIO - ) - -runHandler :: [Proto Feature] -> Handler a -> IO a -runHandler db = flip runReaderT db . unwrap - -asksDb :: ([Proto Feature] -> a) -> Handler a -asksDb = Wrap . asks - -{------------------------------------------------------------------------------- - Top-level --------------------------------------------------------------------------------} - -handlers :: Cmdline -> Methods Handler (ProtobufMethodsOf RouteGuide) -handlers cmdline - | cmdTrailersOnlyShortcut cmdline - = Method (mkNonStreaming getFeature ) - $ RawMethod (mkRpcHandler trailersOnlyShortcut) - $ Method (mkClientStreaming recordRoute ) - $ Method (mkBiDiStreaming routeChat ) - $ NoMoreMethods - - -- demonstrate the use of 'simpleMethods' - | otherwise - = simpleMethods - (mkNonStreaming getFeature ) - (mkServerStreaming listFeatures) - (mkClientStreaming recordRoute ) - (mkBiDiStreaming routeChat ) - -{------------------------------------------------------------------------------- - Handlers --------------------------------------------------------------------------------} - -getFeature :: Proto Point -> Handler (Proto Feature) -getFeature p = asksDb $ fromMaybe defMessage . featureAt p - -listFeatures :: - Proto Rectangle - -> (NextElem (Proto Feature) -> IO ()) - -> Handler () -listFeatures r send = do - ps <- asksDb $ filter (\f -> inRectangle r (f ^. #location)) - liftIO $ NextElem.mapM_ send ps - -recordRoute :: - IO (NextElem (Proto Point)) - -> Handler (Proto RouteSummary) -recordRoute recv = do - mkSummary <- asksDb summary - liftIO $ do - start <- getCurrentTime - ps <- NextElem.collect recv - stop <- getCurrentTime - return $ mkSummary (stop `diffUTCTime` start) ps - -routeChat :: - IO (NextElem (Proto RouteNote)) - -> (NextElem (Proto RouteNote) -> IO ()) - -> Handler () -routeChat recv send = liftIO $ flip evalStateT Map.empty $ do - NextElem.whileNext_ (liftIO recv) $ \n -> modifyM $ \acc -> do - let notes = Map.findWithDefault [] (n ^. #location) acc - mapM_ (send . NextElem) $ reverse notes - return $ Map.alter (Just . (n:) . fromMaybe []) (n ^. #location) acc - liftIO $ send NoNextElem - -{------------------------------------------------------------------------------- - Trailers-Only shortcut - - See discussion in @demo-server.md@. --------------------------------------------------------------------------------} - -trailersOnlyShortcut :: Call ListFeatures -> Handler () -trailersOnlyShortcut call = do - r <- liftIO $ recvFinalInput call - features <- asksDb $ filter (\f -> inRectangle r (f ^. #location)) - liftIO $ - if null features then - sendTrailersOnly call def - else do - mapM_ (sendOutput call . StreamElem) features - sendTrailers call def - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - -modifyM :: Monad m => (s -> m s) -> StateT s m () -#if MIN_VERSION_transformers(0,6,1) -modifyM = State.modifyM -#else -modifyM f = State.StateT $ \s -> ((),) <$> f s -#endif diff --git a/grapesy/demo-server/Main.hs b/grapesy/demo-server/Main.hs deleted file mode 100644 index 4eced14d..00000000 --- a/grapesy/demo-server/Main.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main (main) where - -import Data.Aeson - -import Network.GRPC.Common -import Network.GRPC.Common.Compression qualified as Compression -import Network.GRPC.Common.Protobuf -import Network.GRPC.Server -import Network.GRPC.Server.Protobuf -import Network.GRPC.Server.Run -import Network.GRPC.Server.StreamType - -import Paths_grapesy - -import Demo.Server.Cmdline -import Demo.Server.Service.Greeter qualified as Greeter -import Demo.Server.Service.Ping qualified as Ping -import Demo.Server.Service.RouteGuide qualified as RouteGuide - -import Proto.API.Helloworld -import Proto.API.Ping -import Proto.API.RouteGuide - -{------------------------------------------------------------------------------- - All services --------------------------------------------------------------------------------} - -services :: - Cmdline - -> [Proto Feature] - -> Services IO [ - ProtobufMethodsOf Greeter - , ProtobufMethodsOf RouteGuide - , '[Ping] - ] -services cmdline db = - Service Greeter.handlers - $ Service (hoistMethods runHandler $ RouteGuide.handlers cmdline) - $ Service Ping.handlers - $ NoMoreServices - where - runHandler :: RouteGuide.Handler a -> IO a - runHandler = RouteGuide.runHandler db - -{------------------------------------------------------------------------------- - Application --------------------------------------------------------------------------------} - -main :: IO () -main = do - cmdline <- getCmdline - db <- getRouteGuideDb - - let serverConfig :: ServerConfig - serverConfig = ServerConfig { - serverInsecure = cmdInsecure cmdline - , serverSecure = cmdSecure cmdline - } - - runServerWithHandlers - (serverParams cmdline) - serverConfig - (fromServices $ services cmdline db) - -getRouteGuideDb :: IO [Proto Feature] -getRouteGuideDb = do - path <- getDataFileName "route_guide_db.json" - mDb <- decodeFileStrict path - case mDb of - Just db -> return db - Nothing -> error "Could not parse the route guide DB" - -serverParams :: Cmdline -> ServerParams -serverParams cmd = def { - serverCompression = - if cmdDisableCompression cmd - then Compression.none - else serverCompression def - } - diff --git a/grapesy/docs/demo-client.md b/grapesy/docs/demo-client.md deleted file mode 100644 index 15d7b3e6..00000000 --- a/grapesy/docs/demo-client.md +++ /dev/null @@ -1,433 +0,0 @@ -# Demo client - -The code for the demo can be found in [`demo/Main.hs`](/demo-client/Main.hs). It -is based on the examples from the [gRPC docs](https://grpc.io/docs/). We will -mostly refer to the [Python version](https://grpc.io/docs/languages/python/) of -these examples, as it is the most complete, although we will also provide some -pointers for testing against the [C++ -version](https://grpc.io/docs/languages/cpp/). - -In the explanations below, `grpc-repo` refers to a local checkout of the [gRPC -repo](https://github.com/grpc/grpc). These instructions are based on commit hash -[358bfb5](https://github.com/grpc/grpc/commit/358bfb581feeda5bf17dd3b96da1074d84a6ef8d). - -## Protobuf - -All of these examples use the Protobuf instantiation of `gRPC`. On the Haskell -side, `.proto` files are compiled using -[`proto-lens-protoc`](https://hackage.haskell.org/package/proto-lens-protoc). -This uses type-level symbols to refer to service methods; one minor pecularity -here is that it turns the first letter of the method name to lowercase. For -example, `helloworld.Greeter.SayHello` becomes - -```haskell -Protobuf @Greeter @"sayHello" -``` - -## TLS - -See https://grpc.io/docs/guides/auth/#python for the changes required to the -Python code to enable TLS. - -To connect over TLS, run the client with `--secure`: - -``` -cabal run demo-client -- sayHello --name 'John' --secure -``` - -By default this sets up the `demo-server`'s certificate as a root, so that the -client can verify the certificate. See the command line flags for details. - -## Quick start - -### `helloworld.Greeter.SayHello` - -Haskell implementation: `greeterSayHello`. - -Assumes running server: - -* If testing against `grapesy`'s own demo-server, see `demo-server.md`. - -* If testing against example Python server: - - ``` - grpc-repo/examples/python/helloworld$ python3 greeter_server.py - ``` - -* If testing against example C++ server: - - ``` - grpc-repo/examples/cpp/helloworld/cmake/build$ ./greeter_server - ``` - -Run client with - -``` -cabal run demo-client -- sayHello --name 'John' -``` - -The output will be slightly different depending on which server you use. - -### Testing low-level details - -We can also send _multiple_ messages: - -``` -cabal run demo-client -- \ - sayHello --name 'John' \ - sayHello --name 'Alice' -``` - -optionally with pauses: - -``` -cabal run demo-client -- \ - sayHello --name 'John' \ - --delay 5 \ - sayHello --name 'Alice' -``` - -#### Compression - -This can be interesting for example to verify that compression is working -properly (the first message will be sent without compression since it's not yet -known what compression schemes the server supports, but subsequent messages -should then be compressed). However, it takes a bit of effort to make the server -actually compress anything: - -* You need to enable compression in the server; for the Python one, see - https://github.com/grpc/grpc/blob/master/examples/python/compression/README.md -* You need to send a "name" that is long enough that the server actually - bothers with compression at all. -* You can also use the `--gzip`, `--deflate`, or `--snappy` command line flags - to tell the server to *only* use GZip, Deflate, or Snappy compression, - respectively. - -For example: - -``` -cabal run demo-client -- --gzip \ - sayHello --name 'John' \ - sayHello --name '0xxxxxxxxxx1xxxxxxxxxx2xxxxxxxxxx3xxxxxxxxxx4xxxxxxxxxx5xxxxxxxxxx' -``` - -Of course, the compression is transparent to the user, but you can observe it -in Wireshark. - -#### Automatic reconnect - -The `grapesy` implementation of `gRPC` supports -[wait for ready](https://github.com/grpc/grpc/blob/master/doc/wait-for-ready.md) -semantics, meaning that if the server cannot be reached, the connection will -automatically be retried. This is disabled by default (as per the spec), but the -demo client enables it, trying at most 10x to connect to a server, using -exponential backoff as the reconnection policy. - -Closely related, the same reconnection policy then also enables automatic -reconnects, which means the client will re-establish a connection to a server -after it has lost it. - -We can observe both using the demo client and server. Start the client without -the server: - -``` -cabal run demo-client -- \ - sayHello --name 'John' \ - --delay 5 \ - sayHello --name 'Alice' -``` - -Then start the server; you should see the first `sayHello` method call happen: - -``` -{message: "Hello, John!"} -``` - -Now stop the server again, and the client will try to reconnect again. Finally, -if you now start the server again, the client should be able to connect again: - -``` -{message: "Hello, Alice!"} -``` - -This means that code can just create one `Connection` object and keep using it, -even in the presence of temporary network failures etc.: `grapesy` will -automatically reconnect. Of course, this is only true for _new_ RPC calls; -_existing_ calls will fail. To see this, we can run the `sayHelloBidiStream` -version of hello world, which uses a streaming RPC call, saying "hello" to each -name as they stream in (as opposed to making multiple RPC calls for each name). -Start the server again, and then run the client; after the first hello, stop -the server and start it again; the client will reconnect, but when it tries to -send the next message, an exception will be raised: - -``` -$ cabal run demo-client -- --core sayHelloBidiStream \ - --name 'John' \ - --delay 10 \ - --name 'Joe' \ - --name 'Jay' -{message: "John Ack"} -Disconnected. Reconnecting after 1701081μs -Reconnecting now. -demo-client: demo-client: ServerDisconnected {serverDisconnectedException = ..., ...} -``` - -### Dealing with unterminated streams - -Normally the last message to the server is marked as `END_STREAM`. If this is -not the case, the server can still respond, but they will additionally send a -`RST_STREAM` frame to the client to indicate that the stream has ended. -To test this we can intentionally omit the `END_STREAM` marker: - -``` -cabal run demo-client -- --core-dont-mark-final sayHello --name 'John' -``` - -Wireshark can be used to observe the `END_STREAM` marker being sent -(note that this depends on https://github.com/kazu-yamamoto/http2/pull/78). - -### `helloworld.Greeter.SayHelloStreamReply` - -Haskell implementation: `greeterSayHelloStreamReply`. - -This is only implemented by a _single_ example server (the Python one). Run it -with - -``` -grpc-repo/examples/python/wait_for_ready$ - python3 wait_for_ready_with_client_timeout_example_server.py -``` - -Run client with - -``` -cabal run demo-client -- sayHelloStreamReply --name 'John' -``` - -The Python server has some intentional delays in there, so the streaming will be -relatively slow (delays on the order of seconds). Moreover, this example also -sends some metadata in the initial request. Metadata is not available using the -standard Protobuf API in grapesy; instead, we need to use the full client API. -The demo does this in the `Core` implementation: - -``` -cabal run demo-client -- --core sayHelloStreamReply --name 'John' -``` - -This should output something like: - -``` -# pause.. -ResponseInitialMetadata (SayHelloMetadata (Just "initial-md-value")) -# pause.. -{message: "Hello John times 0"} -{message: "Hello John times 1"} -{message: "Hello John times 2"} -NoMetadata -``` - -### `helloworld.Greeter.SayHelloBidiStream` - -This is an illustration of cancellation -(https://grpc.io/docs/guides/cancellation/) and is only supported by the C++ -example in `grpc-repo/examples/cpp/cancellation`. Provided the C++ server is -running, you can run the client with - -``` -cabal run demo-client -- --core sayHelloBidiStream \ - --name 'John' \ - --name 'Joe' \ - --name 'Jay' -``` - -## Route guide - -Instructions below assume a running server: - -``` -grpc-repo/examples/python/route_guide$ python3 route_guide_server.py -``` - -or - -``` -grpc-repo/examples/cpp/route_guide$ cmake/build/route_guide_server -``` - -All methods except `getFeature` support the `--streamtype-conduit` option to use -the [`Conduit` interface](/src/Network/GRPC/Client/StreamType/Conduit.hs). - -### `routeguide.RouteGuide.GetFeature` (non-streaming RPC) - -Haskell implementation: `routeGuideGetFeature`. - -Run client: - -``` -cabal run demo-client -- getFeature --latitude 409146138 --longitude -746188906 -``` - -(for a location where there exists a feature), or - -``` -cabal run demo-client -- getFeature --latitude 0 --longitude 0 -``` - -for a location where there is not. - -### `routeguide.RouteGuide.ListFeatures` (server-side streaming) - -Haskell implementation: `routeGuideListFeatures`. - -Run client: - -``` -cabal run demo-client -- listFeatures \ - --lo-latitude 400000000 \ - --lo-longitude -750000000 \ - --hi-latitude 420000000 \ - --hi-longitude -730000000 -``` - -#### Edge case: no features - -An important edge case here is the case where there are zero features in -the specified rectangle: - -``` -cabal run demo-client -- listFeatures \ - --lo-latitude 0 \ - --lo-longitude 0 \ - --hi-latitude 0 \ - --hi-longitude 0 -``` - -This is important because this triggers the gRPC `Trailers-Only` case despite -not being an error (strictly speaking this is not conform the gRPC spec). - -This test can also be run with `--core`, in which case it shows the received -metadata. This is important, even though that metadata is empty, because it -requires some special care to treat that metadata correctly in this case; see -discussion in `Network.GRPC.Spec.Response`. - -### `routeguide.RouteGuide.RecordRuite` (client-side streaming) - -Haskell implementation: `routeGuideRecordRoute`. - -Run client: - -``` -cabal run demo-client -- recordRoute \ - --latitude 404306372 --longitude -741079661 \ - --delay 0.5 \ - --latitude 406109563 --longitude -742186778 \ - --delay 0.5 \ - --latitude 417951888 --longitude -748484944 \ - --delay 0.5 \ - --latitude 411236786 --longitude -744070769 \ - --delay 0.5 \ - --latitude 409224445 --longitude -748286738 \ - --delay 0.5 \ - --latitude 407586880 --longitude -741670168 \ - --delay 0.5 \ - --latitude 415736605 --longitude -742847522 \ - --delay 0.5 \ - --latitude 411236786 --longitude -744070769 \ - --delay 0.5 \ - --latitude 400106455 --longitude -742870190 \ - --delay 0.5 \ - --latitude 404615353 --longitude -745129803 -``` - -This should report something like - -``` -{point_count: 10 feature_count: 10 distance: 667689 elapsed_time: 4} -``` - -#### Edge case: empty route - -One important edge case here is the empty route: - -``` -cabal run demo-client -- recordRoute -``` - -(This is effectively the equivalent of the `Trailers-Only` case from the "no -features" edge case above, except of course that gRPC does not actually support -request trailers. Nonetheless, similar scenario.) - -### `routeguide.RouteGuide.RouteChat` (bidirectional streaming) - -Haskell implementation: `routeGuideRouteChat`. - -This example is a bit strange; despite the name "chat" it does not actually -allow for communication between clients. Instead, the server will keep a history -of all notes received, and whenever it receives another note, it will output all -previous notes at that same location. So if you run the client with something -like this: - -``` -cabal run demo-client -- routeChat \ - --latitude 0 --longitude 0 'A' \ - --delay 1 \ - --latitude 0 --longitude 0 'B' \ - --delay 1 \ - --latitude 0 --longitude 0 'C' \ - --delay 1 \ - --latitude 0 --longitude 0 'D' \ - --delay 1 \ - --latitude 0 --longitude 1 'E' \ - --delay 1 \ - --latitude 0 --longitude 1 'F' \ - --delay 1 \ - --latitude 0 --longitude 1 'G' \ - --delay 1 \ - --latitude 0 --longitude 0 'H' -``` - -you will get this output: - -``` -Sending {location { } message: "A"} -Delay 1.0s - -Sending {location { } message: "B"} -Delay 1.0s -{location { } message: "A"} - -Sending {location { } message: "C"} -Delay 1.0s -{location { } message: "A"} -{location { } message: "B"} - -Sending {location { } message: "D"} -Delay 1.0s -{location { } message: "A"} -{location { } message: "B"} -{location { } message: "C"} - -Sending {location { longitude: 1 } message: "E"} -Delay 1.0s - -Sending {location { longitude: 1 } message: "F"} -Delay 1.0s -{location { longitude: 1 } message: "E"} - -Sending {location { longitude: 1 } message: "G"} -Delay 1.0s -{location { longitude: 1 } message: "E"} -{location { longitude: 1 } message: "F"} - -Sending {location { } message: "H"} -{location { } message: "A"} -{location { } message: "B"} -{location { } message: "C"} -{location { } message: "D"} -``` - -**Note**: The C++ implementation of this server seems buggy: new clients that -connect sometimes (randomly?) get state from old clients. The Python client does -not do this. - - diff --git a/grapesy/docs/demo-server.md b/grapesy/docs/demo-server.md deleted file mode 100644 index 1a7f4790..00000000 --- a/grapesy/docs/demo-server.md +++ /dev/null @@ -1,108 +0,0 @@ -# Demo server - -The demo server implements the `Greeter` (`helloworld.proto`) and `RouteGuide` -(`route_guide.proto`) examples from the gRPC repo. - -## Running the server - -Start the server with - -``` -cabal run demo-server -- \ - --port-insecure 50051 \ - --port-secure 50052 --host-secure 0.0.0.0 -``` - -The secure server uses a bundled self-signed certificate by default. See the -command line flags for details. - -## Testing the server - -See https://grpc.io/docs/guides/auth/#python for the changes required to the -Python code to enable TLS. - -### `Greeter` - -#### `Greeter.SayHello` - -To test the server against a `Greeter` client, can run the Python one: - -``` -grpc-repo/examples/python/helloworld$ python3 greeter_client.py -Will try to greet world ... -Greeter client received: Hello, you! -``` - -#### `Greeter.SayHelloStreamReply` - -This appears to be supported only by a Python demo: - -``` -grpc-repo/examples/python/wait_for_ready$ python3 wait_for_ready_with_client_timeout_example_client.py -Greeter client received initial metadata: key=initial-md value=initial-md-value -received initial metadata before time out! -Greeter client received: Hello you times 0 -Greeter client received: Hello you times 1 -Greeter client received: Hello you times 2 -``` - -#### `Greeter.SayHelloBidiStream` - -This is a recent addition to the demo, illustrating cancellation -(https://grpc.io/docs/guides/cancellation/). It appears to be supported only by -a C++ demo: - -``` -grpc-repo/examples/cpp/cancellation/cmake/build$ ./client -``` - -(See https://grpc.io/docs/languages/cpp/quickstart/ for instructions on how -to compile the C++ examples.) - -### `RouteGuide` - -Run the Python client: - -``` -grpc-repo/examples/python/route_guide$ python3 route_guide_client.py -``` - -(output omitted). - -### Compression - -Currently server-side compression can be verified simply by running the Python -hello-world client (and then looking at the communication in Wireshark), because -the server applies compression independent of whether that saves space or not. - -### Trailers-Only shortcut - -A normal gRPC response looks like - -``` - - - -``` - -If there are no messages, then this whole thing collapses to just a set of -trailers (or headers; the distinction is no longer relevant in this case); the -gRPC specification refers to this as `Trailers-Only`. The spec says that this -should _only_ be used in error cases, but in practice some servers also use this -for normal cases. For example, the Python implementation of the `ListFeatures` -method will use `Trailers-Only` in the case that the list of features is empty. - -The Protobuf-specific wrappers in `grapesy` will not use `Trailers-Only` except -in the case of errors, conforming to the spec; however, it is possible to use -the lower-level server API to get the behaviour exibited by the Python example -implementation. The command line flag `--trailers-only-shortcut` enables this -for the demo server. The difference in server operation can only be observed -with Wireshark; a request for a list of features in the rectangle `(0, 0, 0, 0)` -(which is empty) will - -* result in three HTTP frames in the normal case (`HEADERS`, empty `DATA` to - separate headers from trailers, and another `HEADERS` frame with the trailers) -* result in a single HTTP `HEADERS` frame when using `--trailers-only-shortcut` - -Note that this behaviour does _NOT_ conform the gRPC spec, so not all clients -may support it. diff --git a/grapesy/grapesy.cabal b/grapesy/grapesy.cabal index 1019a58b..b7194db0 100644 --- a/grapesy/grapesy.cabal +++ b/grapesy/grapesy.cabal @@ -268,98 +268,6 @@ test-suite test-grapesy , temporary >= 1.3 && < 1.4 , unix >= 2.7 && < 2.9 -executable demo-client - import: lang, common-executable-flags - hs-source-dirs: demo-client, proto - main-is: Main.hs - autogen-modules: Paths_grapesy - build-depends: grapesy - - other-modules: - Demo.Client.API.Core.Greeter - Demo.Client.API.Core.NoFinal.Greeter - Demo.Client.API.Core.RouteGuide - Demo.Client.API.StreamType.Conduit.RouteGuide - Demo.Client.API.StreamType.IO.Greeter - Demo.Client.API.StreamType.IO.Ping - Demo.Client.API.StreamType.IO.RouteGuide - Demo.Client.API.StreamType.MonadStack.Greeter - Demo.Client.Cmdline - Demo.Client.Util.DelayOr - Demo.Client.Util.Logging - - Paths_grapesy - - Proto.API.Helloworld - Proto.API.Ping - Proto.API.RouteGuide - Proto.Helloworld - Proto.Ping - Proto.RouteGuide - - build-depends: - -- Inherited dependencies - , async - , bytestring - , conduit - , exceptions - , network - , text - - build-depends: - -- Additional dependencies - , contra-tracer >= 0.2 && < 0.3 - , optparse-applicative >= 0.16 && < 0.19 - , proto-lens-runtime >= 0.7 && < 0.8 - , transformers >= 0.5 && < 0.7 - - if !flag(build-demo) - buildable: - False - -executable demo-server - import: lang, common-executable-flags - hs-source-dirs: demo-server, proto - main-is: Main.hs - autogen-modules: Paths_grapesy - build-depends: grapesy - - other-modules: - Demo.Server.Aux.RouteGuide - Demo.Server.Cmdline - Demo.Server.Service.Greeter - Demo.Server.Service.Ping - Demo.Server.Service.RouteGuide - - Proto.API.Helloworld - Proto.API.Ping - Proto.API.RouteGuide - Proto.Helloworld - Proto.Ping - Proto.RouteGuide - - Paths_grapesy - - build-depends: - -- Inherited dependencies - , aeson - , bytestring - , containers - , exceptions - , network - , text - - build-depends: - -- Additional dependencies - , optparse-applicative >= 0.16 && < 0.19 - , proto-lens-runtime >= 0.7 && < 0.8 - , time >= 1.9 && < 1.13 - , transformers >= 0.5 && < 0.7 - - if !flag(build-demo) - buildable: - False - test-suite test-stress import: lang, common-executable-flags type: exitcode-stdio-1.0 @@ -522,11 +430,6 @@ benchmark grapesy-kvstore cpp-options: -DSTRACE build-depends: unix >= 2.7 && < 2.9 -Flag build-demo - description: Build the demo - default: False - manual: True - Flag build-stress-test description: Build the stress test default: False diff --git a/grpc-spec/src/Network/GRPC/Spec/Serialization/Headers/Common.hs b/grpc-spec/src/Network/GRPC/Spec/Serialization/Headers/Common.hs index 06229199..3bec4c29 100644 --- a/grpc-spec/src/Network/GRPC/Spec/Serialization/Headers/Common.hs +++ b/grpc-spec/src/Network/GRPC/Spec/Serialization/Headers/Common.hs @@ -53,7 +53,7 @@ buildContentType mContentType = ( -- The gRPC spec mandates different behaviour here for requests and responses: -- when parsing a request (i.e., on the server), the spec requires that the -- server responds with @415 Unsupported Media Type@. When parsing a response, --- however (i.e., on hte client), the spec mandates that we synthesize a +-- however (i.e., on the client), the spec mandates that we synthesize a -- gRPC exception. We therefore take a function as parameter to construct the -- actual error. parseContentType :: forall m rpc.