diff --git a/examples/echo/echo-server/Main.hs b/examples/echo/echo-server/Main.hs index 9a08fac..dac5fdb 100644 --- a/examples/echo/echo-server/Main.hs +++ b/examples/echo/echo-server/Main.hs @@ -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 diff --git a/src/Network/GRPC/LowLevel/Server.hs b/src/Network/GRPC/LowLevel/Server.hs index 759457f..80f401f 100644 --- a/src/Network/GRPC/LowLevel/Server.hs +++ b/src/Network/GRPC/LowLevel/Server.hs @@ -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 diff --git a/src/Network/GRPC/LowLevel/Server/Unregistered.hs b/src/Network/GRPC/LowLevel/Server/Unregistered.hs index 323c2f3..66d4688 100644 --- a/src/Network/GRPC/LowLevel/Server/Unregistered.hs +++ b/src/Network/GRPC/LowLevel/Server/Unregistered.hs @@ -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 diff --git a/src/Network/GRPC/Unsafe/Op.chs b/src/Network/GRPC/Unsafe/Op.chs index 7205682..b0078ac 100644 --- a/src/Network/GRPC/Unsafe/Op.chs +++ b/src/Network/GRPC/Unsafe/Op.chs @@ -14,6 +14,8 @@ import Foreign.Ptr #include #include +{#context prefix = "grpc" #} + {#enum grpc_op_type as OpType {underscoreToCase} deriving (Eq, Show)#} {#enum grpc_status_code as StatusCode {underscoreToCase} deriving (Eq, Show)#} diff --git a/tests/LowLevelTests.hs b/tests/LowLevelTests.hs index 337ca58..3ea7ffd 100644 --- a/tests/LowLevelTests.hs +++ b/tests/LowLevelTests.hs @@ -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 () diff --git a/tests/LowLevelTests/Op.hs b/tests/LowLevelTests/Op.hs index ac454e0..a27fb8f 100644 --- a/tests/LowLevelTests/Op.hs +++ b/tests/LowLevelTests/Op.hs @@ -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" || diff --git a/tests/UnsafeTests.hs b/tests/UnsafeTests.hs index 546267e..62e1359 100644 --- a/tests/UnsafeTests.hs +++ b/tests/UnsafeTests.hs @@ -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