mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2024-11-18 00:59:42 +01:00
96d12c1e6c
* 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
* Use common machinery for all streaming modes; make handler types more consistent
* wibbles
70 lines
2.7 KiB
Haskell
70 lines
2.7 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
|
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
|
|
|
|
import Control.Concurrent.Async (async, wait)
|
|
import Control.Monad (forever)
|
|
import Data.ByteString (ByteString)
|
|
import Network.GRPC.LowLevel
|
|
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
|
|
import qualified Network.GRPC.LowLevel.Call.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 (ServerConfig "localhost" 50051 [] []) $ \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 methods = [(MethodName "/echo.Echo/DoEcho", Normal)]
|
|
withServer grpc (ServerConfig "localhost" 50051 methods []) $ \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 ()
|
|
|
|
-- | loop to fork n times
|
|
regLoop :: Server -> RegisteredMethod 'Normal -> IO ()
|
|
regLoop server method = forever $ do
|
|
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 ()
|
|
|
|
regMainThreaded :: IO ()
|
|
regMainThreaded = do
|
|
withGRPC $ \grpc -> do
|
|
let methods = [(MethodName "/echo.Echo/DoEcho", Normal)]
|
|
withServer grpc (ServerConfig "localhost" 50051 methods []) $ \server -> do
|
|
let method = head (normalMethods server)
|
|
tid1 <- async $ regLoop server method
|
|
tid2 <- async $ regLoop server method
|
|
wait tid1
|
|
wait tid2
|
|
return ()
|
|
|
|
main :: IO ()
|
|
main = regMainThreaded
|