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

* fix testWrongEndpoint

* test that unregistered requests are ignored by request_registered_call

* handler returns status code, drop Grpc prefix from status codes

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

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
+        (respBody, trailingMeta, status, details) <- f call
-        let status = C.GrpcStatusOk
+                                                       requestBody
+                                                       requestMeta
         let respOps = serverOpsSendNormalRegisteredResponse
                         respBody initMeta trailingMeta status details
         respOpsResults <- runOps (unServerCall call) serverCQ respOps

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
+        (respBody, respMetadata, status, details) <- f call
-        let status = C.GrpcStatusOk
+                                                       body
+                                                       requestMeta
+                                                       methodName
         let respOps = serverOpsSendNormalResponse
                         respBody respMetadata status details
         respOpsResults <- runOps call' serverCQ respOps

src/Network/GRPC/Unsafe/Op.chs

@@ -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)#}
 

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 $ \_ _ _ ->
+    r <- serverHandleNormalCall s rm 1 mempty dummyHandler
-           return ("", mempty, StatusDetails "details")
     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
+      r <- serverHandleNormalCall s rm 2 mempty dummyHandler
-        return ("reply test", dummyMeta, StatusDetails "details string")
+      r @?= Left GRPCIOTimeout
-      r @?= Right ()
+
+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 ""
+        serverCallCancel c StatusCancelled ""
-        return (mempty, mempty, "")
+        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)
+                -> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
-dummyHandler _ _ _ = return ("", mempty, 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 ()

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"
             ||

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