gRPC-haskell/tests/TestServer.hs
Joel Stanley 9408745254 Streaming interface tweaks (i.e., StreamSend/Recv ops in IO) (#58)
* Add clientRW', StreamRecv', StreamSend' placeholders for IO-based stream ops (instead of Streaming); concurrent hellos Haskell client; hellos client cleanup

* Fix typo

* Rename clientRW' => clientRW; fix unreg bidi testcase

* Replace serverRW operation with one that uses the IO-based stream ops instead of the Pipes.Proxy.Client ops; modify examples accordingly

* Misc formatting, minor restructuring wibbles

* Replace remaining stream send/recv operations with IO-based ops instead of
Pipes.Proxy.Client; DCR; minor style consistency tweaks.
2016-08-09 11:30:47 -05:00

71 lines
3.1 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Main where
import Prelude hiding (sum)
import Simple
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Data.Monoid
import Data.Foldable (sum)
import Data.String
import Network.GRPC.LowLevel
handleNormalCall :: ServerCall SimpleServiceRequest -> IO (SimpleServiceResponse, MetadataMap, StatusCode, StatusDetails)
handleNormalCall call =
pure (SimpleServiceResponse request result, mempty, StatusOk, StatusDetails "")
where SimpleServiceRequest request nums = payload call
result = sum nums
handleClientStreamingCall :: ServerCall () -> StreamRecv SimpleServiceRequest -> IO (Maybe SimpleServiceResponse, MetadataMap, StatusCode, StatusDetails)
handleClientStreamingCall call recvRequest = go 0 ""
where go sumAccum nameAccum =
recvRequest >>= \req ->
case req of
Left ioError -> pure (Nothing, mempty, StatusCancelled, StatusDetails ("handleClientStreamingCall: IO error: " <> fromString (show ioError)))
Right Nothing ->
pure (Just (SimpleServiceResponse nameAccum sumAccum), mempty, StatusOk, StatusDetails "")
Right (Just (SimpleServiceRequest name nums)) ->
go (sumAccum + sum nums) (nameAccum <> name)
handleServerStreamingCall :: ServerCall SimpleServiceRequest -> StreamSend SimpleServiceResponse -> IO (MetadataMap, StatusCode, StatusDetails)
handleServerStreamingCall call sendResponse = go
where go = do forM_ nums $ \num ->
sendResponse (SimpleServiceResponse requestName num)
pure (mempty, StatusOk, StatusDetails "")
SimpleServiceRequest requestName nums = payload call
handleBiDiStreamingCall :: ServerCall () -> StreamRecv SimpleServiceRequest -> StreamSend SimpleServiceResponse -> IO (MetadataMap, StatusCode, StatusDetails)
handleBiDiStreamingCall call recvRequest sendResponse = go
where go = recvRequest >>= \req ->
case req of
Left ioError -> pure (mempty, StatusCancelled, StatusDetails ("handleBiDiStreamingCall: IO error: " <> fromString (show ioError)))
Right Nothing ->
pure (mempty, StatusOk, StatusDetails "")
Right (Just (SimpleServiceRequest name nums)) ->
do sendResponse (SimpleServiceResponse name (sum nums))
go
handleDone :: MVar () -> ServerCall SimpleServiceDone -> IO (SimpleServiceDone, MetadataMap, StatusCode, StatusDetails)
handleDone exitVar req =
do forkIO (threadDelay 5000 >> putMVar exitVar ())
pure (payload req, mempty, StatusOk, StatusDetails "")
main :: IO ()
main = do exitVar <- newEmptyMVar
forkIO $ simpleServiceServer SimpleService
{ simpleServiceDone = handleDone exitVar
, simpleServiceNormalCall = handleNormalCall
, simpleServiceClientStreamingCall = handleClientStreamingCall
, simpleServiceServerStreamingCall = handleServerStreamingCall
, simpleServiceBiDiStreamingCall = handleBiDiStreamingCall }
takeMVar exitVar