gRPC-haskell/examples/hellos/hellos-server/Main.hs
Joel Stanley c1fa7956c7 "Hellos" C++/Haskell programs for exercising interop for streaming modes (#49)
* Hellos example: skeleton and server-streaming mode use

* Catch IO exceptions in dispatchLoop

* Distinguish decoding errors from other errors; convert error calls to explicit throws of GRPCIOErrors

* instance Exception GRPCIOError

* Add error checks and error messages to hellos cpp client

* Change fixed32 to uint32

* Add prelim hellos-client, hellos-server executables

* Hellos cpp example: add client-streaming mode use

* In unregistered high-level server, aggressively catch all exceptions raised in
handlers and promote then to a new GRPCIOError constructor.

* Hellos hs example: add client-streaming mode use

* Hellos cpp example: add simple bidi mode use

* Hellos hs example: add simple bidi mode use

* wibbles

* Add GRPCIOErrorEq newtype wrapper w/ Eq instance for testing purposes

* Refactoring wibbles

* README wibbles

* DCR

* Fix rebase derp

* Remove libdl dep, update protobuf github link in hellos cpp Makefile.

* Use Data.Coerce.coerce for GRPCIOErrorEq; remove warnings

* Report expected/got errors in Haskell hellos client/server

* Report expected/got errors in cpp hellos client/server

* Add some instructions for running the hellos client/server

* Fix warnings

* Rename logShow to logMsg and use stderr for logging

* Tweak compliation parameters for hellos hs executables; increase constant workload

* Remove unnecessary type annotation

* Simplify handleError in dispatchLoop

* Remove GRPCIOErrorEq and coerce use; change GRPCIOHandlerException type
2016-07-26 15:21:35 -07:00

83 lines
3.2 KiB
Haskell

{-# 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 Data.Protobuf.Wire.Class
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
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 [] [] [] [] []