mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2024-07-06 11:23:30 +02:00
* Tweak runOps param order, inline common op sequences, clean up serverHandleNormalCall * More ops sequence inlining for clarity, experimenting with Managed * Checkpoint: preliminary support for all streaming modes; much cleanup/refactoring and api design still needed * Use mempty for default StatusDetails; tweak bad status matching mechanism * Preliminary user-facing, server-streaming, low-level api and test * renaming wibbles * Preliminary user-facing, client-streaming, low-level api and test * Move sendMsgs comb to Network.GRPC.LowLevel.Op; misc cleanup/DCR * Modify bidi streaming to omit request payload * Add transformers dep * Preliminary user-facing low-level bidirectional streaming api and test * Fix missing peek import * Remove TimeoutSeconds params on streaming mode functions * Fix serverHandleNormalCall rebase wart * Fix rebase warts; minor hlint fixes and wibbles * Post-rebase tweaks to optional payload use in serverRequestCall (i.e., now respects payloadHandling again) * Cleanup/refactor serverRequestCall * Fix comment * Change ServerRWHandler type so that handler does not have to invoke a finalizer * Change ServerReaderHandler type so that handler does not have to invoke a finalizer * Simplify serverWriter interface and ServerWriterHandler structure * Simplify serverRW (get rid of exec param), improve bidi streaming tests * Use ExceptT in serverRW impl * Change ServerRWHandler type to pass recv/send operations. * Renaming * Define ClientRWHandler, pass recv/send ops * wibbles * Use ExceptT in clientRW impl * Add DataKinded phantom typing to RegisteredMethod; misc cleanup * Simplify sendMsgs interface; add SingleSend type and related helpers * Rename SingleSend to SendSingle, use ExceptT to clean up {client,server}Writer and sendMsgs * More ExceptT cleanup in clientWriter * Factor out reusable bits of clientWriter * Shrink ServerReaderHandler * Delete stale comments * begin high-level server interface * update to datakind representation * clean up * move method type info to type level, parametrize ServerCall by payload * convert for writer handler * start switching over to Message-based handlers * begin work on highlevel example * comment out old code * parametrize StreamSend * parametrize StreamRecv * conversion for ServerReaderHandler * finish handler conversions * Add high level version and payload checking to echo-client * Decouple server CQs from call-bound CQs (registered methods); use more consistent naming conventions * Decouple server/call-bound CQs for unregistered methods; refactor U.serverRequestCall; misc cleanup * Make convertRecv total; formatting wibbles
124 lines
4.6 KiB
Haskell
124 lines
4.6 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
|
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
|
|
|
|
import Control.Concurrent
|
|
import Control.Concurrent.Async
|
|
import Control.Monad
|
|
import Data.ByteString (ByteString)
|
|
import Data.Protobuf.Wire.Class
|
|
import qualified Data.Text as T
|
|
import Data.Word
|
|
import GHC.Generics (Generic)
|
|
import Network.GRPC.HighLevel.Server
|
|
import Network.GRPC.LowLevel
|
|
import qualified Network.GRPC.LowLevel.Call.Unregistered as U
|
|
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
|
|
|
|
serverMeta :: MetadataMap
|
|
serverMeta = [("test_meta", "test_meta_value")]
|
|
|
|
handler :: U.ServerCall
|
|
-> ByteString
|
|
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
|
|
handler U.ServerCall{..} reqBody = do
|
|
--putStrLn $ "Got request for method: " ++ show method
|
|
--putStrLn $ "Got metadata: " ++ show reqMeta
|
|
return (reqBody, serverMeta, StatusOk, StatusDetails "")
|
|
|
|
unregMain :: IO ()
|
|
unregMain = withGRPC $ \grpc -> do
|
|
withServer grpc defConfig $ \server -> forever $ do
|
|
result <- U.serverHandleNormalCall server serverMeta handler
|
|
case result of
|
|
Left x -> putStrLn $ "handle call result error: " ++ show x
|
|
Right _ -> return ()
|
|
|
|
regMain :: IO ()
|
|
regMain = withGRPC $ \grpc -> do
|
|
let ms = [(MethodName "/echo.Echo/DoEcho")]
|
|
withServer grpc (defConfig {methodsToRegisterNormal = ms}) $ \server ->
|
|
forever $ do
|
|
let method = head (normalMethods server)
|
|
result <- serverHandleNormalCall server method serverMeta $
|
|
\_call reqBody _reqMeta -> return (reqBody, serverMeta, StatusOk,
|
|
StatusDetails "")
|
|
case result of
|
|
Left x -> putStrLn $ "registered call result error: " ++ show x
|
|
Right _ -> return ()
|
|
|
|
tputStrLn x = do
|
|
tid <- myThreadId
|
|
putStrLn $ "[" ++ show tid ++ "]: " ++ x
|
|
|
|
regLoop :: Server -> RegisteredMethod 'Normal -> IO ()
|
|
regLoop server method = forever $ do
|
|
-- tputStrLn "about to block on call handler"
|
|
result <- serverHandleNormalCall server method serverMeta $
|
|
\_call reqBody _reqMeta ->
|
|
return (reqBody, serverMeta, StatusOk, StatusDetails "")
|
|
case result of
|
|
Left x -> error $! "registered call result error: " ++ show x
|
|
Right _ -> return ()
|
|
|
|
regMainThreaded :: IO ()
|
|
regMainThreaded = do
|
|
withGRPC $ \grpc -> do
|
|
let ms = [(MethodName "/echo.Echo/DoEcho")]
|
|
withServer grpc (defConfig {methodsToRegisterNormal = ms}) $ \server -> do
|
|
let method = head (normalMethods server)
|
|
tids <- replicateM 7 $ async $ do tputStrLn "starting handler"
|
|
regLoop server method
|
|
waitAnyCancel tids
|
|
tputStrLn "finishing"
|
|
|
|
-- NB: If you change these, make sure to change them in the client as well.
|
|
-- TODO: Put these in a common location (or just hack around it until CG is working)
|
|
data EchoRequest = EchoRequest {message :: T.Text} deriving (Show, Eq, Ord, Generic)
|
|
instance Message EchoRequest
|
|
data AddRequest = AddRequest {addX :: Word32, addY :: Word32} deriving (Show, Eq, Ord, Generic)
|
|
instance Message AddRequest
|
|
data AddResponse = AddResponse {answer :: Word32} deriving (Show, Eq, Ord, Generic)
|
|
instance Message AddResponse
|
|
|
|
highlevelMain :: IO ()
|
|
highlevelMain =
|
|
serverLoop defaultOptions{optNormalHandlers = [echoHandler, addHandler]}
|
|
where echoHandler =
|
|
UnaryHandler "/echo.Echo/DoEcho" $
|
|
\_c body m -> do
|
|
tputStrLn $ "UnaryHandler for DoEcho hit, body=" ++ show body
|
|
return ( body :: EchoRequest
|
|
, m
|
|
, StatusOk
|
|
, StatusDetails ""
|
|
)
|
|
addHandler =
|
|
--TODO: I can't get this one to execute. Is the generated method
|
|
--name different?
|
|
|
|
-- static const char* Add_method_names[] = {
|
|
-- "/echo.Add/DoAdd",
|
|
-- };
|
|
|
|
UnaryHandler "/echo.Add/DoAdd" $
|
|
\_c b m -> do
|
|
tputStrLn $ "UnaryHandler for DoAdd hit, b=" ++ show b
|
|
print (addX b)
|
|
print (addY b)
|
|
return ( AddResponse $ addX b + addY b
|
|
, m
|
|
, StatusOk
|
|
, StatusDetails ""
|
|
)
|
|
|
|
main :: IO ()
|
|
main = highlevelMain
|
|
|
|
defConfig :: ServerConfig
|
|
defConfig = ServerConfig "localhost" 50051 [] [] [] [] []
|