mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2024-06-26 14:38:35 +02:00
3366dde7ab
* begin security bindings * secure channel creation * SSL credentials support * add client-side ssl support * ssl test * read file before passing to channel credentials, free credentials when done creating * use localhost key/cert for test * WIP sketch of callbacks for metadata plugins * conversion from Haskell auth processor to C * add test for custom server metadata auth processor * wip auth failure test * rebase tweak * working test of custom auth metadata server processor * improve security docs, clean up * add unsafe layer client-side auth metadata plugin functionality * add client config option for custom auth metadata * WIP client-side metadata auth plugin. Crashing when calling C callback. * get initial version of client-side metadata plugins working * replace String with ByteString in a few places, add function for getting AuthProperty * AuthContext utilities and more documentation * end-to-end test of client and server auth plugins * remove redundant tests * function for parents in unary calls, add deactivated failing test for auth metadata propagation from parent to child * some cleanup * tweaks * more tweaks * remove unused file * docs tweak * consolidate exports * update protobuf-wire commit
84 lines
3.2 KiB
Haskell
84 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 [] [] [] [] [] Nothing
|