eeva/gRPC-haskell
1
0
Fork 0
mirror of https://github.com/unclechu/gRPC-haskell.git synced 2024-11-26 21:19:43 +01:00
Code Issues Projects Releases Wiki Activity

fix wrong endpoint test, add test, tweak handler types (#29)

Browse source 
* fix testWrongEndpoint

* test that unregistered requests are ignored by request_registered_call

* handler returns status code, drop Grpc prefix from status codes
This commit is contained in:
Connor Clark 2016-06-16 08:23:54 -07:00 committed by Joel Stanley
parent 4ce7497a33
commit 5ba5c8a42a
7 changed files with 79 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
examples/echo/echo-server/Main.hs
View file

@ -14,11 +14,11 @@ serverMeta :: MetadataMap
serverMeta = [("test_meta", "test_meta_value")]
handler :: U.ServerCall -> ByteString -> MetadataMap -> MethodName
-> IO (ByteString, MetadataMap, StatusDetails)
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
handler _call reqBody _reqMeta _method = do
--putStrLn $ "Got request for method: " ++ show method
--putStrLn $ "Got metadata: " ++ show reqMeta
return (reqBody, serverMeta, StatusDetails "")
return (reqBody, serverMeta, StatusOk, StatusDetails "")
unregMain :: IO ()
unregMain = withGRPC $ \grpc -> do
@ -35,7 +35,7 @@ regMain = withGRPC $ \grpc -> do
forever $ do
let method = head (registeredMethods server)
result <- serverHandleNormalCall server method 15 serverMeta $
\_call reqBody _reqMeta -> return (reqBody, serverMeta,
\_call reqBody _reqMeta -> return (reqBody, serverMeta, StatusOk,
StatusDetails "")
case result of
Left x -> putStrLn $ "registered call result error: " ++ show x
@ -45,7 +45,7 @@ regMain = withGRPC $ \grpc -> do
regLoop :: Server -> RegisteredMethod -> IO ()
regLoop server method = forever $ do
result <- serverHandleNormalCall server method 15 serverMeta $
\_call reqBody _reqMeta -> return (reqBody, serverMeta,
\_call reqBody _reqMeta -> return (reqBody, serverMeta, StatusOk,
StatusDetails "")
case result of
Left x -> putStrLn $ "registered call result error: " ++ show x

7
src/Network/GRPC/LowLevel/Server.hs
View file

@ -170,7 +170,7 @@ serverOpsSendNormalRegisteredResponse
-- trailing meta, and use it for both kinds of call handlers.
type ServerHandler
= ServerCall -> ByteString -> MetadataMap
-> IO (ByteString, MetadataMap, StatusDetails)
-> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails)
-- TODO: we will want to replace this with some more general concept that also
-- works with streaming calls in the future.
@ -193,8 +193,9 @@ serverHandleNormalCall s@Server{..} rm timeLimit initMeta f = do
Nothing -> error "serverHandleNormalCall(R): payload empty."
Just requestBody -> do
requestMeta <- serverCallGetMetadata call
(respBody, trailingMeta, details) <- f call requestBody requestMeta
let status = C.GrpcStatusOk
(respBody, trailingMeta, status, details) <- f call
requestBody
requestMeta
let respOps = serverOpsSendNormalRegisteredResponse
respBody initMeta trailingMeta status details
respOpsResults <- runOps (unServerCall call) serverCQ respOps

8
src/Network/GRPC/LowLevel/Server/Unregistered.hs
View file

@ -53,7 +53,7 @@ serverOpsSendNormalResponse body metadata code details =
-- request body and response body respectively.
type ServerHandler
= ServerCall -> ByteString -> MetadataMap -> MethodName
-> IO (ByteString, MetadataMap, StatusDetails)
-> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails)
-- | Handle one unregistered call.
serverHandleNormalCall :: Server
@ -76,8 +76,10 @@ serverHandleNormalCall s@Server{..} timeLimit srvMetadata f = do
methodName <- serverCallGetMethodName call
hostName <- serverCallGetHost call
grpcDebug $ "call_details host is: " ++ show hostName
(respBody, respMetadata, details) <- f call body requestMeta methodName
let status = C.GrpcStatusOk
(respBody, respMetadata, status, details) <- f call
body
requestMeta
methodName
let respOps = serverOpsSendNormalResponse
respBody respMetadata status details
respOpsResults <- runOps call' serverCQ respOps

2
src/Network/GRPC/Unsafe/Op.chs
View file

@ -14,6 +14,8 @@ import Foreign.Ptr
#include <grpc/impl/codegen/grpc_types.h>
#include <grpc_haskell.h>
{#context prefix = "grpc" #}
{#enum grpc_op_type as OpType {underscoreToCase} deriving (Eq, Show)#}
{#enum grpc_status_code as StatusCode {underscoreToCase} deriving (Eq, Show)#}

83
tests/LowLevelTests.hs
View file

@ -31,7 +31,8 @@ lowLevelTests = testGroup "Unit tests of low-level Haskell library"
, testServerCreateDestroy
, testServerCall
, testServerTimeoutNoClient
-- , testWrongEndpoint
, testWrongEndpoint
, testMixRegisteredUnregistered
, testPayload
, testPayloadUnregistered
, testServerCancel
@ -79,13 +80,9 @@ testServerTimeoutNoClient :: TestTree
testServerTimeoutNoClient =
serverOnlyTest "wait timeout when client DNE" [("/foo", Normal)] $ \s -> do
let rm = head (registeredMethods s)
r <- serverHandleNormalCall s rm 1 mempty $ \_ _ _ ->
return ("", mempty, StatusDetails "details")
r <- serverHandleNormalCall s rm 1 mempty dummyHandler
r @?= Left GRPCIOTimeout
-- TODO: fix this test: currently, client seems to hang and server times out,
-- expecting that the client reports an invalid endpoint. Also, investigate
-- intermittent crashes on shorter server timeouts (tried 2, 5 seconds)
testWrongEndpoint :: TestTree
testWrongEndpoint =
csTest "client requests unknown endpoint" client server [("/foo", Normal)]
@ -95,14 +92,55 @@ testWrongEndpoint =
client c = do
rm <- clientRegisterMethod c "/bar" Normal
r <- clientRequest c rm 1 "Hello!" mempty
r @?= Left (GRPCIOBadStatusCode GrpcStatusDeadlineExceeded
r @?= Left (GRPCIOBadStatusCode StatusDeadlineExceeded
(StatusDetails "Deadline Exceeded"))
server s = do
length (registeredMethods s) @?= 1
let rm = head (registeredMethods s)
r <- serverHandleNormalCall s rm 10 mempty $ \_ _ _ -> do
return ("reply test", dummyMeta, StatusDetails "details string")
r @?= Right ()
r <- serverHandleNormalCall s rm 2 mempty dummyHandler
r @?= Left GRPCIOTimeout
testMixRegisteredUnregistered :: TestTree
testMixRegisteredUnregistered =
csTest "server uses unregistered calls to handle unknown endpoints"
client
server
[("/foo", Normal)]
where
client c = do
rm1 <- clientRegisterMethod c "/foo" Normal
rm2 <- clientRegisterMethod c "/bar" Normal
clientRequest c rm1 1 "Hello" mempty >>= do
checkReqRslt $ \NormalRequestResult{..} -> do
rspBody @?= "reply test"
initMD @?= Just dummyMeta
trailMD @?= dummyMeta
clientRequest c rm2 1 "bad endpoint" mempty >>= do
checkReqRslt $ \NormalRequestResult{..} -> do
rspBody @?= ""
r3 <- clientRequest c rm1 1 "Hello" mempty
r3 @?= deadlineExceededStatus
return ()
server s = do
concurrently regThread unregThread
return ()
where regThread = do
let rm = head (registeredMethods s)
r <- serverHandleNormalCall s rm 2 dummyMeta $ \_ body _ -> do
body @?= "Hello"
return ("reply test", dummyMeta, StatusOk, StatusDetails "")
return ()
unregThread = do
r1 <- U.serverHandleNormalCall s 2 mempty $ \_ _ _ method -> do
method @?= "/bar"
return ("", mempty, StatusOk,
StatusDetails "Wrong endpoint")
r2 <- U.serverHandleNormalCall s 2 mempty $ \_ _ _ method -> do
method @?= "/bar"
return ("", mempty, StatusNotFound,
StatusDetails "Wrong endpoint")
r2 @?= Left GRPCIOTimeout
return ()
-- TODO: There seems to be a race here (and in other client/server pairs, of
-- course) about what gets reported when there is a failure. E.g., if one of the
@ -119,7 +157,7 @@ testPayload =
rm <- clientRegisterMethod c "/foo" Normal
clientRequest c rm 10 "Hello!" clientMD >>= do
checkReqRslt $ \NormalRequestResult{..} -> do
rspCode @?= GrpcStatusOk
rspCode @?= StatusOk
rspBody @?= "reply test"
details @?= "details string"
initMD @?= Just dummyMeta
@ -130,7 +168,8 @@ testPayload =
r <- serverHandleNormalCall s rm 11 dummyMeta $ \_ reqBody reqMD -> do
reqBody @?= "Hello!"
checkMD "Server metadata mismatch" clientMD reqMD
return ("reply test", dummyMeta, StatusDetails "details string")
return ("reply test", dummyMeta, StatusOk,
StatusDetails "details string")
r @?= Right ()
testServerCancel :: TestTree
@ -140,14 +179,14 @@ testServerCancel =
client c = do
rm <- clientRegisterMethod c "/foo" Normal
res <- clientRequest c rm 10 "" mempty
res @?= Left (GRPCIOBadStatusCode GrpcStatusCancelled
res @?= Left (GRPCIOBadStatusCode StatusCancelled
(StatusDetails
"Received RST_STREAM err=8"))
server s = do
let rm = head (registeredMethods s)
r <- serverHandleNormalCall s rm 10 mempty $ \c _ _ -> do
serverCallCancel c GrpcStatusCancelled ""
return (mempty, mempty, "")
serverCallCancel c StatusCancelled ""
return (mempty, mempty, StatusOk, "")
r @?= Right ()
testPayloadUnregistered :: TestTree
@ -157,14 +196,14 @@ testPayloadUnregistered =
client c = do
U.clientRequest c "/foo" 10 "Hello!" mempty >>= do
checkReqRslt $ \NormalRequestResult{..} -> do
rspCode @?= GrpcStatusOk
rspCode @?= StatusOk
rspBody @?= "reply test"
details @?= "details string"
server s = do
r <- U.serverHandleNormalCall s 11 mempty $ \_ body _md meth -> do
body @?= "Hello!"
meth @?= "/foo"
return ("reply test", mempty, "details string")
return ("reply test", mempty, StatusOk, "details string")
r @?= Right ()
testGoaway :: TestTree
@ -201,7 +240,7 @@ testSlowServer =
let rm = head (registeredMethods s)
serverHandleNormalCall s rm 1 mempty $ \_ _ _ -> do
threadDelay (2*10^(6 :: Int))
return ("", mempty, StatusDetails "")
return ("", mempty, StatusOk, StatusDetails "")
return ()
--------------------------------------------------------------------------------
@ -211,16 +250,16 @@ dummyMeta :: M.Map ByteString ByteString
dummyMeta = [("foo","bar")]
dummyHandler :: ServerCall -> ByteString -> MetadataMap
-> IO (ByteString, MetadataMap, StatusDetails)
dummyHandler _ _ _ = return ("", mempty, StatusDetails "")
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
dummyHandler _ _ _ = return ("", mempty, StatusOk, StatusDetails "")
unavailableStatus :: Either GRPCIOError a
unavailableStatus =
Left (GRPCIOBadStatusCode GrpcStatusUnavailable (StatusDetails ""))
Left (GRPCIOBadStatusCode StatusUnavailable (StatusDetails ""))
deadlineExceededStatus :: Either GRPCIOError a
deadlineExceededStatus =
Left (GRPCIOBadStatusCode GrpcStatusDeadlineExceeded
Left (GRPCIOBadStatusCode StatusDeadlineExceeded
(StatusDetails "Deadline Exceeded"))
nop :: Monad m => a -> m ()

4
tests/LowLevelTests/Op.hs
View file

@ -51,12 +51,12 @@ testCancelFromServer =
runSerialTest $ \grpc ->
withClientServerUnaryCall grpc $
\(c@Client{..}, s@Server{..}, cc@ClientCall{..}, sc@ServerCall{..}) -> do
serverCallCancel sc GrpcStatusPermissionDenied "TestStatus"
serverCallCancel sc StatusPermissionDenied "TestStatus"
clientRes <- runOps unClientCall clientCQ clientRecvOps
case clientRes of
Left x -> error $ "Client recv error: " ++ show x
Right [_,_,OpRecvStatusOnClientResult _ code details] -> do
code @?= GrpcStatusPermissionDenied
code @?= StatusPermissionDenied
assertBool "Received status details or RST_STREAM error" $
details == "TestStatus"
||

2
tests/UnsafeTests.hs
View file

@ -196,7 +196,7 @@ payloadServer = do
opSendMessage respOps 1 respbb
B.useAsCString "ok" $ \detailsStr ->
opSendStatusServer respOps 2 0 (MetadataKeyValPtr nullPtr)
GrpcStatusOk detailsStr
StatusOk detailsStr
serverCall <- peek serverCallPtr
respBatchError <- grpcCallStartBatch serverCall respOps 3
(tag 103) reserved