gRPC-haskell/tests/TestServer.hs

75 lines
3.5 KiB
Haskell
Raw Normal View History

2016-07-26 01:37:06 +02:00
{-# LANGUAGE OverloadedStrings #-}
2016-08-13 00:48:28 +02:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
2016-07-26 01:37:06 +02:00
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
2016-08-13 00:48:28 +02:00
import Network.GRPC.HighLevel.Server
2016-12-08 19:10:32 +01:00
import Network.GRPC.HighLevel.Generated (defaultServiceOptions)
2016-07-26 01:37:06 +02:00
2016-08-13 00:48:28 +02:00
handleNormalCall :: ServerRequest 'Normal SimpleServiceRequest SimpleServiceResponse -> IO (ServerResponse 'Normal SimpleServiceResponse)
handleNormalCall (ServerNormalRequest meta (SimpleServiceRequest request nums)) =
pure (ServerNormalResponse (SimpleServiceResponse request result) mempty StatusOk (StatusDetails ""))
where result = sum nums
2016-07-26 01:37:06 +02:00
2016-08-13 00:48:28 +02:00
handleClientStreamingCall :: ServerRequest 'ClientStreaming SimpleServiceRequest SimpleServiceResponse -> IO (ServerResponse 'ClientStreaming SimpleServiceResponse)
handleClientStreamingCall (ServerReaderRequest call recvRequest) = go 0 ""
2016-07-26 01:37:06 +02:00
where go sumAccum nameAccum =
recvRequest >>= \req ->
case req of
2016-08-13 00:48:28 +02:00
Left ioError -> pure (ServerReaderResponse Nothing mempty StatusCancelled (StatusDetails ("handleClientStreamingCall: IO error: " <> fromString (show ioError))))
2016-07-26 01:37:06 +02:00
Right Nothing ->
2016-08-13 00:48:28 +02:00
pure (ServerReaderResponse (Just (SimpleServiceResponse nameAccum sumAccum)) mempty StatusOk (StatusDetails ""))
2016-07-26 01:37:06 +02:00
Right (Just (SimpleServiceRequest name nums)) ->
go (sumAccum + sum nums) (nameAccum <> name)
2016-08-13 00:48:28 +02:00
handleServerStreamingCall :: ServerRequest 'ServerStreaming SimpleServiceRequest SimpleServiceResponse -> IO (ServerResponse 'ServerStreaming SimpleServiceResponse)
handleServerStreamingCall (ServerWriterRequest call (SimpleServiceRequest requestName nums) sendResponse) = go
2016-07-26 01:37:06 +02:00
where go = do forM_ nums $ \num ->
sendResponse (SimpleServiceResponse requestName num)
2016-08-13 00:48:28 +02:00
pure (ServerWriterResponse mempty StatusOk (StatusDetails ""))
2016-07-26 01:37:06 +02:00
2016-08-13 00:48:28 +02:00
handleBiDiStreamingCall :: ServerRequest 'BiDiStreaming SimpleServiceRequest SimpleServiceResponse -> IO (ServerResponse 'BiDiStreaming SimpleServiceResponse)
handleBiDiStreamingCall (ServerBiDiRequest call recvRequest sendResponse) = go
2016-07-26 01:37:06 +02:00
where go = recvRequest >>= \req ->
case req of
2016-08-13 00:48:28 +02:00
Left ioError ->
pure (ServerBiDiResponse mempty StatusCancelled (StatusDetails ("handleBiDiStreamingCall: IO error: " <> fromString (show ioError))))
2016-07-26 01:37:06 +02:00
Right Nothing ->
2016-08-13 00:48:28 +02:00
pure (ServerBiDiResponse mempty StatusOk (StatusDetails ""))
2016-07-26 01:37:06 +02:00
Right (Just (SimpleServiceRequest name nums)) ->
do sendResponse (SimpleServiceResponse name (sum nums))
go
2016-08-13 00:48:28 +02:00
handleDone :: MVar () -> ServerRequest 'Normal SimpleServiceDone SimpleServiceDone -> IO (ServerResponse 'Normal SimpleServiceDone)
handleDone exitVar (ServerNormalRequest _ req) =
2016-07-26 01:37:06 +02:00
do forkIO (threadDelay 5000 >> putMVar exitVar ())
2016-08-13 00:48:28 +02:00
pure (ServerNormalResponse req mempty StatusOk (StatusDetails ""))
2016-07-26 01:37:06 +02:00
main :: IO ()
main = do exitVar <- newEmptyMVar
2016-12-08 19:10:32 +01:00
forkIO $ simpleServiceServer (SimpleService
{ simpleServicedone = handleDone exitVar
, simpleServicenormalCall = handleNormalCall
, simpleServiceclientStreamingCall = handleClientStreamingCall
, simpleServiceserverStreamingCall = handleServerStreamingCall
, simpleServicebiDiStreamingCall = handleBiDiStreamingCall })
2016-12-08 19:10:32 +01:00
defaultServiceOptions
2016-07-26 01:37:06 +02:00
takeMVar exitVar